+ p = do xs ← eTagListP
+ P.endOfInput
+ return xs
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundTimeStamp' performs \"If-Modified-Since\" test or
+-- \"If-Unmodified-Since\" test instead of \"If-Match\" test or
+-- \"If-None-Match\" test. Be aware that any tests based on a last
+-- modification time are unsafe because it is possible to mess up such
+-- tests by modifying the entity twice in a second.
+--
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.
+foundTimeStamp ∷ UTCTime → Resource ()
+foundTimeStamp timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ when (method ≡ POST)
+ $ abort InternalServerError []
+ (Just "Illegal computation of foundTimeStamp for POST request.")
+
+ let statusForIfModSince
+ = if method ≡ GET ∨ method ≡ HEAD then
+ NotModified
+ else
+ PreconditionFailed
+
+ -- If-Modified-Since があればそれを見る。
+ ifModSince ← getHeader "If-Modified-Since"
+ case ifModSince of
+ Just str → case HTTP.fromAscii str of
+ Right lastTime
+ → when (timeStamp ≤ lastTime)
+ $ abort statusForIfModSince []
+ (Just $ "The entity has not been modified since " ⊕ A.toText str)
+ Left _
+ → return () -- 不正な時刻は無視
+ Nothing → return ()
+
+ -- If-Unmodified-Since があればそれを見る。
+ ifUnmodSince ← getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ Just str → case HTTP.fromAscii str of
+ Right lastTime
+ → when (timeStamp > lastTime)
+ $ abort PreconditionFailed []
+ (Just $ "The entity has not been modified since " ⊕ A.toText str)
+ Left _
+ → return () -- 不正な時刻は無視
+ Nothing → return ()
+
+ driftTo ReceivingBody
+
+-- |@'foundNoEntity' mStr@ tells the system that the 'Resource' found
+-- no entity for the request URI. @mStr@ is an optional error message
+-- to be replied to the client.
+--
+-- If the request method is PUT, 'foundNoEntity' performs \"If-Match\"
+-- test and when that fails it aborts with status \"412 Precondition
+-- Failed\". If the request method is GET, HEAD, POST or DELETE,
+-- 'foundNoEntity' always aborts with status \"404 Not Found\".
+foundNoEntity ∷ Maybe Text → Resource ()
+foundNoEntity msgM
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≢ PUT)
+ $ abort NotFound [] msgM
+
+ -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+ -- If-Match: 條件も滿たさない。
+ ifMatch ← getHeader "If-Match"
+ when (ifMatch ≢ Nothing)
+ $ abort PreconditionFailed [] msgM
+
+ driftTo ReceivingBody
+
+
+-- |@'getChunks' limit@ attemts to read the entire request body up to
+-- @limit@ bytes, and then make the 'Resource' transit to the
+-- /Deciding Header/ state. When the actual size of the body is larger
+-- than @limit@ bytes, 'getChunks' immediately aborts with status
+-- \"413 Request Entity Too Large\". When the request has no body, it
+-- returns an empty string.
+--
+-- 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', not at the evaluation of the 'Lazy.ByteString'.
+getChunks ∷ Maybe Int → Resource Lazy.ByteString
+getChunks (Just n)
+ | n < 0 = fail ("getChunks: limit must not be negative: " ⧺ show n)
+ | n ≡ 0 = return (∅)
+ | otherwise = getChunks' n
+getChunks Nothing
+ = getConfig ≫= getChunks ∘ Just ∘ cnfMaxEntityLength
+
+getChunks' ∷ Int → Resource Lazy.ByteString
+getChunks' limit = go limit (∅)
+ where
+ go ∷ Int → Seq Strict.ByteString → Resource Lazy.ByteString
+ go 0 _ = abort RequestEntityTooLarge []
+ (Just $ "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'
+
+-- |@'getForm' limit@ attempts to read the request body with
+-- 'getChunks' and parse it as @application\/x-www-form-urlencoded@ or
+-- @multipart\/form-data@. If the request header \"Content-Type\" is
+-- neither of them, 'getForm' aborts 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 character
+-- encodings for field names, so they'll always be decoded in
+-- UTF-8. (This could be a bad design, but I can't think of any better
+-- idea.)
+getForm ∷ Maybe Int → Resource [(Text, FormData)]
+getForm limit
+ = do cTypeM ← getContentType
+ case cTypeM of
+ Nothing
+ → abort BadRequest [] (Just "Missing Content-Type")
+ Just (MIMEType "application" "x-www-form-urlencoded" _)
+ → readWWWFormURLEncoded
+ Just (MIMEType "multipart" "form-data" params)
+ → readMultipartFormData params
+ Just cType
+ → abort UnsupportedMediaType []
+ $ Just
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Unsupported media type: "
+ ⊕ printMIMEType cType
+ where
+ readWWWFormURLEncoded
+ = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
+ <$>
+ (bsToAscii =≪ getChunks limit)
+
+ bsToAscii bs
+ = case A.fromByteString (Strict.concat (Lazy.toChunks bs)) of
+ Just a → return a
+ Nothing → abort BadRequest [] (Just "Malformed x-www-form-urlencoded")
+
+ readMultipartFormData params
+ = do case M.lookup "boundary" params of
+ Nothing
+ → abort BadRequest [] (Just "Missing boundary of multipart/form-data")
+ Just boundary
+ → do src ← getChunks limit
+ b ← case A.fromText boundary of
+ Just b → return b
+ Nothing → abort BadRequest []
+ (Just $ "Malformed boundary: " ⊕ boundary)
+ case LP.parse (p b) src of
+ LP.Done _ formList
+ → return formList
+ _ → abort BadRequest [] (Just "Unparsable multipart/form-data")
+ where
+ p b = do xs ← multipartFormP b
+ P.endOfInput
+ return xs
+
+-- |@'redirect' code uri@ declares the response status as @code@ and
+-- \"Location\" header field as @uri@. The @code@ must satisfy
+-- 'isRedirection' or it raises an error.
+redirect ∷ StatusCode → URI → Resource ()
+redirect code uri
+ = do when (code ≡ NotModified ∨ not (isRedirection code))
+ $ abort InternalServerError []
+ $ Just
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Attempted to redirect with status "
+ ⊕ printStatusCode code
+ setStatus code
+ setLocation uri
+
+-- |@'setContentType' mType@ declares the response header
+-- \"Content-Type\" as @mType@. Declaring \"Content-Type\" is
+-- mandatory for sending a response body.
+setContentType ∷ MIMEType → Resource ()
+setContentType
+ = setHeader "Content-Type" ∘ A.fromAsciiBuilder ∘ printMIMEType
+
+-- |@'setLocation' uri@ declares the response header \"Location\" as
+-- @uri@. You usually don't need to call this function directly.
+setLocation ∷ URI → Resource ()
+setLocation uri
+ = case A.fromChars uriStr of
+ Just a → setHeader "Location" a
+ Nothing → abort InternalServerError []
+ (Just $ "Malformed URI: " ⊕ T.pack uriStr)
+ where
+ uriStr = uriToString id uri ""
+
+-- |@'setContentEncoding' codings@ declares the response header
+-- \"Content-Encoding\" as @codings@.
+setContentEncoding ∷ [CIAscii] → Resource ()
+setContentEncoding codings
+ = do ver ← getRequestVersion
+ tr ← case ver of
+ HttpVersion 1 0 → return (toAB ∘ unnormalizeCoding)
+ HttpVersion 1 1 → return toAB
+ _ → abort InternalServerError []
+ (Just "setContentEncoding: Unknown HTTP version")
+ setHeader "Content-Encoding"
+ (A.fromAsciiBuilder $ joinWith ", " $ map tr codings)
+ where
+ toAB = A.toAsciiBuilder ∘ A.fromCIAscii
+
+-- |@'setWWWAuthenticate' challenge@ declares the response header
+-- \"WWW-Authenticate\" as @challenge@.
+setWWWAuthenticate ∷ AuthChallenge → Resource ()
+setWWWAuthenticate = setHeader "WWW-Authenticate" ∘ printAuthChallenge
+
+-- |Write a chunk in 'Strict.ByteString' to the response body. You
+-- must first declare the response header \"Content-Type\" before
+-- applying this function. See 'setContentType'.
+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'.
+--
+-- Note that you must first declare the response header
+-- \"Content-Type\" before applying this function. See
+-- 'setContentType'.
+putChunks ∷ Lazy.ByteString → Resource ()
+putChunks = putBuilder ∘ BB.fromLazyByteString