{-# LANGUAGE
- GeneralizedNewtypeDeriving
+ BangPatterns
+ , GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
-- /Examining Request/ and the final state is /Done/.
--
-- [/Examining Request/] In this state, a 'Resource' looks at the
--- request header fields and thinks about a corresponding entity for
--- it. If there is a suitable entity, the 'Resource' tells the
+-- request header fields and thinks about the corresponding entity
+-- for it. If there is a suitable entity, the 'Resource' tells the
-- system an entity tag and its last modification time
-- ('foundEntity'). If it found no entity, it tells the system so
-- ('foundNoEntity'). In case it is impossible to decide the
-- socket, the system sends \"100 Continue\" to the client if need
-- be. When a 'Resource' transits to the next state without
-- receiving all or part of a request body, the system automatically
--- receives and discards it.
+-- discards it.
--
--- [/Deciding Header/] A 'Resource' makes a decision of status code
--- and response header fields. When it transits to the next state,
--- the system validates and completes the response header fields and
+-- [/Deciding Header/] A 'Resource' makes a decision of response
+-- status code and header fields. When it transits to the next
+-- state, the system validates and completes the header fields and
-- then sends them to the client.
--
-- [/Sending Body/] In this state, a 'Resource' asks the system to
, foundETag
, foundTimeStamp
, foundNoEntity
+ , foundNoEntity'
-- * Receiving a request body
-- |These functions make the 'Resource' transit to the /Receiving
, deleteHeader
-- * Sending a response body
- -- |These functions make the 'Resource' transit to the /Sending
- -- Body/ state.
+
+ -- |These functions make the 'Resource' transit to the
+ -- /Sending Body/ state.
, putChunk
, putChunks
, putBuilder
)
where
-import qualified Blaze.ByteString.Builder.ByteString as BB
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder as BB
+import qualified Blaze.ByteString.Builder.Internal as BB
import Control.Applicative
import Control.Monad
import Control.Monad.IO.Class
import Data.ByteString (ByteString)
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
-import qualified Data.ByteString.Lazy.Internal as Lazy
-import Data.Foldable (toList)
import Data.List
import qualified Data.Map as M
import Data.Maybe
+import Data.Monoid
import Data.Monoid.Unicode
-import Data.Sequence (Seq)
-import Data.Sequence.Unicode hiding ((∅))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- |@'getHeader' name@ returns the value of the request header field
-- @name@. Comparison of header name is case-insensitive. Note that
-- this function is not intended to be used so frequently: there
--- should be actions like 'getContentType' for every common headers.
+-- should be functions like 'getContentType' for every common headers.
getHeader ∷ CIAscii → Resource (Maybe Ascii)
getHeader name
= H.getHeader name <$> getRequest
toTuple (AcceptEncoding {..})
= (aeEncoding, aeQValue)
--- |Return 'True' iff a given content-coding is acceptable.
+-- |Return 'True' iff a given content-coding is acceptable by the
+-- client.
isEncodingAcceptable ∷ CIAscii → Resource Bool
isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
where
driftTo ReceivingBody
+-- |'foundNoEntity'' is the same as @'foundNoEntity' 'Nothing'@.
+foundNoEntity' ∷ Resource ()
+{-# INLINE foundNoEntity' #-}
+foundNoEntity' = foundNoEntity Nothing
+
-- |@'getChunks' limit@ attemts to read the entire request body up to
-- @limit@ bytes, and then make the 'Resource' transit to the
-- When the @limit@ is 'Nothing', 'getChunks' uses the default
-- limitation value ('cnfMaxEntityLength') instead.
--
--- 'getChunks' returns a 'Lazy.ByteString' but it's not really lazy:
--- reading from the socket just happens at the computation of
+-- 'getChunks' returns a lazy 'Lazy.ByteString' but it's not really
+-- lazy: reading from the socket just happens at the computation of
-- 'getChunks', not at the evaluation of the 'Lazy.ByteString'.
getChunks ∷ Maybe Int → Resource Lazy.ByteString
getChunks (Just n)
getChunks' ∷ Int → Resource Lazy.ByteString
getChunks' limit = go limit (∅)
where
- go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
- go 0 _ = do chunk ← getChunk 1
- if Strict.null chunk then
- return (∅)
- else
- abort $ mkAbortion' RequestEntityTooLarge
- $ "Request body must be smaller than "
- ⊕ T.pack (show limit)
- ⊕ " bytes."
- go n xs = do let n' = min n Lazy.defaultChunkSize
- chunk ← getChunk n'
- if Strict.null chunk then
- -- Got EOF
- return $ Lazy.fromChunks $ toList xs
- else
- do let n'' = n' - Strict.length chunk
- xs' = xs ⊳ chunk
- go n'' xs'
+ go ∷ Int → Builder → Resource Lazy.ByteString
+ go 0 _ = do chunk ← getChunk 1
+ if Strict.null chunk then
+ return (∅)
+ else
+ abort $ mkAbortion' RequestEntityTooLarge
+ $ "Request body must be smaller than "
+ ⊕ T.pack (show limit)
+ ⊕ " bytes."
+ go !n !b = do c ← getChunk $ min n BB.defaultBufferSize
+ if Strict.null c then
+ -- Got EOF
+ return $ BB.toLazyByteString b
+ else
+ do let n' = n - Strict.length c
+ xs' = b ⊕ BB.fromByteString c
+ go n' xs'
-- |@'getForm' limit@ attempts to read the request body with
-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
case LP.parse (p b) src of
LP.Done _ formList
→ return formList
- _ → abort $ mkAbortion' BadRequest "Unparsable multipart/form-data"
+ LP.Fail _ eCtx e
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable multipart/form-data: "
+ ⊕ T.pack (intercalate ", " eCtx)
+ ⊕ ": "
+ ⊕ T.pack e
where
p b = do xs ← multipartFormP b
P.endOfInput
_ → abort $ mkAbortion' InternalServerError
"setContentEncoding: Unknown HTTP version"
setHeader "Content-Encoding"
- (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
+ $ A.fromAsciiBuilder
+ $ mconcat
+ $ intersperse (A.toAsciiBuilder ", ")
+ $ map tr codings
where
toAB = A.toAsciiBuilder ∘ A.fromCIAscii
putChunk ∷ Strict.ByteString → Resource ()
putChunk = putBuilder ∘ BB.fromByteString
--- |Write a chunk in 'Lazy.ByteString' to the response body. It is
--- safe to apply this function to an infinitely long
--- 'Lazy.ByteString'.
+-- |Write a chunk in lazy 'Lazy.ByteString' to the response body. It
+-- can be safely applied to an infinitely long 'Lazy.ByteString'.
--
-- Note that you must first declare the response header
-- \"Content-Type\" before applying this function. See
projects / Lucu.git / blobdiff