getRequest ∷ Resource Request
getRequest
= do itr ← getInteraction
- liftIO $ atomically $ readItr itrRequest fromJust itr
+ liftIO $ atomically $ fromJust <$> readItr itrRequest itr
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
input limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
+ hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
chunk ← if hasBody then
askForInput itr
else
$ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do chunkLen ← readItr itrReqChunkLength id itr
+ $ do chunkLen ← readItr itrReqChunkLength itr
writeItr itrWillReceiveBody True itr
if ((> actualLimit) <$> chunkLen) ≡ Just True then
-- 受信前から多過ぎる事が分かってゐる
writeItr itrReqBodyWanted (Just actualLimit) itr
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen id itr
- chunkIsOver ← readItr itrReqChunkIsOver id itr
+ $ do chunkLen ← readItr itrReceivedBodyLen itr
+ chunkIsOver ← readItr itrReqChunkIsOver itr
if chunkLen < actualLimit then
-- 要求された量に滿たなくて、まだ殘りが
-- あるなら再試行。
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにする
-- とメモリの無駄になるので除去。
- chunk ← readItr itrReceivedBody seqToLBS itr
+ chunk ← seqToLBS <$> readItr itrReceivedBody itr
writeItr itrReceivedBody (∅) itr
writeItr itrReceivedBodyLen 0 itr
return chunk
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody id itr
+ hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
chunk ← if hasBody then
askForInput itr
else
writeItr itrWillReceiveBody True itr
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen id itr
+ $ do chunkLen ← readItr itrReceivedBodyLen itr
-- 要求された量に滿たなくて、まだ殘りがある
-- なら再試行。
when (chunkLen < actualLimit)
- $ do chunkIsOver ← readItr itrReqChunkIsOver id itr
+ $ do chunkIsOver ← readItr itrReqChunkIsOver itr
unless chunkIsOver
$ retry
-- 成功
- chunk ← readItr itrReceivedBody seqToLBS itr
+ chunk ← seqToLBS <$> readItr itrReceivedBody itr
writeItr itrReceivedBody (∅) itr
writeItr itrReceivedBodyLen 0 itr
return chunk
(Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
discardBody ← liftIO $ atomically $
- readItr itrWillDiscardBody id itr
+ readItr itrWillDiscardBody itr
unless (discardBody)
$ sendChunks wholeChunk limit
driftTo ∷ InteractionState → Resource ()
driftTo newState
= do itr ← getInteraction
- liftIO $ atomically $ do oldState ← readItr itrState id itr
+ liftIO $ atomically $ do oldState ← readItr itrState itr
if newState < oldState then
throwStateError oldState newState
else
= postprocess itr
drift itr _ Done
- = do bodyIsNull ← readItr itrSentNoBody id itr
+ = do bodyIsNull ← readItr itrSentNoBody itr
when bodyIsNull
- $ writeDefaultPage itr
+ $ writeDefaultPage itr
drift _ _ _
= return ()