- 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 []
- $ "Attempted to redirect with status " ++ show code
- setStatus code
- setHeader "Location" (uriToString id uri $ "")
-
-
-setETag :: Bool -> String -> Resource ()
-setETag isWeak token
- = setHeader "ETag" $ show $ mkETag isWeak token
-
-
-setLastModified :: ClockTime -> Resource ()
-setLastModified lastmod
- = setHeader "Last-Modified" $ formatHTTPDateTime lastmod
-
-
-{- 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
-
-
-outputChunkBS :: ByteString -> Resource ()
-outputChunkBS str = do driftTo DecidingBody
- itr <- ask
- liftIO $ atomically $
- do updateItr itr itrBodyToSend (flip B.append str)
- unless (B.null str)
- $ writeItr itr itrBodyIsNull False
-
-
-{-
-
- [GettingBody からそれ以降の状態に遷移する時]
-
- body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
-
- [DecidingHeader からそれ以降の状態に遷移する時]
-
- postprocess する。
-
-
- [Done に遷移する時]
-
- bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。Content-Type も變はる。但し(デフォルトのまま)Status が 200 OK
- だった場合は、補完の代はりに 204 No Content に變へる。
-
--}
-
-driftTo :: InteractionState -> Resource ()
-driftTo newState
- = do itr <- ask
- liftIO $ atomically $ do oldState <- readItr itr itrState id
- if newState < oldState then
- throwStateError oldState newState
- else
- do let a = [oldState .. newState]
- b = tail a
- c = zip a b
- mapM_ (uncurry $ drift itr) c
- writeItr itr itrState newState
+ readWWWFormURLEncoded
+ = (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