- = do src <- input limit
- return $ parseWWWFormURLEncoded src
-
- readMultipartFormData -- FIXME: 未對應
- = abort UnsupportedMediaType []
- (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
-
--- | 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 <- ask
- liftIO $ atomically $ updateItr itr itrResponse
- $ \ 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 :: String -> String -> Resource ()
-setHeader name value
- = driftTo DecidingHeader >> setHeader' name value
-
-
-setHeader' :: String -> String -> Resource()
-setHeader' name value
- = do itr <- ask
- liftIO $ atomically
- $ updateItr itr itrResponse
- $ H.setHeader name value
-
--- | Computation of @'redirect' code uri@ sets the response status to
--- @code@ and \"Location\" header to @uri@. @code@ must satisfy
--- 'Network.HTTP.Lucu.Response.isRedirection' or it causes an error.
-redirect :: StatusCode -> URI -> Resource ()
-redirect code uri
- = do when (code == NotModified || not (isRedirection code))
- $ abort InternalServerError []
- $ Just ("Attempted to redirect with status " ++ show code)
- setStatus code
- setHeader "Location" (uriToString id uri $ "")
-
--- | Computation of @'setContentType' mType@ sets the response header
--- \"Content-Type\" to @mType@.
-setContentType :: MIMEType -> Resource ()
-setContentType mType
- = setHeader "Content-Type" $ show mType
-
-
-{- DecidingBody 時に使用するアクション群 -}
-
--- | Computation of @'output' str@ writes @str@ as a response body,
--- and then make the 'Resource' transit to /Done/ state. It is safe to
--- apply 'output' to an infinite string, such as a lazy stream of
--- \/dev\/random.
---
--- Note that 'outputBS' is more efficient than 'output' so you should
--- use it whenever possible.
-output :: String -> Resource ()
-output = outputBS . B.pack
-
--- | This is mostly the same as 'output' but is more efficient.
-outputBS :: ByteString -> Resource ()
-outputBS str = do outputChunkBS str
- driftTo Done
-
--- | Computation of @'outputChunk' str@ writes @str@ as a part of
--- response body. You can compute this action multiple times to write
--- a body little at a time. It is safe to apply 'outputChunk' to an
--- infinite string.
---
--- Note that 'outputChunkBS' is more efficient than 'outputChunk' so
--- you should use it whenever possible.
-outputChunk :: String -> Resource ()
-outputChunk = outputChunkBS . B.pack
-
--- | This is mostly the same as 'outputChunk' but is more efficient.
-outputChunkBS :: ByteString -> Resource ()
-outputChunkBS str
- = do driftTo DecidingBody
- itr <- ask
-
- let limit = cnfMaxOutputChunkLength $ itrConfig itr
- when (limit <= 0)
- $ fail ("cnfMaxOutputChunkLength must be positive: "
- ++ show limit)
-
- discardBody <- liftIO $ atomically $
- readItr itr itrWillDiscardBody id
-
- unless (discardBody)
- $ sendChunks str limit
-
- unless (B.null str)
- $ liftIO $ atomically $
- writeItr itr itrBodyIsNull False
+ = (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 (cast sc ≡ Just 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