+-- |Return 'True' iff a given content-coding is acceptable by the
+-- client.
+isEncodingAcceptable ∷ CIAscii → Resource Bool
+isEncodingAcceptable encoding = any doesMatch <$> getAcceptEncoding
+ where
+ doesMatch ∷ (CIAscii, Maybe Double) → Bool
+ doesMatch (e, q) = (e ≡ "*" ∨ e ≡ encoding) ∧ q ≢ Just 0
+
+-- |Return the value of request header \"Content-Type\" as 'MIMEType'.
+getContentType ∷ Resource (Maybe MIMEType)
+getContentType
+ = do cTypeM ← getHeader "Content-Type"
+ case cTypeM of
+ Nothing
+ → return Nothing
+ Just cType
+ → case P.parseOnly (finishOff MT.mimeType) (A.toByteString cType) of
+ Right t → return $ Just t
+ Left _ → abort $ mkAbortion' BadRequest
+ $ "Unparsable Content-Type: " ⊕ A.toText cType
+
+-- |Return the value of request header \"Authorization\" as
+-- 'AuthCredential'.
+getAuthorization ∷ Resource (Maybe AuthCredential)
+getAuthorization
+ = do authM ← getHeader "Authorization"
+ case authM of
+ Nothing
+ → return Nothing
+ Just auth
+ → case P.parseOnly (finishOff authCredential) (A.toByteString auth) of
+ Right ac → return $ Just ac
+ Left _ → return Nothing
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. If this is a GET or HEAD request, a found entity means
+-- a datum to be replied. If this is a PUT or DELETE request, it means
+-- a datum which was stored for the URI until now. For POST requests
+-- it raises an error.
+--
+-- 'foundEntity' performs \"If-Match\" test or \"If-None-Match\" test
+-- whenever possible, and if those tests fail, it immediately aborts
+-- with status \"412 Precondition Failed\" or \"304 Not Modified\"
+-- depending on the situation.
+--
+-- If the request method is either GET or HEAD, 'foundEntity'
+-- automatically puts \"ETag\" and \"Last-Modified\" headers into the
+-- response.
+foundEntity ∷ ETag → UTCTime → Resource ()
+foundEntity tag timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "Last-Modified" (HTTP.toAscii timeStamp)
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "foundEntity: this is a POST request."
+ foundETag tag
+
+ driftTo ReceivingBody
+
+-- |Tell the system that the 'Resource' found an entity for the
+-- request URI. The only difference from 'foundEntity' is that
+-- 'foundETag' doesn't (nor can't) put \"Last-Modified\" header into
+-- the response.
+--
+-- Using this function is discouraged. You should use 'foundEntity'
+-- whenever possible.
+foundETag ∷ ETag → Resource ()
+foundETag tag
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "ETag"
+ $ A.fromAsciiBuilder
+ $ printETag tag
+ when (method ≡ POST)
+ $ abort
+ $ mkAbortion' InternalServerError
+ "Illegal computation of foundETag for POST request."
+
+ -- If-Match があればそれを見る。
+ ifMatch ← getHeader "If-Match"
+ case ifMatch of
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ return ()
+ else
+ case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ Right tags
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ → when ((¬) (any (≡ tag) tags))
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity tag doesn't match: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-Match: " ⊕ A.toText value
+
+ let statusForNoneMatch
+ = if method ≡ GET ∨ method ≡ HEAD then
+ fromStatusCode NotModified
+ else
+ fromStatusCode PreconditionFailed
+
+ -- If-None-Match があればそれを見る。
+ ifNoneMatch ← getHeader "If-None-Match"
+ case ifNoneMatch of
+ Nothing
+ → return ()
+ Just value
+ → if value ≡ "*" then
+ abort $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: *"
+ else
+ case P.parseOnly (finishOff eTagList) (A.toByteString value) of
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort
+ $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: " ⊕ A.toText value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-None-Match: " ⊕ A.toText value
+
+ driftTo ReceivingBody
+
+-- |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
+ $ mkAbortion' InternalServerError
+ "Illegal call of foundTimeStamp for POST request."
+
+ let statusForIfModSince
+ = if method ≡ GET ∨ method ≡ HEAD then
+ fromStatusCode NotModified
+ else
+ fromStatusCode PreconditionFailed
+
+ ifModSince ← getHeader "If-Modified-Since"
+ case ifModSince of
+ Just str → case HTTP.fromAscii str of
+ Right lastTime
+ → when (timeStamp ≤ lastTime)
+ $ abort
+ $ mkAbortion' statusForIfModSince
+ $ "The entity has not been modified since " ⊕ A.toText str
+ Left e
+ → abort $ mkAbortion' BadRequest
+ $ "Malformed If-Modified-Since: " ⊕ T.pack e
+ Nothing → return ()
+
+ ifUnmodSince ← getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ Just str → case HTTP.fromAscii str of
+ Right lastTime
+ → when (timeStamp > lastTime)
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity has not been modified since " ⊕ A.toText str
+ Left e
+ → abort $ mkAbortion' BadRequest
+ $ "Malformed If-Unmodified-Since: " ⊕ T.pack e
+ 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
+ $ mkAbortion NotFound [] msgM
+
+ -- エンティティが存在しないと云ふ事は、"*" も含めたどのやうな
+ -- If-Match: 條件も滿たさない。
+ ifMatch ← getHeader "If-Match"
+ when (ifMatch ≢ Nothing)
+ $ abort
+ $ mkAbortion PreconditionFailed [] msgM
+
+ 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
+-- /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 '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 → 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
+-- @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\".
+--
+-- Note that there are currently a few limitations on parsing
+-- @multipart/form-data@. See: 'parseMultipartFormData'
+getForm ∷ Maybe Int → Resource [(Strict.ByteString, FormData)]
+getForm limit
+ = do cTypeM ← getContentType
+ case cTypeM of
+ Nothing
+ → abort $ mkAbortion' BadRequest "Missing Content-Type"
+ Just (MIMEType "application" "x-www-form-urlencoded" _)
+ → readWWWFormURLEncoded
+ Just (MIMEType "multipart" "form-data" params)
+ → readMultipartFormData params
+ Just cType
+ → abort $ mkAbortion' UnsupportedMediaType
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Unsupported media type: "
+ ⊕ MT.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 $ mkAbortion' BadRequest "Malformed x-www-form-urlencoded"
+
+ readMultipartFormData (MIMEParams m)
+ = case M.lookup "boundary" m of
+ Nothing
+ → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
+ Just boundary
+ → do src ← getChunks limit
+ b ← case A.fromText boundary of
+ Just b → return b
+ Nothing → abort $ mkAbortion' BadRequest
+ $ "Malformed boundary: " ⊕ boundary
+ case parseMultipartFormData b src of
+ Right xs → return $ map (first A.toByteString) xs
+ Left err → abort $ mkAbortion' BadRequest $ T.pack err
+
+-- |@'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 sc ⇒ sc → URI → Resource ()
+redirect sc uri
+ = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
+ $ abort
+ $ mkAbortion' InternalServerError
+ $ A.toText
+ $ A.fromAsciiBuilder
+ $ A.toAsciiBuilder "Attempted to redirect with status "
+ ⊕ printStatusCode sc
+ setStatus sc
+ 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 ∘ MT.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 $ mkAbortion' InternalServerError
+ $ "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 $ mkAbortion' InternalServerError
+ "setContentEncoding: Unknown HTTP version"
+ setHeader "Content-Encoding"
+ $ A.fromAsciiBuilder
+ $ mconcat
+ $ intersperse (A.toAsciiBuilder ", ")
+ $ 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 '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:
+-- 'setContentType'
+putChunks ∷ Lazy.ByteString → Resource ()
+putChunks = putBuilder ∘ BB.fromLazyByteString