- = do src <- input limit
- return $ do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
- let pair = break (== '=') pairStr
- return ( unEscapeString $ fst pair
- , unEscapeString $ snd pair
- )
- readMultipartFormData -- FIXME: 未對應
- = abort UnsupportedMediaType []
- (Just $ "Sorry, inputForm does not currently support multipart/form-data.")
-
-
-defaultLimit :: Int
-defaultLimit = (-1)
-
-
-
-{- DecidingHeader 時に使用するアクション群 -}
-
-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 an action like 'setContentType'
--- for every common headers.
---
--- Some important headers (especially \"Content-Length\" and
--- \"Transfer-Encoding\") may be silently deleted or overwritten by
--- the system not to corrupt the interaction with client at the
--- viewpoint of HTTP protocol. For instance, if we are keeping
--- connection alive, for an obvious reason it causes a catastrophe to
--- send header \"Content-Length: 10\" and actually sending body of 20
--- bytes long.
-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
-
-
-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 $ "")
-
-
-setContentType :: MIMEType -> Resource ()
-setContentType mType
- = setHeader "Content-Type" $ show mType
-
-
-{- DecidingBody 時に使用するアクション群 -}
-
-output :: String -> Resource ()
-output = outputBS . B.pack
-
-
-outputBS :: ByteString -> Resource ()
-outputBS str = do outputChunkBS str
- driftTo Done
-
-
-outputChunk :: String -> Resource ()
-outputChunk = outputChunkBS . B.pack
-
-
-{- チャンクの大きさは Config で制限されてゐる。もし例へば /dev/zero を
- B.readFile して作った ByteString をそのまま ResponseWriter に渡した
- りすると大變な事が起こる。何故なら ResponseWriter は
- Transfer-Encoding: chunked の時、ヘッダを書く爲にチャンクの大きさを
- 測るから、その時に起こるであらう事は言ふまでも無い。 -}
-
-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 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)