- = 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 ← input 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
-
--- | This is just a constant @-1@. It's better to say @'input'
--- 'defaultLimit'@ than to say @'input' (-1)@ but these are exactly
--- the same.
-defaultLimit ∷ Int
-defaultLimit = (-1)
-
-
-{- DecidingHeader 時に使用するアクション群 -}
-
--- | Set the response status code. If you omit to compute this action,
--- the status code will be defaulted to \"200 OK\".
-setStatus ∷ StatusCode → Resource ()
-setStatus code
- = do driftTo DecidingHeader
- itr ← getInteraction
- liftIO $ atomically $ updateItr itrResponse f itr
- where
- f res = res {
- resStatus = code
- }
-
--- | Set a value of given resource header. Comparison of header name
--- is case-insensitive. Note that this action is not intended to be
--- used so frequently: there should be actions like 'setContentType'
--- for every common headers.
---
--- Some important headers (especially \"Content-Length\" and
--- \"Transfer-Encoding\") may be silently dropped or overwritten by
--- the system not to corrupt the interaction with client at the
--- viewpoint of HTTP protocol layer. For instance, if we are keeping
--- the connection alive, without this process it causes a catastrophe
--- to send a header \"Content-Length: 10\" and actually send a body of
--- 20 bytes long. In this case the client shall only accept the first
--- 10 bytes of response body and thinks that the residual 10 bytes is
--- a part of header of the next response.
-setHeader ∷ CIAscii → Ascii → Resource ()
-setHeader name value
- = driftTo DecidingHeader ≫ setHeader' name value
-
-setHeader' ∷ CIAscii → Ascii → Resource ()
-setHeader' name value
- = do itr ← getInteraction
- liftIO $ atomically
- $ updateItr itrResponse (H.setHeader name value) itr
-
--- | Computation of @'redirect' code uri@ sets the response status to
--- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
--- 'isRedirection' or it causes 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
+ = 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 $ 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 → Rsrc ()
+redirect sc uri
+ = do when (sc ≈ NotModified ∨ (¬) (isRedirection sc))
+ $ abort
+ $ mkAbortion' InternalServerError
+ $ cs
+ $ ("Attempted to redirect with status " ∷ Ascii)
+ ⊕ cs (fromStatusCode sc)
+ setStatus sc