- = 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
- }
-
-
-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 $ "")
-
-
-setETag :: ETag -> Resource ()
-setETag tag
- = setHeader "ETag" $ show tag
-
-
-setLastModified :: ClockTime -> Resource ()
-setLastModified lastmod
- = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
-
-
-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 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