- askForInput :: Interaction -> Resource ByteString
- askForInput itr
- = do let defaultLimit = cnfMaxEntityLength $ itrConfig itr
- actualLimit = if limit < 0 then
- defaultLimit
- else
- limit
- when (actualLimit <= 0)
- $ fail ("inputChunkBS: limit must be positive: " ++ show actualLimit)
- -- Reader にリクエスト
- liftIO $ atomically
- $ do writeItr itr itrReqBodyWanted $ Just actualLimit
- writeItr itr itrWillReceiveBody True
- -- 應答を待つ。トランザクションを分けなければ當然デッドロック。
- chunk <- liftIO $ atomically
- $ do chunk <- readItr itr itrReceivedBody id
- -- 要求された量に滿たなくて、まだ殘りがあ
- -- るなら再試行。
- when (B.length chunk < fromIntegral actualLimit)
- $ do chunkIsOver <- readItr itr itrReqChunkIsOver id
- unless chunkIsOver
- $ retry
- -- 成功
- writeItr itr itrReceivedBody B.empty
- return chunk
- when (B.null chunk)
- $ driftTo DecidingHeader
- return chunk
-
-
-defaultLimit :: Int
-defaultLimit = (-1)
-
-
-
-{- DecidingHeader 時に使用するアクション群 -}
-
-setStatus :: StatusCode -> Resource ()
-setStatus code
- = do driftTo DecidingHeader
- itr <- ask
- liftIO $ atomically $ updateItr itr itrResponse
- $ \ resM -> case resM of
- Nothing -> Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = code
- , resHeaders = []
- }
- Just res -> Just $ 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
- $ \ resM -> case resM of
- Nothing -> Just $ Response {
- resVersion = HttpVersion 1 1
- , resStatus = Ok
- , resHeaders = [ (name, value) ]
- }
- Just res -> Just $ H.setHeader name value res
-
-
-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
+ 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 sc uri
+ = do when (sc ≡: NotModified ∨ (¬) (isRedirection sc))
+ $ abort
+ $ mkAbortion' InternalServerError
+ $ cs
+ $ ("Attempted to redirect with status " ∷ Ascii)
+ ⊕ cs (fromStatusCode 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)