, driftTo -- private
)
where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder.ByteString as BB
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.Reader
import qualified Data.Attoparsec.Char8 as P
import qualified Data.Attoparsec.Lazy as LP
import Data.ByteString (ByteString)
+import qualified Data.ByteString as Strict
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as Lazy
-import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Foldable (toList)
import Data.List
import qualified Data.Map as M
import Data.Maybe
+import Data.Monoid
import Data.Monoid.Unicode
-import qualified Data.Sequence as S
+import Data.Sequence (Seq)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-import qualified Data.Text.Encoding.Error as T
import Data.Time
import qualified Data.Time.HTTP as HTTP
import Network.HTTP.Lucu.Abortion
toPairWithFormData (name, value)
= let fd = FormData {
fdFileName = Nothing
- , fdContent = L8.fromChunks [value]
+ , fdContent = Lazy.fromChunks [value]
}
- in (T.decodeUtf8With T.lenientDecode name, fd)
+ in (T.decodeUtf8 name, fd)
-- |Get a value of given request header. Comparison of header name is
-- case-insensitive. Note that this action is not intended to be used
askForInput itr
else
do driftTo DecidingHeader
- return L8.empty
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
liftIO $ atomically
$ do chunkLen ← readItr itrReqChunkLength id itr
writeItr itrWillReceiveBody True itr
- if fmap (> actualLimit) chunkLen ≡ Just True then
+ if ((> actualLimit) <$> chunkLen) ≡ Just True then
-- 受信前から多過ぎる事が分かってゐる
tooLarge actualLimit
else
writeItr itrReqBodyWanted (Just actualLimit) itr
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
- $ do chunk ← readItr itrReceivedBody chunksToLBS itr
- chunkIsOver ← readItr itrReqChunkIsOver id itr
- if L8.length chunk < fromIntegral actualLimit then
+ $ do chunkLen ← readItr itrReceivedBodyLen id itr
+ chunkIsOver ← readItr itrReqChunkIsOver id itr
+ if chunkLen < actualLimit then
-- 要求された量に滿たなくて、まだ殘りが
-- あるなら再試行。
unless chunkIsOver
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにする
-- とメモリの無駄になるので除去。
+ chunk ← readItr itrReceivedBody seqToLBS itr
writeItr itrReceivedBody (∅) itr
return chunk
+
driftTo DecidingHeader
return chunk
tooLarge lim = abortSTM RequestEntityTooLarge []
(Just $ "Request body must be smaller than "
⊕ T.pack (show lim) ⊕ " bytes.")
+
+seqToLBS ∷ Seq ByteString → Lazy.ByteString
+{-# INLINE seqToLBS #-}
+seqToLBS = Lazy.fromChunks ∘ toList
-- | Computation of @'inputChunk' limit@ attempts to read a part of
-- request body up to @limit@ bytes. You can read any large request by
askForInput itr
else
do driftTo DecidingHeader
- return L8.empty
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
$ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do writeItr itrReqBodyWanted (Just actualLimit) itr
- writeItr itrWillReceiveBody True itr
+ $ do writeItr itrReqBodyWanted (Just actualLimit) itr
+ writeItr itrWillReceiveBody True itr
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
- $ do chunk ← readItr itrReceivedBody chunksToLBS itr
- -- 要求された量に滿たなくて、まだ殘りがあ
- -- るなら再試行。
- when (L8.length chunk < fromIntegral actualLimit)
- $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
- unless chunkIsOver
- $ retry
- -- 成功
- writeItr itrReceivedBody (∅) itr
- return chunk
- when (L8.null chunk)
+ $ do chunkLen ← readItr itrReceivedBodyLen id itr
+ -- 要求された量に滿たなくて、まだ殘りがある
+ -- なら再試行。
+ when (chunkLen < actualLimit)
+ $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
+ unless chunkIsOver
+ $ retry
+ -- 成功
+ chunk ← readItr itrReceivedBody seqToLBS itr
+ writeItr itrReceivedBody (∅) itr
+ return chunk
+ when (Lazy.null chunk)
$ driftTo DecidingHeader
return chunk
-- | Computation of @'inputForm' limit@ attempts to read the request
-- body with 'input' and parse it as
--- application\/x-www-form-urlencoded or multipart\/form-data. If the
--- request header \"Content-Type\" is neither of them, 'inputForm'
+-- @application\/x-www-form-urlencoded@ or @multipart\/form-data@. If
+-- the request header \"Content-Type\" is neither of them, 'inputForm'
-- makes 'Resource' abort with status \"415 Unsupported Media
-- Type\". If the request has no \"Content-Type\", it aborts with
-- \"400 Bad Request\".
+--
+-- Field names in @multipart\/form-data@ will be precisely decoded in
+-- accordance with RFC 2231. On the other hand,
+-- @application\/x-www-form-urlencoded@ says nothing about the
+-- encoding of field names, so they'll always be decoded in UTF-8.
inputForm ∷ Int → Resource [(Text, FormData)]
inputForm limit
= do cTypeM ← getContentType
→ readMultipartFormData params
Just cType
→ abort UnsupportedMediaType []
- (Just $ "Unsupported media type: " ⊕ A.toText (printMIMEType cType))
+ $ Just
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Unsupported media type: "
+ ⊕ printMIMEType cType
where
readWWWFormURLEncoded
= (map toPairWithFormData ∘ parseWWWFormURLEncoded)
(bsToAscii =≪ input limit)
bsToAscii bs
- = case A.fromByteString (C8.concat (L8.toChunks bs)) of
+ = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
Just a → return a
Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
redirect code uri
= do when (code ≡ NotModified ∨ not (isRedirection code))
$ abort InternalServerError []
- (Just $ "Attempted to redirect with status " ⊕ A.toText (printStatusCode code))
+ $ Just
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Attempted to redirect with status "
+ ⊕ printStatusCode code
setStatus code
setLocation uri
-- | Computation of @'setContentType' mType@ sets the response header
-- \"Content-Type\" to @mType@.
setContentType ∷ MIMEType → Resource ()
-setContentType mType
- = setHeader "Content-Type" (printMIMEType mType)
+setContentType
+ = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
-- | Computation of @'setLocation' uri@ sets the response header
-- \"Location\" to @uri@.
-- \/dev\/random.
output ∷ Lazy.ByteString → Resource ()
{-# INLINE output #-}
-output str = do outputChunk str
- driftTo Done
+output str = outputChunk str *> driftTo Done
-- | Computation of @'outputChunk' str@ writes @str@ as a part of
-- response body. You can compute this action multiple times to write
unless (discardBody)
$ sendChunks wholeChunk limit
- unless (L8.null wholeChunk)
+ unless (Lazy.null wholeChunk)
$ liftIO $ atomically $
writeItr itrBodyIsNull False itr
where
- -- チャンクの大きさは Config で制限されてゐる。もし例へば
- -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
- -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
- -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
- -- く爲にチャンクの大きさを測るからだ。
sendChunks ∷ Lazy.ByteString → Int → Resource ()
sendChunks str limit
- | L8.null str = return ()
- | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
- itr ← getInteraction
- liftIO $ atomically $
- do buf ← readItr itrBodyToSend id itr
- if S.null buf then
- -- バッファが消化された
- writeItr itrBodyToSend (chunksFromLBS chunk) itr
- else
- -- 消化されるのを待つ
- retry
- -- 殘りのチャンクについて繰り返す
- sendChunks remaining limit
+ | Lazy.null str = return ()
+ | otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
+ itr ← getInteraction
+ liftIO $ atomically
+ $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
+ sendChunks remaining limit
+
+ chunkToBuilder ∷ Lazy.ByteString → Builder
+ chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
{-
projects / Lucu.git / blobdiff