From cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Wed, 5 Oct 2011 01:44:07 +0900
Subject: [PATCH] ResponseWriter now compiles.
Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa
---
Network/HTTP/Lucu/DefaultPage.hs | 4 +-
Network/HTTP/Lucu/HandleLike.hs | 10 +-
Network/HTTP/Lucu/Interaction.hs | 9 +-
Network/HTTP/Lucu/Postprocess.hs | 19 +-
Network/HTTP/Lucu/Resource.hs | 28 +--
Network/HTTP/Lucu/Resource/Tree.hs | 6 +-
Network/HTTP/Lucu/ResponseWriter.hs | 279 ++++++++++++++--------------
7 files changed, 182 insertions(+), 173 deletions(-)
diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 360a268..1e5a7a6 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -47,9 +47,9 @@ getDefaultPage !conf !req !res
writeDefaultPage â· Interaction â STM ()
writeDefaultPage !itr
-- Content-Type ãæ£ãããªããã°è£å®ã§ããªãã
- = do res â readItr itrResponse id itr
+ = do res â readItr itrResponse itr
when (getHeader "Content-Type" res == Just defaultPageContentType)
- $ do reqM â readItr itrRequest id itr
+ $ do reqM â readItr itrRequest itr
let conf = itrConfig itr
page = getDefaultPage conf reqM res
diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs
index f58264d..f38fa5b 100644
--- a/Network/HTTP/Lucu/HandleLike.hs
+++ b/Network/HTTP/Lucu/HandleLike.hs
@@ -3,12 +3,16 @@
#-}
module Network.HTTP.Lucu.HandleLike
( HandleLike(..)
+ , hPutBuilder
)
where
+import Blaze.ByteString.Builder (Builder)
+import qualified Blaze.ByteString.Builder as BB
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy.Char8 as L
import qualified OpenSSL.Session as SSL
import OpenSSL.X509
+import Prelude.Unicode
import qualified System.IO as I
class HandleLike h where
@@ -50,5 +54,9 @@ instance HandleLike SSL.SSL where
else
return Nothing
- hFlush _ = return () -- unneeded
+ hFlush _ = return () -- No need to do anything.
hClose s = SSL.shutdown s SSL.Bidirectional
+
+hPutBuilder â· HandleLike h â h â Builder â IO ()
+{-# INLINE hPutBuilder #-}
+hPutBuilder = BB.toByteStringIO â hPutBS
diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs
index 46e32a1..1c2679c 100644
--- a/Network/HTTP/Lucu/Interaction.hs
+++ b/Network/HTTP/Lucu/Interaction.hs
@@ -17,7 +17,6 @@ module Network.HTTP.Lucu.Interaction
)
where
import Blaze.ByteString.Builder (Builder)
-import Control.Applicative
import Control.Concurrent.STM
import Data.Ascii (Ascii)
import qualified Data.ByteString as BS
@@ -168,13 +167,13 @@ writeItr â· (Interaction â TVar a) â a â Interaction â STM ()
writeItr accessor a itr
= writeTVar (accessor itr) a
-readItr â· (Interaction â TVar a) â (a â b) â Interaction â STM b
+readItr â· (Interaction â TVar a) â Interaction â STM a
{-# INLINE readItr #-}
-readItr accessor reader itr
- = reader <$> readTVar (accessor itr)
+readItr accessor itr
+ = readTVar (accessor itr)
updateItr â· (Interaction â TVar a) â (a â a) â Interaction â STM ()
{-# INLINE updateItr #-}
updateItr accessor updator itr
- = do old â readItr accessor id itr
+ = do old â readItr accessor itr
writeItr accessor (updator old) itr
diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 0e089ca..1a00b00 100644
--- a/Network/HTTP/Lucu/Postprocess.hs
+++ b/Network/HTTP/Lucu/Postprocess.hs
@@ -1,6 +1,5 @@
{-# LANGUAGE
- BangPatterns
- , DoAndIfThenElse
+ DoAndIfThenElse
, OverloadedStrings
, UnicodeSyntax
#-}
@@ -63,9 +62,9 @@ import Prelude.Unicode
-}
postprocess â· Interaction â STM ()
-postprocess !itr
- = do reqM â readItr itrRequest id itr
- res â readItr itrResponse id itr
+postprocess itr
+ = do reqM â readItr itrRequest itr
+ res â readItr itrResponse itr
let sc = resStatus res
unless (any (\ p â p sc) [isSuccessful, isRedirection, isError])
@@ -98,15 +97,15 @@ postprocess !itr
-- itrResponse ã®å
容㯠relyOnRequest ã«ãã£ã¦è®ã¸ããã¦ããå¯
-- è½æ§ãé«ãã
- do oldRes â readItr itrResponse id itr
+ do oldRes â readItr itrResponse itr
newRes â unsafeIOToSTM
$ completeUnconditionalHeaders (itrConfig itr) oldRes
writeItr itrResponse newRes itr
where
relyOnRequest â· STM ()
relyOnRequest
- = do status â readItr itrResponse resStatus itr
- req â readItr itrRequest fromJust itr
+ = do status â resStatus <$> readItr itrResponse itr
+ req â fromJust <$> readItr itrRequest itr
let reqVer = reqVersion req
canHaveBody = if reqMethod req â¡ HEAD then
@@ -141,7 +140,7 @@ postprocess !itr
Just value â when (A.toCIAscii value â¡ "close")
$ writeItr itrWillClose True itr
- willClose â readItr itrWillClose id itr
+ willClose â readItr itrWillClose itr
when willClose
$ updateRes $ setHeader "Connection" "close"
@@ -150,7 +149,7 @@ postprocess !itr
readHeader â· CIAscii â STM (Maybe Ascii)
{-# INLINE readHeader #-}
- readHeader k = readItr itrResponse (getHeader k) itr
+ readHeader k = getHeader k <$> readItr itrResponse itr
updateRes â· (Response â Response) â STM ()
{-# INLINE updateRes #-}
diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs
index c8ca45d..0dd73c9 100644
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -239,7 +239,7 @@ getRemoteCertificate = itrRemoteCert <$> getInteraction
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
@@ -609,7 +609,7 @@ input â· Int â Resource Lazy.ByteString
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
@@ -628,7 +628,7 @@ input limit
$ 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
-- åä¿¡åããå¤éããäºãåãã£ã¦ãã
@@ -637,8 +637,8 @@ input limit
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
-- è¦æ±ãããéã«æ»¿ããªãã¦ãã¾ã æ®ãã
-- ãããªãå試è¡ã
@@ -651,7 +651,7 @@ input limit
$ tooLarge actualLimit
-- æåãitr å
ã«ãã£ã³ã¯ãç½®ããã¾ã¾ã«ãã
-- ã¨ã¡ã¢ãªã®ç¡é§ã«ãªãã®ã§é¤å»ã
- chunk â readItr itrReceivedBody seqToLBS itr
+ chunk â seqToLBS <$> readItr itrReceivedBody itr
writeItr itrReceivedBody (â
) itr
writeItr itrReceivedBodyLen 0 itr
return chunk
@@ -684,7 +684,7 @@ inputChunk â· Int â Resource Lazy.ByteString
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
@@ -707,15 +707,15 @@ inputChunk limit
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
@@ -906,7 +906,7 @@ outputChunk wholeChunk
(Just $ "cnfMaxOutputChunkLength must be positive: " â T.pack (show limit))
discardBody â liftIO $ atomically $
- readItr itrWillDiscardBody id itr
+ readItr itrWillDiscardBody itr
unless (discardBody)
$ sendChunks wholeChunk limit
@@ -949,7 +949,7 @@ outputChunk wholeChunk
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
@@ -977,9 +977,9 @@ driftTo newState
= postprocess itr
drift itr _ Done
- = do bodyIsNull â readItr itrSentNoBody id itr
+ = do bodyIsNull â readItr itrSentNoBody itr
when bodyIsNull
- $ writeDefaultPage itr
+ $ writeDefaultPage itr
drift _ _ _
= return ()
diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index b457072..d386bce 100644
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -292,9 +292,9 @@ runResource def itr
-- ã¾ã DecidingHeader 以åã®ç¶æ
ã ã£ããããã®éä¸çµäº
-- ãæçã«åæ ãããé¤å°ããããããã§ãªããã° stderr
-- ã«ã§ãåãããç¡ãã
- state â atomically $ readItr itrState id itr
- reqM â atomically $ readItr itrRequest id itr
- res â atomically $ readItr itrResponse id itr
+ state â atomically $ readItr itrState itr
+ reqM â atomically $ readItr itrRequest itr
+ res â atomically $ readItr itrResponse itr
if state ⤠DecidingHeader then
flip runRes itr
$ do setStatus $ aboStatus abo
diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 9751a76..7382071 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,171 +1,174 @@
{-# LANGUAGE
- BangPatterns
+ DoAndIfThenElse
+ , RecordWildCards
+ , ScopedTypeVariables
, UnicodeSyntax
#-}
module Network.HTTP.Lucu.ResponseWriter
( responseWriter
)
where
-
-import qualified Data.ByteString.Lazy.Char8 as C8
+import qualified Blaze.ByteString.Builder.HTTP as BB
+import qualified Data.Ascii as A
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.Config
-import Network.HTTP.Lucu.Format
import Network.HTTP.Lucu.HandleLike
-import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
import Network.HTTP.Lucu.Response
import Prelude hiding (catch)
-import System.IO (stderr)
+import Prelude.Unicode
+import System.IO (hPutStrLn, stderr)
+data Context h
+ = Context {
+ cConfig â· !Config
+ , cHandle â· !h
+ , cQueue â· !InteractionQueue
+ , cReader â· !ThreadId
+ }
-responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
-responseWriter !cnf !h !tQueue !readerTID
- = awaitSomethingToWrite
+responseWriter â· HandleLike h â Config â h â InteractionQueue â ThreadId â IO ()
+responseWriter cnf h tQueue readerTID
+ = awaitSomethingToWrite (Context cnf h tQueue readerTID)
`catches`
- [ Handler (( \ _ -> return () ) :: IOException -> IO ())
- , Handler ( \ ThreadKilled -> return () )
- , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
- , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+ [ Handler $ \ (_ â· IOException) â return ()
+ , Handler $ \ e â case e of
+ ThreadKilled â return ()
+ _ â hPutStrLn stderr (show e)
+ , Handler $ \ BlockedIndefinitelyOnSTM â hPutStrLn stderr "requestWriter: blocked indefinitely"
+ , Handler $ \ (e â· SomeException) â hPutStrLn stderr (show e)
]
- where
- awaitSomethingToWrite :: IO ()
- awaitSomethingToWrite
- = {-# SCC "awaitSomethingToWrite" #-}
- join $!
- atomically $!
- -- ãã¥ã¼ã空ã§ãªããªãã¾ã§å¾
ã¤
- 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
- writeContinueIfNecessary itr
- else
- if state >= DecidingBody then
- writeHeaderOrBodyIfNecessary itr
- else
- retry
- writeContinueIfNecessary :: Interaction -> STM (IO ())
- writeContinueIfNecessary !itr
- = {-# SCC "writeContinueIfNecessary" #-}
- do expectedContinue <- readItr itr itrExpectedContinue id
- if expectedContinue then
- do wroteContinue <- readItr itr itrWroteContinue id
- if wroteContinue then
- -- æ¢ã« Continue ãæ¸è¾¼ã¿æ¿
- retry
- else
- do reqBodyWanted <- readItr itr itrReqBodyWanted id
- if reqBodyWanted /= Nothing then
- return $ writeContinue itr
- else
+awaitSomethingToWrite â· HandleLike h â Context h â IO ()
+awaitSomethingToWrite ctx@(Context {..})
+ = join $
+ atomically $
+ -- ãã¥ã¼ã空ã§ãªããªãã¾ã§å¾
ã¤
+ do queue â readTVar cQueue
+ -- GettingBody ç¶æ
ã«ãããContinue ãæå¾
ããã¦ãã¦ããããã¾
+ -- ã éä¿¡åãªã®ã§ããã°ãContinue ãéä¿¡ããã
+ case S.viewr queue of
+ EmptyR â retry
+ _ :> itr â do state â readItr itrState itr
+ if state â¡ GettingBody then
+ writeContinueIfNeeded ctx itr
+ else
+ if state ⥠DecidingBody then
+ writeHeaderOrBodyIfNeeded ctx itr
+ else
retry
- else
- retry
- writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
- writeHeaderOrBodyIfNecessary !itr
- -- DecidingBody 以éã®ç¶æ
ã«ãããã¾ã ããããåºåããåã§ã
- -- ãã°ãããããåºåããããããåºåå¾ã§ãããbodyToSend ã
- -- 空ã§ãªããã°ããããåºåããã空ã§ããæã¯ãããç¶æ
ã
- -- Done ã§ããã°å¾å¦çãããã
- = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
- do wroteHeader <- readItr itr itrWroteHeader id
-
- if not wroteHeader then
- return $! writeHeader itr
- else
- do bodyToSend <- readItr itr itrBodyToSend id
-
- if C8.null bodyToSend then
- do state <- readItr itr itrState id
-
- if state == Done then
- return $! finalize itr
- else
- retry
- else
- return $! writeBodyChunk itr
+writeContinueIfNeeded â· HandleLike h â Context h â Interaction â STM (IO ())
+writeContinueIfNeeded ctx itr
+ = do expectedContinue â readItr itrExpectedContinue itr
+ if expectedContinue then
+ do wroteContinue â readItr itrWroteContinue itr
+ if wroteContinue then
+ -- æ¢ã« Continue ãæ¸è¾¼ã¿æ¿
+ retry
+ else
+ do reqBodyWanted â readItr itrReqBodyWanted itr
+ if reqBodyWanted ⢠Nothing then
+ return $ writeContinue ctx itr
+ else
+ retry
+ else
+ retry
- writeContinue :: Interaction -> IO ()
- writeContinue !itr
- = {-# SCC "writeContinue" #-}
- do let cont = Response {
- resVersion = HttpVersion 1 1
- , resStatus = Continue
- , resHeaders = emptyHeaders
- }
- cont' <- completeUnconditionalHeaders cnf cont
- hPutResponse h cont'
- hFlush h
- atomically $! writeItr itr itrWroteContinue True
- awaitSomethingToWrite
+-- DecidingBody 以éã®ç¶æ
ã«ãããã¾ã ããããåºåããåã§ããã°ããã
+-- ããåºåããããããåºåå¾ã§ãããbodyToSend ã空ã§ãªããã°ãããã
+-- åºåããã空ã§ããæã¯ãããç¶æ
ãDone ã§ããã°å¾å¦çãããã
+writeHeaderOrBodyIfNeeded â· HandleLike h â Context h â Interaction â STM (IO ())
+writeHeaderOrBodyIfNeeded ctx itr
+ = do wroteHeader â readItr itrWroteHeader itr
+ if not wroteHeader then
+ return $ writeHeader ctx itr
+ else
+ do noBodyToWrite â isEmptyTMVar (itrBodyToSend itr)
+ if noBodyToWrite then
+ do state â readItr itrState itr
+ if state â¡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+ else
+ return $ writeBodyChunk ctx itr
- writeHeader :: Interaction -> IO ()
- writeHeader !itr
- = {-# SCC "writeHeader" #-}
- do res <- atomically $! do writeItr itr itrWroteHeader True
- readItr itr itrResponse id
- hPutResponse h res
- hFlush h
- awaitSomethingToWrite
-
- writeBodyChunk :: Interaction -> IO ()
- writeBodyChunk !itr
- = {-# SCC "writeBodyChunk" #-}
- do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
- willChunkBody <- atomically $! readItr itr itrWillChunkBody id
- chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
- writeItr itr itrBodyToSend C8.empty
- return chunk
- unless willDiscardBody
- $ do if willChunkBody then
- do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
- hPutLBS h (C8.pack "\r\n")
- hPutLBS h chunk
- hPutLBS h (C8.pack "\r\n")
- else
- hPutLBS h chunk
- hFlush h
- awaitSomethingToWrite
+writeContinue â· HandleLike h â Context h â Interaction â IO ()
+writeContinue ctx@(Context {..}) itr
+ = do let cont = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Continue
+ , resHeaders = (â
)
+ }
+ cont' â completeUnconditionalHeaders cConfig cont
+ hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+ hFlush cHandle
+ atomically $ writeItr itrWroteContinue True itr
+ awaitSomethingToWrite ctx
- finishBodyChunk :: Interaction -> IO ()
- finishBodyChunk !itr
- = {-# SCC "finishBodyChunk" #-}
- do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
- willChunkBody <- atomically $! readItr itr itrWillChunkBody id
- when (not willDiscardBody && willChunkBody)
- $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
+writeHeader â· HandleLike h â Context h â Interaction â IO ()
+writeHeader ctx@(Context {..}) itr
+ = do res â atomically
+ $ do writeItr itrWroteHeader True itr
+ readItr itrResponse itr
+ hPutBuilder cHandle $ A.toBuilder $ printResponse res
+ hFlush cHandle
+ awaitSomethingToWrite ctx
- finalize :: Interaction -> IO ()
- finalize !itr
- = {-# SCC "finalize" #-}
- do finishBodyChunk itr
- willClose <- atomically $!
- do queue <- readTVar tQueue
+writeBodyChunk â· HandleLike h â Context h â Interaction â IO ()
+writeBodyChunk ctx@(Context {..}) itr
+ = join $
+ atomically $
+ do willDiscardBody â readItr itrWillDiscardBody itr
+ if willDiscardBody then
+ do _ â tryTakeTMVar (itrBodyToSend itr)
+ return $ awaitSomethingToWrite ctx
+ else
+ do willChunkBody â readItr itrWillChunkBody itr
+ chunk â takeTMVar (itrBodyToSend itr)
+ return $
+ do if willChunkBody then
+ hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
+ else
+ hPutBuilder cHandle chunk
+ hFlush cHandle
+ awaitSomethingToWrite ctx
- case S.viewr queue of
- EmptyR -> return () -- this should never happen
- remaining :> _ -> writeTVar tQueue remaining
+finishBodyChunk â· HandleLike h â Context h â Interaction â IO ()
+finishBodyChunk (Context {..}) itr
+ = join $
+ atomically $
+ do willDiscardBody â readItr itrWillDiscardBody itr
+ willChunkBody â readItr itrWillChunkBody itr
+ if ((¬) willDiscardBody) ⧠willChunkBody then
+ return $
+ do hPutBuilder cHandle BB.chunkedTransferTerminator
+ hFlush cHandle
+ else
+ return $ return ()
- readItr itr itrWillClose id
- if willClose then
- -- reader ã¯æãã hWaitForInput ãã¦ããæä¸ãªã®ã§ã
- -- ã¹ã¬ããã豫ã殺ãã¦ç½®ããªãã¨ãããããªãã
- do killThread readerTID
- hClose h
- else
- awaitSomethingToWrite
+finalize â· HandleLike h â Context h â Interaction â IO ()
+finalize ctx@(Context {..}) itr
+ = do finishBodyChunk ctx itr
+ willClose â atomically $
+ do queue â readTVar cQueue
+ case S.viewr queue of
+ EmptyR â return () -- this should never happen
+ remaining :> _ â writeTVar cQueue remaining
+ readItr itrWillClose itr
+ if willClose then
+ -- reader ã¯æãã hWaitForInput ãã¦ããæä¸ãªã®ã§ãã¹ã¬ã
+ -- ãã豫ã殺ãã¦ç½®ããªãã¨ãããããªãã
+ do killThread cReader
+ hClose cHandle
+ else
+ awaitSomethingToWrite ctx
--
2.40.0