--- Note that 'outputLBS' is more efficient than 'output' so you should
--- use it whenever possible.
-output :: String -> Resource ()
-output str = outputLBS $! L8.pack str
-{-# INLINE output #-}
-
--- | This is mostly the same as 'output' but is more efficient.
-outputLBS :: Lazy.ByteString -> Resource ()
-outputLBS str = do outputChunkLBS str
- driftTo Done
-{-# INLINE outputLBS #-}
-
--- | 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.
---
--- Note that 'outputChunkLBS' is more efficient than 'outputChunk' so
--- you should use it whenever possible.
-outputChunk :: String -> Resource ()
-outputChunk str = outputChunkLBS $! L8.pack str
-{-# INLINE outputChunk #-}
-
--- | This is mostly the same as 'outputChunk' but is more efficient.
-outputChunkLBS :: Lazy.ByteString -> Resource ()
-outputChunkLBS wholeChunk
- = wholeChunk `seq`
- do driftTo DecidingBody
- itr <- getInteraction
-
- 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 wholeChunk limit
-
- unless (L8.null wholeChunk)
- $ liftIO $ atomically $
- writeItr itr itrBodyIsNull False
- where
- -- チャンクの大きさは Config で制限されてゐる。もし例へば
- -- "/dev/zero" を L8.readFile して作った Lazy.ByteString をそのまま
- -- ResponseWriter に渡したりすると大變な事が起こる。何故なら
- -- ResponseWriter は Transfer-Encoding: chunked の時、ヘッダを書
- -- く爲にチャンクの大きさを測る。
- sendChunks :: Lazy.ByteString -> Int -> Resource ()
- sendChunks str limit
- | L8.null str = return ()
- | otherwise = do let (chunk, remaining) = L8.splitAt (fromIntegral limit) str
- itr <- getInteraction
- liftIO $ atomically $
- do buf <- readItr itr itrBodyToSend id
- if L8.null buf then
- -- バッファが消化された
- writeItr itr itrBodyToSend chunk
- else
- -- 消化されるのを待つ
- retry
- -- 殘りのチャンクについて繰り返す
- sendChunks remaining limit
-
-{-
-
- [GettingBody からそれ以降の状態に遷移する時]
-
- body を讀み終へてゐなければ、殘りの body を讀み捨てる。
-
-
- [DecidingHeader からそれ以降の状態に遷移する時]
-
- postprocess する。
-
-
- [Done に遷移する時]
-
- bodyIsNull が False ならば何もしない。True だった場合は出力補完す
- る。
-
--}
-
-driftTo :: InteractionState -> Resource ()
-driftTo newState
- = newState `seq`
- do itr <- getInteraction
- 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
- where
- 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 itr itrReqBodyWasteAll True
-
- drift itr DecidingHeader _
- = postprocess itr
-
- drift itr _ Done
- = do bodyIsNull <- readItr itr itrBodyIsNull id
- when bodyIsNull
- $ writeDefaultPage itr
-
- drift _ _ _
- = return ()