{-# LANGUAGE
- BangPatterns
- , GeneralizedNewtypeDeriving
+ GeneralizedNewtypeDeriving
, DoAndIfThenElse
, OverloadedStrings
, RecordWildCards
getRequest ∷ Resource Request
getRequest
= do itr ← getInteraction
- liftIO $ atomically $ fromJust <$> readItr itrRequest itr
+ liftIO $ atomically $ fromJust <$> readTVar (itrRequest itr)
-- |Get the 'Method' value of the request.
getMethod ∷ Resource Method
-- If this is a GET or HEAD request, 'foundEntity' automatically puts
-- \"ETag\" and \"Last-Modified\" headers into the response.
foundEntity ∷ ETag → UTCTime → Resource ()
-foundEntity !tag !timeStamp
+foundEntity tag timeStamp
= do driftTo ExaminingRequest
method ← getMethod
-- This action is not preferred. You should use 'foundEntity' whenever
-- possible.
foundETag ∷ ETag → Resource ()
-foundETag !tag
+foundETag tag
= do driftTo ExaminingRequest
method ← getMethod
input limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
+ hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
chunk ← if hasBody then
askForInput itr
else
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
- askForInput itr
- = do let confLimit = cnfMaxEntityLength $ itrConfig itr
+ askForInput (Interaction {..})
+ = do let confLimit = cnfMaxEntityLength itrConfig
actualLimit = if limit ≤ 0 then
confLimit
else
$ fail ("inputLBS: limit must be positive: " ⧺ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do chunkLen ← readItr itrReqChunkLength itr
- writeItr itrWillReceiveBody True itr
+ $ do chunkLen ← readTVar itrReqChunkLength
+ writeTVar itrWillReceiveBody True
if ((> actualLimit) <$> chunkLen) ≡ Just True then
-- 受信前から多過ぎる事が分かってゐる
tooLarge actualLimit
else
- writeItr itrReqBodyWanted (Just actualLimit) itr
+ writeTVar itrReqBodyWanted (Just actualLimit)
-- 應答を待つ。トランザクションを分けなければ當然デッドロックする。
chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen itr
- chunkIsOver ← readItr itrReqChunkIsOver itr
+ $ do chunkLen ← readTVar itrReceivedBodyLen
+ chunkIsOver ← readTVar itrReqChunkIsOver
if chunkLen < actualLimit then
-- 要求された量に滿たなくて、まだ殘りが
-- あるなら再試行。
$ tooLarge actualLimit
-- 成功。itr 内にチャンクを置いたままにする
-- とメモリの無駄になるので除去。
- chunk ← seqToLBS <$> readItr itrReceivedBody itr
- writeItr itrReceivedBody (∅) itr
- writeItr itrReceivedBodyLen 0 itr
+ chunk ← seqToLBS <$> readTVar itrReceivedBody
+ writeTVar itrReceivedBody (∅)
+ writeTVar itrReceivedBodyLen 0
return chunk
driftTo DecidingHeader
inputChunk limit
= do driftTo GettingBody
itr ← getInteraction
- hasBody ← liftIO $ atomically $ readItr itrRequestHasBody itr
+ hasBody ← liftIO $ atomically $ readTVar $ itrRequestHasBody itr
chunk ← if hasBody then
askForInput itr
else
return chunk
where
askForInput ∷ Interaction → Resource Lazy.ByteString
- askForInput itr
- = do let confLimit = cnfMaxEntityLength $ itrConfig itr
+ askForInput (Interaction {..})
+ = do let confLimit = cnfMaxEntityLength itrConfig
actualLimit = if limit < 0 then
confLimit
else
$ fail ("inputChunkLBS: limit must be positive: " ++ show actualLimit)
-- Reader にリクエスト
liftIO $ atomically
- $ do writeItr itrReqBodyWanted (Just actualLimit) itr
- writeItr itrWillReceiveBody True itr
+ $ do writeTVar itrReqBodyWanted (Just actualLimit)
+ writeTVar itrWillReceiveBody True
-- 應答を待つ。トランザクションを分けなければ當然デッドロック。
chunk ← liftIO $ atomically
- $ do chunkLen ← readItr itrReceivedBodyLen itr
+ $ do chunkLen ← readTVar itrReceivedBodyLen
-- 要求された量に滿たなくて、まだ殘りがある
-- なら再試行。
when (chunkLen < actualLimit)
- $ do chunkIsOver ← readItr itrReqChunkIsOver itr
+ $ do chunkIsOver ← readTVar itrReqChunkIsOver
unless chunkIsOver
$ retry
-- 成功
- chunk ← seqToLBS <$> readItr itrReceivedBody itr
- writeItr itrReceivedBody (∅) itr
- writeItr itrReceivedBodyLen 0 itr
+ chunk ← seqToLBS <$> readTVar itrReceivedBody
+ writeTVar itrReceivedBody (∅)
+ writeTVar itrReceivedBodyLen 0
return chunk
when (Lazy.null chunk)
$ driftTo DecidingHeader
setStatus code
= do driftTo DecidingHeader
itr ← getInteraction
- liftIO $ atomically $ updateItr itrResponse f itr
- where
- f res = res {
- resStatus = code
- }
+ liftIO $ atomically
+ $ do res ← readTVar $ itrResponse itr
+ let res' = res {
+ resStatus = code
+ }
+ writeTVar (itrResponse itr) res'
-- | Set a value of given resource header. Comparison of header name
-- is case-insensitive. Note that this action is not intended to be
setHeader' name value
= do itr ← getInteraction
liftIO $ atomically
- $ updateItr itrResponse (H.setHeader name value) itr
+ $ do res ← readTVar $ itrResponse itr
+ let res' = H.setHeader name value res
+ writeTVar (itrResponse itr) res'
-- | Computation of @'redirect' code uri@ sets the response status to
-- @code@ and \"Location\" header to @uri@. The @code@ must satisfy
{- DecidingBody 時に使用するアクション群 -}
--- | Computation of @'output' str@ writes @str@ as a response body,
--- and then make the 'Resource' transit to /Done/ state. It is safe to
--- apply 'output' to an infinite string, such as a lazy stream of
--- \/dev\/random.
+-- | Write a 'Lazy.ByteString' to the response body, and then transit
+-- to the /Done/ state. It is safe to apply 'output' to an infinite
+-- string, such as the lazy stream of \/dev\/random.
output ∷ Lazy.ByteString → Resource ()
{-# INLINE output #-}
output str = outputChunk str *> driftTo Done
--- | Computation of @'outputChunk' str@ writes @str@ as a part of
--- response body. You can compute this action multiple times to write
--- a body little at a time. It is safe to apply 'outputChunk' to an
--- infinite string.
+-- | Write a 'Lazy.ByteString' to the response body. This action can
+-- be repeated as many times as you want. It is safe to apply
+-- 'outputChunk' to an infinite string.
outputChunk ∷ Lazy.ByteString → Resource ()
outputChunk wholeChunk
= do driftTo DecidingBody
$ abort InternalServerError []
(Just $ "cnfMaxOutputChunkLength must be positive: " ⊕ T.pack (show limit))
- discardBody ← liftIO $ atomically $
- readItr itrWillDiscardBody itr
-
+ discardBody ← liftIO $ atomically $ readTVar $ itrWillDiscardBody itr
unless (discardBody)
- $ sendChunks wholeChunk limit
+ $ sendChunks itr wholeChunk limit
unless (Lazy.null wholeChunk)
$ liftIO $ atomically $
- writeItr itrSentNoBody False itr
+ writeTVar (itrSentNoBody itr) False
where
- sendChunks ∷ Lazy.ByteString → Int → Resource ()
- sendChunks str limit
+ sendChunks ∷ Interaction → Lazy.ByteString → Int → Resource ()
+ sendChunks itr@(Interaction {..}) str limit
| Lazy.null str = return ()
| otherwise = do let (chunk, remaining) = Lazy.splitAt (fromIntegral limit) str
- itr ← getInteraction
liftIO $ atomically
- $ putTMVar (itrBodyToSend itr) (chunkToBuilder chunk)
- sendChunks remaining limit
+ $ putTMVar itrBodyToSend (chunkToBuilder chunk)
+ sendChunks itr remaining limit
chunkToBuilder ∷ Lazy.ByteString → Builder
chunkToBuilder = mconcat ∘ map BB.fromByteString ∘ Lazy.toChunks
driftTo ∷ InteractionState → Resource ()
driftTo newState
= do itr ← getInteraction
- liftIO $ atomically $ do oldState ← readItr itrState itr
- 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 itrState newState itr
+ liftIO $ atomically
+ $ do oldState ← readTVar $ itrState itr
+ 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
+ writeTVar (itrState itr) newState
where
- throwStateError ∷ Monad m => InteractionState → InteractionState → m a
-
+ throwStateError ∷ Monad m ⇒ InteractionState → InteractionState → m a
throwStateError Done DecidingBody
= fail "It makes no sense to output something after finishing to output."
-
throwStateError old new
= fail ("state error: " ⧺ show old ⧺ " ==> " ⧺ show new)
-
drift ∷ Interaction → InteractionState → InteractionState → STM ()
-
- drift itr GettingBody _
- = writeItr itrReqBodyWasteAll True itr
-
+ drift (Interaction {..}) GettingBody _
+ = writeTVar itrReqBodyWasteAll True
drift itr DecidingHeader _
= postprocess itr
-
- drift itr _ Done
- = do bodyIsNull ← readItr itrSentNoBody itr
+ drift itr@(Interaction {..}) _ Done
+ = do bodyIsNull ← readTVar itrSentNoBody
when bodyIsNull
$ writeDefaultPage itr
-
drift _ _ _
= return ()
projects / Lucu.git / blobdiff