+-- |Tell the system that the 'Rsrc' 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 → Rsrc ()
+foundETag tag
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "ETag"
+ $ cs 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 def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-Match"
+ Right tags
+ -- tags の中に一致するものが無ければ
+ -- PreconditionFailed で終了。
+ → when ((¬) (any (≡ tag) tags))
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity tag doesn't match: " ⊕ cs value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-Match: " ⊕ cs 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 def) (cs value) of
+ Right []
+ → abort $ mkAbortion' BadRequest
+ $ "Empty If-None-Match"
+ Right tags
+ → when (any (≡ tag) tags)
+ $ abort
+ $ mkAbortion' statusForNoneMatch
+ $ "The entity tag matches: " ⊕ cs value
+ Left _
+ → abort $ mkAbortion' BadRequest
+ $ "Unparsable If-None-Match: " ⊕ cs value
+
+ driftTo ReceivingBody
+
+-- |Tell the system that the 'Rsrc' 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 → Rsrc ()
+foundTimeStamp timeStamp
+ = do driftTo ExaminingRequest
+
+ method ← getMethod
+ when (method ≡ GET ∨ method ≡ HEAD)
+ $ setHeader "Last-Modified"
+ $ flip proxy http
+ $ cs 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 fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just lastTime
+ → when (timeStamp ≤ lastTime)
+ $ abort
+ $ mkAbortion' statusForIfModSince
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
+ → abort $ mkAbortion' BadRequest
+ $ "Malformed If-Modified-Since: " ⊕ cs str
+ Nothing → return ()
+
+ ifUnmodSince ← getHeader "If-Unmodified-Since"
+ case ifUnmodSince of
+ Just str → case fromAttempt $ ca (Tagged str ∷ Tagged HTTP Ascii) of
+ Just lastTime
+ → when (timeStamp > lastTime)
+ $ abort
+ $ mkAbortion' PreconditionFailed
+ $ "The entity has not been modified since " ⊕ cs str
+ Nothing
+ → abort $ mkAbortion' BadRequest
+ $ "Malformed If-Unmodified-Since: " ⊕ cs str
+ Nothing → return ()
+
+ driftTo ReceivingBody
+
+-- |@'foundNoEntity' mStr@ tells the system that the 'Rsrc' 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 → Rsrc ()
+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' ∷ Rsrc ()
+{-# INLINE foundNoEntity' #-}
+foundNoEntity' = foundNoEntity Nothing
+
+-- |@'getChunks' limit@ attemts to read the entire request body up to
+-- @limit@ bytes, and then make the 'Rsrc' 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 → Rsrc 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 → Rsrc Lazy.ByteString
+getChunks' limit = go limit (∅)
+ where
+ go ∷ Int → Builder → Rsrc Lazy.ByteString
+ go 0 _ = do chunk ← getChunk 1
+ if Strict.null chunk then
+ return (∅)
+ else
+ abort $ mkAbortion' RequestEntityTooLarge
+ $ "Request body must be smaller than "
+ ⊕ cs (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 → Rsrc [(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
+ $ cs
+ $ ("Unsupported media type: " ∷ Ascii)
+ ⊕ cs cType
+ where
+ readWWWFormURLEncoded
+ = (map toPairWithFormData ∘ parseWWWFormURLEncoded)
+ <$>
+ (bsToAscii =≪ getChunks limit)
+
+ bsToAscii bs
+ = case convertAttemptVia ((⊥) ∷ ByteString) bs of
+ Success a → return a
+ Failure e → abort $ mkAbortion' BadRequest $ cs (show e)
+
+ readMultipartFormData m
+ = case lookup "boundary" m of
+ Nothing
+ → abort $ mkAbortion' BadRequest "Missing boundary of multipart/form-data"
+ Just boundary
+ → do src ← getChunks limit
+ b ← case ca boundary of
+ Success b → return b
+ Failure _ → abort $ mkAbortion' BadRequest
+ $ "Malformed boundary: " ⊕ boundary
+ case parseMultipartFormData b src of
+ Right xs → return $ map (first cs) xs
+ Left err → abort $ mkAbortion' BadRequest $ cs 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 → Rsrc ()
+redirect (fromStatusCode → sc) uri
+ = do when (sc ≡ cs NotModified ∨ (¬) (isRedirection sc))
+ $ abort
+ $ mkAbortion' InternalServerError
+ $ cs
+ $ ("Attempted to redirect with status " ∷ Ascii)
+ ⊕ cs 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 → Rsrc ()
+setContentType = setHeader "Content-Type" ∘ cs
+
+-- |@'setLocation' uri@ declares the response header \"Location\" as
+-- @uri@. You usually don't need to call this function directly.
+setLocation ∷ URI → Rsrc ()
+setLocation uri
+ = case ca uriStr of
+ Success a → setHeader "Location" a
+ Failure e → abort $ mkAbortion' InternalServerError
+ $ cs (show e)
+ where
+ uriStr = uriToString id uri ""
+
+-- |@'setContentEncoding' codings@ declares the response header
+-- \"Content-Encoding\" as @codings@.
+setContentEncoding ∷ [CIAscii] → Rsrc ()
+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"
+ $ cs
+ $ mconcat
+ $ intersperse (cs (", " ∷ Ascii))
+ $ map tr codings
+ where
+ toAB ∷ ConvertSuccess α AsciiBuilder ⇒ α → AsciiBuilder
+ toAB = cs