)
where
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as C8
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
= {-# SCC "awaitSomethingToWrite" #-}
do action
<- atomically $!
- do -- キューが空でなくなるまで待つ
- queue <- readTVar tQueue
- when (S.null queue)
- retry
-
+ -- キューが空でなくなるまで待つ
+ do queue <- readTVar tQueue
-- GettingBody 状態にあり、Continue が期待され
-- てゐて、それがまだ送信前なのであれば、
-- Continue を送信する。
case S.viewr queue of
+ EmptyR -> retry
_ :> itr -> do state <- readItr itr itrState id
if state == GettingBody then
else
do bodyToSend <- readItr itr itrBodyToSend id
- if B.null bodyToSend then
+ if C8.null bodyToSend then
do state <- readItr itr itrState id
if state == Done then
do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
willChunkBody <- atomically $! readItr itr itrWillChunkBody id
chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
- writeItr itr itrBodyToSend B.empty
+ writeItr itr itrBodyToSend C8.empty
return chunk
unless willDiscardBody
$ do if willChunkBody then
- do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
- hPutStr h "\r\n"
- B.hPut h chunk
- hPutStr h "\r\n"
+ do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
+ C8.hPut h (C8.pack "\r\n")
+ C8.hPut h chunk
+ C8.hPut h (C8.pack "\r\n")
else
- B.hPut h chunk
+ C8.hPut h chunk
hFlush h
awaitSomethingToWrite
do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
willChunkBody <- atomically $! readItr itr itrWillChunkBody id
when (not willDiscardBody && willChunkBody)
- $ hPutStr h "0\r\n\r\n" >> hFlush h
+ $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
finalize :: Interaction -> IO ()
finalize itr
do queue <- readTVar tQueue
case S.viewr queue of
+ EmptyR -> return () -- this should never happen
remaining :> _ -> writeTVar tQueue remaining
readItr itr itrWillClose id