, RecordWildCards
, UnicodeSyntax
#-}
-{-# OPTIONS_HADDOCK prune #-}
-- |This is the Resource Monad; monadic actions to define the behavior
-- of each resources. The 'Resource' Monad is a kind of 'Prelude.IO'
-- * Types
Resource
, FormData(..)
- , runRes -- private
+ , runRes
-- * Actions
-- |Get the 'Request' value which represents the request header. In
-- general you don't have to use this action.
getRequest ∷ Resource Request
-getRequest
- = do itr ← getInteraction
- liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr)
+getRequest = (fromJust ∘ itrRequest) <$> getInteraction
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
input limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
- chunk ← if hasBody then
+ chunk ← if reqHasBody $ fromJust $ itrRequest itr then
askForInput itr
else
do driftTo DecidingHeader
$ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do chunkLen ← readTVar itrReqChunkLength
- writeTVar itrWillReceiveBody True
- if ((> actualLimit) <$> chunkLen) ≡ Just True then
- -- 受信前から多過ぎる事が分かってゐる
- tooLarge actualLimit
- else
- writeTVar itrReqBodyWanted (Just actualLimit)
+ $ writeTVar itrReqBodyWanted actualLimit
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
$ do chunkLen ← readTVar itrReceivedBodyLen
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
- chunk ← if hasBody then
- askForInput itr
- else
- do driftTo DecidingHeader
- return (∅)
+ chunk ← if reqHasBody $ fromJust $ itrRequest itr then
+ askForInput itr
+ else
+ do driftTo DecidingHeader
+ return (∅)
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
askForInput (Interaction {..})
= do let confLimit = cnfMaxEntityLength itrConfig
actualLimit = if limit < 0 then
- confLimit
- else
- limit
- when (actualLimit <= 0)
+ confLimit
+ else
+ limit
+ when (actualLimit ≤ 0)
$ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do writeTVar itrReqBodyWanted (Just actualLimit)
- writeTVar itrWillReceiveBody True
+ $ writeTVar itrReqBodyWanted actualLimit
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
$ do chunkLen ← readTVar itrReceivedBodyLen
-- | 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
+setStatus sc
= do driftTo DecidingHeader
itr ← getInteraction
- liftIO $ atomically
- $ do res ← readTVar $ itrResponse itr
- let res' = res {
- resStatus = code
- }
- writeTVar (itrResponse itr) res'
+ liftIO
+ $ atomically
+ $ setResponseStatus itr sc
-- | Set a value of given resource header. Comparison of header name
-- is case-insensitive. Note that this action is not intended to be
unless (Lazy.null wholeChunk)
$ liftIO $ atomically $
- writeTVar (itrSentNoBody itr) False
+ writeTVar (itrSentNoBodySoFar itr) False
where
sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
sendChunks itr@(Interaction {..}) str limit
drift itr DecidingHeader _
= postprocess itr
drift itr@(Interaction {..}) _ Done
- = do bodyIsNull ← readTVar itrSentNoBody
+ = do bodyIsNull ← readTVar itrSentNoBodySoFar
when bodyIsNull
$ writeDefaultPage itr
drift _ _ _