From: PHO Date: Fri, 21 Oct 2011 13:29:28 +0000 (+0900) Subject: The library compiles again. X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=8225cc5;p=Lucu.git The library compiles again. Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index aafaf73..d47854f 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -41,8 +41,6 @@ module Network.HTTP.Lucu , module Network.HTTP.Lucu.Config -- * Resource Tree - , ResourceDef(..) - , emptyResource , ResTree , mkResTree @@ -86,7 +84,7 @@ import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.ETag import Network.HTTP.Lucu.Httpd import Network.HTTP.Lucu.MIMEType -import Network.HTTP.Lucu.Resource hiding (driftTo) +import Network.HTTP.Lucu.Resource import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.StaticFile diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 86b6dbd..20b4bc2 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -42,6 +42,7 @@ data Interaction = Interaction { , itrReceiveBodyReq ∷ !(TMVar ReceiveBodyRequest) , itrReceivedBody ∷ !(TMVar Strict.ByteString) + , itrSendContinue ∷ !(TMVar Bool) , itrResponse ∷ !(TVar Response) , itrWillChunkBody ∷ !(TVar Bool) , itrWillDiscardBody ∷ !(TVar Bool) @@ -89,6 +90,7 @@ newInteraction conf@(Config {..}) port addr cert request receiveBodyReq ← newEmptyTMVarIO receivedBody ← newEmptyTMVarIO + sendContinue ← newEmptyTMVarIO response ← newTVarIO res willChunkBody ← newTVarIO False willDiscardBody ← newTVarIO (arWillDiscardBody ar) @@ -112,6 +114,7 @@ newInteraction conf@(Config {..}) port addr cert request , itrReceiveBodyReq = receiveBodyReq , itrReceivedBody = receivedBody + , itrSendContinue = sendContinue , itrResponse = response , itrWillChunkBody = willChunkBody , itrWillDiscardBody = willDiscardBody diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs index 131cc8e..bc9363d 100644 --- a/Network/HTTP/Lucu/Postprocess.hs +++ b/Network/HTTP/Lucu/Postprocess.hs @@ -143,6 +143,7 @@ updateResIO (Interaction {..}) f new ← unsafeIOToSTM $ f old writeTVar itrResponse new +-- FIXME: Narrow the use of IO monad! completeUnconditionalHeaders ∷ Config → Response → IO Response completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer where diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index ecaaadb..05b3042 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -10,14 +10,15 @@ module Network.HTTP.Lucu.RequestReader where import Control.Applicative import Control.Concurrent.STM -import Control.Exception +import Control.Exception hiding (block) import Control.Monad import qualified Data.Attoparsec.Lazy as LP +import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy import Data.Maybe +import Data.Monoid.Unicode import qualified Data.Sequence as S -import Data.Sequence.Unicode -import Data.Text (Text) +import Data.Sequence.Unicode hiding ((∅)) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.HandleLike @@ -44,6 +45,11 @@ data Context h , cQueue ∷ !InteractionQueue } +data ChunkReceivingState + = Initial + | InChunk !Int -- ^Number of remaining octets in the current + -- chunk. It's always positive. + requestReader ∷ HandleLike h ⇒ Config → ResTree @@ -157,7 +163,7 @@ acceptRequestForExistentResource ∷ HandleLike h ⇒ Context h → Interaction → Lazy.ByteString - → [Text] + → [Strict.ByteString] → ResourceDef → IO () acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef @@ -165,152 +171,196 @@ acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef atomically $ enqueue ctx itr do _ ← spawnResource rsrcDef itr if reqMustHaveBody $ fromJust $ itrRequest itr then - observeRequest ctx itr input + waitForReceiveBodyReq ctx itr input else acceptRequest ctx input -observeRequest ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → IO () -observeRequest ctx itr input - = case fromJust $ itrReqBodyLength itr of - Chunked - → observeChunkedRequest ctx itr input 0 - Fixed len - → observeNonChunkedRequest ctx itr input len - -observeChunkedRequest ∷ HandleLike h +waitForReceiveBodyReq ∷ HandleLike h ⇒ Context h → Interaction → Lazy.ByteString - → Int → IO () -observeChunkedRequest ctx itr input remaining +waitForReceiveBodyReq ctx itr input + = case fromJust $ itrReqBodyLength itr of + Chunked + → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input + Fixed len + → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len + +-- Toooooo long name for a function... +waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → IO () +waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input = join $ atomically $ - do isOver ← readTVar $ itrReqChunkIsOver itr - if isOver then - return $ acceptRequest ctx input - else - do wanted ← readTVar $ itrReqBodyWanted itr - case wanted of - 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr - if wasteAll then - return $ wasteCurrentChunk ctx itr input remaining - else - retry - _ → return $ readCurrentChunk ctx itr input wanted remaining + do req ← takeTMVar itrReceiveBodyReq + case req of + ReceiveBody wanted + → do putTMVar itrSendContinue $ fromJust itrExpectedContinue + return $ readCurrentChunk ctx itr input Initial wanted + WasteAll + → do putTMVar itrSendContinue False + return $ wasteAllChunks ctx itr input Initial -wasteCurrentChunk ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → Int - → IO () -wasteCurrentChunk ctx itr input len - | len > 0 - = let input' = Lazy.drop (fromIntegral len) input - in - case LP.parse chunkFooterP input' of - LP.Done input'' _ - → observeChunkedRequest ctx itr input'' 0 +waitForReceiveChunkedBodyReq ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → ChunkReceivingState + → IO () +waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st + = do req ← atomically $ takeTMVar itrReceiveBodyReq + case req of + ReceiveBody wanted + → readCurrentChunk ctx itr input st wanted + WasteAll + → wasteAllChunks ctx itr input st + +wasteAllChunks ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → ChunkReceivingState + → IO () +wasteAllChunks ctx itr = go + where + go ∷ Lazy.ByteString → ChunkReceivingState → IO () + go input Initial + = case LP.parse chunkHeaderP input of + LP.Done input' chunkLen + | chunkLen ≡ 0 → gotFinalChunk input' + | otherwise → gotChunk input' chunkLen + LP.Fail _ _ _ + → chunkWasMalformed itr + go input (InChunk chunkLen) + = gotChunk input chunkLen + + gotChunk ∷ Lazy.ByteString → Int → IO () + gotChunk input chunkLen + = let input' = Lazy.drop (fromIntegral chunkLen) input + in + case LP.parse chunkFooterP input' of + LP.Done input'' _ + → go input'' Initial + LP.Fail _ _ _ + → chunkWasMalformed itr + + gotFinalChunk ∷ Lazy.ByteString → IO () + gotFinalChunk input + = case LP.parse chunkFooterP input of + LP.Done input' _ + → case LP.parse chunkTrailerP input' of + LP.Done input'' _ + → acceptRequest ctx input'' + LP.Fail _ _ _ + → chunkWasMalformed itr LP.Fail _ _ _ → chunkWasMalformed itr - | otherwise - = seekNextChunk ctx itr input readCurrentChunk ∷ HandleLike h ⇒ Context h → Interaction → Lazy.ByteString - → Int + → ChunkReceivingState → Int → IO () -readCurrentChunk ctx itr input wanted remaining - | remaining > 0 - = do let bytesToRead = fromIntegral $ min wanted remaining - (chunk, input') = Lazy.splitAt bytesToRead input - actualReadBytes = fromIntegral $ Lazy.length chunk - newWanted = wanted - actualReadBytes - newRemaining = remaining - actualReadBytes - chunk' = S.fromList $ Lazy.toChunks chunk - updateStates = atomically $ - do writeTVar (itrReqBodyWanted itr) newWanted - oldBody ← readTVar $ itrReceivedBody itr - oldBodyLen ← readTVar $ itrReceivedBodyLen itr - writeTVar (itrReceivedBody itr) $ oldBody ⋈ chunk' - writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes - if newRemaining ≡ 0 then - case LP.parse chunkFooterP input' of - LP.Done input'' _ - → do updateStates - observeChunkedRequest ctx itr input'' 0 - LP.Fail _ _ _ - → chunkWasMalformed itr - else - do updateStates - observeChunkedRequest ctx itr input' newRemaining - | otherwise - = seekNextChunk ctx itr input +readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted + = go input0 st0 + where + go ∷ Lazy.ByteString → ChunkReceivingState → IO () + go input Initial + = case LP.parse chunkHeaderP input of + LP.Done input' chunkLen + | chunkLen ≡ 0 + → gotFinalChunk input' + | otherwise + → gotChunk input' chunkLen + LP.Fail _ _ _ + → chunkWasMalformed itr + go input (InChunk chunkLen) + = gotChunk input chunkLen -seekNextChunk ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → IO () -seekNextChunk ctx itr input - = case LP.parse chunkHeaderP input of - LP.Done input' len - | len ≡ 0 -- Final chunk - → case LP.parse chunkTrailerP input' of + gotChunk ∷ Lazy.ByteString → Int → IO () + gotChunk input chunkLen + = do let bytesToRead = min wanted chunkLen + (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input + block' = Strict.concat $ Lazy.toChunks block + actualReadBytes = Strict.length block' + chunkLen' = chunkLen - actualReadBytes + atomically $ putTMVar itrReceivedBody block' + if chunkLen' ≡ 0 then + case LP.parse chunkFooterP input' of LP.Done input'' _ - → do atomically $ - writeTVar (itrReqChunkIsOver itr) True - acceptRequest ctx input'' + → waitForReceiveChunkedBodyReq ctx itr input'' Initial LP.Fail _ _ _ → chunkWasMalformed itr - | otherwise -- Non-final chunk - → observeChunkedRequest ctx itr input' len - LP.Fail _ _ _ - → chunkWasMalformed itr + else + waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen' + + gotFinalChunk ∷ Lazy.ByteString → IO () + gotFinalChunk input + = do atomically $ putTMVar itrReceivedBody (∅) + case LP.parse chunkFooterP input of + LP.Done input' _ + → case LP.parse chunkTrailerP input' of + LP.Done input'' _ + → acceptRequest ctx input'' + LP.Fail _ _ _ + → chunkWasMalformed itr + LP.Fail _ _ _ + → chunkWasMalformed itr chunkWasMalformed ∷ Interaction → IO () chunkWasMalformed itr + -- FIXME: This is a totally wrong way to abort! = atomically $ do setResponseStatus itr BadRequest writeTVar (itrWillClose itr) True writeTVar (itrState itr) Done postprocess itr -observeNonChunkedRequest ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → Int - → IO () -observeNonChunkedRequest ctx itr input remaining +waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → Int + → IO () +waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen = join $ atomically $ - do wanted ← readTVar $ itrReqBodyWanted itr - case wanted of - 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr - if wasteAll then - return $ wasteNonChunkedRequestBody ctx itr input remaining - else - retry - _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining + do req ← takeTMVar itrReceiveBodyReq + case req of + ReceiveBody wanted + → do putTMVar itrSendContinue $ fromJust itrExpectedContinue + return $ readNonChunkedRequestBody ctx itr input bodyLen wanted + WasteAll + → do putTMVar itrSendContinue False + return $ wasteNonChunkedRequestBody ctx input bodyLen + +waitForReceiveNonChunkedBodyReq ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → Int + → IO () +waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen + = do req ← atomically $ takeTMVar itrReceiveBodyReq + case req of + ReceiveBody wanted + → readNonChunkedRequestBody ctx itr input bodyLen wanted + WasteAll + → wasteNonChunkedRequestBody ctx input bodyLen wasteNonChunkedRequestBody ∷ HandleLike h ⇒ Context h - → Interaction → Lazy.ByteString → Int → IO () -wasteNonChunkedRequestBody ctx itr input remaining - = do let input' = Lazy.drop (fromIntegral remaining) input - atomically $ writeTVar (itrReqChunkIsOver itr) True +wasteNonChunkedRequestBody ctx input bodyLen + = do let input' = Lazy.drop (fromIntegral bodyLen) input acceptRequest ctx input' readNonChunkedRequestBody ∷ HandleLike h @@ -320,23 +370,24 @@ readNonChunkedRequestBody ∷ HandleLike h → Int → Int → IO () -readNonChunkedRequestBody ctx itr input wanted remaining - = do let bytesToRead = min wanted remaining - (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input - actualReadBytes = fromIntegral $ Lazy.length chunk - newWanted = wanted - actualReadBytes - newRemaining = remaining - actualReadBytes - isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0 - chunk' = S.fromList $ Lazy.toChunks chunk - atomically $ - do writeTVar (itrReqChunkIsOver itr) isOver - writeTVar (itrReqBodyWanted itr) newWanted - writeTVar (itrReceivedBody itr) chunk' - writeTVar (itrReceivedBodyLen itr) actualReadBytes - if isOver then - acceptRequest ctx input' - else - observeNonChunkedRequest ctx itr input' newRemaining +readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted + | bodyLen ≡ 0 = gotEndOfRequest + | otherwise = gotBody + where + gotBody ∷ IO () + gotBody + = do let bytesToRead = min wanted bodyLen + (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input + block' = Strict.concat $ Lazy.toChunks block + actualReadBytes = Strict.length block' + bodyLen' = bodyLen - actualReadBytes + atomically $ putTMVar itrReceivedBody block' + waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen' + + gotEndOfRequest ∷ IO () + gotEndOfRequest + = do atomically $ putTMVar itrReceivedBody (∅) + acceptRequest ctx input enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM () enqueue (Context {..}) itr diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 72b7517..3a9890a 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -69,6 +69,8 @@ module Network.HTTP.Lucu.Resource ( -- * Types Resource + , ResourceDef(..) + , emptyResource , FormData(..) -- * Getting request header diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index d13dd84..02e3938 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -35,11 +35,6 @@ data Context h , cReader ∷ !ThreadId } -data Phase = Initial - | WroteContinue - | WroteHeader - deriving (Eq, Ord, Show) - responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () responseWriter cnf h tQueue readerTID = awaitSomethingToWrite (Context cnf h tQueue readerTID) @@ -80,140 +75,157 @@ awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO () awaitSomethingToWrite ctx@(Context {..}) = join $ atomically $ - -- キューが空でなくなるまで待つ do queue ← readTVar cQueue case S.viewr queue of EmptyR → retry queue' :> itr → do writeTVar cQueue queue' - return $ awaitSomethingToWriteOn ctx itr Initial - --- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前 --- なのであれば、Continue を送信する。 -awaitSomethingToWriteOn ∷ HandleLike h - ⇒ Context h - → Interaction - → Phase - → IO () -awaitSomethingToWriteOn ctx itr phase - = join $ - atomically $ - do state ← readTVar $ itrState itr - if state ≡ ReceivingBody then - writeContinueIfNeeded ctx itr phase - else - if state ≥ SendingBody then - writeHeaderOrBodyIfNeeded ctx itr phase - else - retry + return $ writeContinueIfNeeded ctx itr writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction - → Phase - → STM (IO ()) -writeContinueIfNeeded ctx itr@(Interaction {..}) phase - | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True - = do isRequested ← isEmptyTMVar itrReceiveBodyReq - if isRequested then - return $ writeContinue ctx itr - else - retry - | otherwise - = retry - --- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ --- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを --- 出力する。空である時は、もし状態がDone であれば後処理をする。 -writeHeaderOrBodyIfNeeded ∷ HandleLike h - ⇒ Context h - → Interaction - → Phase - → STM (IO ()) -writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase - | phase < WroteHeader - = return $ writeHeader ctx itr - | otherwise - = do noBodyToWrite ← isEmptyTMVar itrBodyToSend - if noBodyToWrite then - do state ← readTVar itrState - if state ≡ Done then - return $ finalize ctx itr - else - retry - else - return $ writeBodyChunk ctx itr phase - -writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeContinue ctx@(Context {..}) itr@(Interaction {..}) - = do let cont = Response { - resVersion = HttpVersion 1 1 - , resStatus = Continue - , resHeaders = (∅) - } - cont' ← completeUnconditionalHeaders cConfig cont - hPutBuilder cHandle $ A.toBuilder $ printResponse cont' - hFlush cHandle - awaitSomethingToWriteOn ctx itr WroteContinue + → IO () +writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..}) + = do isNeeded ← atomically $ readTMVar itrSendContinue + when isNeeded + $ do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = (∅) + } + cont' ← completeUnconditionalHeaders cConfig cont + hPutBuilder cHandle $ A.toBuilder $ printResponse cont' + hFlush cHandle + writeHeader ctx itr writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO () writeHeader ctx@(Context {..}) itr@(Interaction {..}) - = do res ← atomically $ readTVar itrResponse + = do res ← atomically $ + do state ← readTVar itrState + if state ≥ SendingBody then + readTVar itrResponse + else + retry -- Too early to write header fields. hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle - awaitSomethingToWriteOn ctx itr WroteHeader + writeBodyIfNeeded ctx itr -writeBodyChunk ∷ HandleLike h - ⇒ Context h - → Interaction - → Phase - → IO () -writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase +writeBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeBodyIfNeeded ctx itr@(Interaction {..}) = join $ atomically $ do willDiscardBody ← readTVar itrWillDiscardBody if willDiscardBody then - do _ ← tryTakeTMVar itrBodyToSend - return $ awaitSomethingToWriteOn ctx itr phase + return $ discardBody ctx itr else do willChunkBody ← readTVar itrWillChunkBody - chunk ← takeTMVar itrBodyToSend - return $ - do if willChunkBody then - hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk - else - hPutBuilder cHandle chunk - hFlush cHandle - awaitSomethingToWriteOn ctx itr phase + if willChunkBody then + return $ writeChunkedBody ctx itr + else + return $ writeNonChunkedBody ctx itr -finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -finishBodyChunk (Context {..}) (Interaction {..}) +discardBody ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +discardBody ctx itr@(Interaction {..}) = join $ atomically $ - do willDiscardBody ← readTVar itrWillDiscardBody - willChunkBody ← readTVar itrWillChunkBody - if ((¬) willDiscardBody) ∧ willChunkBody then - return $ - do hPutBuilder cHandle BB.chunkedTransferTerminator - hFlush cHandle - else - return $ return () + do chunk ← tryTakeTMVar itrBodyToSend + case chunk of + Just _ → return $ discardBody ctx itr + Nothing → do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry + +writeChunkedBody ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeChunkedBody ctx@(Context {..}) itr@(Interaction {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar itrBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle $ BB.chunkedTransferEncoding b + hFlush cHandle + writeChunkedBody ctx itr + Nothing → do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry + +writeNonChunkedBody ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar itrBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle b + hFlush cHandle + writeNonChunkedBody ctx itr + Nothing → do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -finalize ctx@(Context {..}) itr@(Interaction {..}) - = 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 - readTVar itrWillClose - if willClose then - -- reader は恐らく hWaitForInput してゐる最中なので、スレッ - -- ドを豫め殺して置かないとをかしくなる。 - do killThread cReader - hClose cHandle - else - awaitSomethingToWrite ctx +finalize ctx@(Context {..}) (Interaction {..}) + = join $ + atomically $ + do sentContinue ← takeTMVar itrSendContinue + willDiscardBody ← readTVar itrWillDiscardBody + willChunkBody ← readTVar itrWillChunkBody + willClose ← readTVar itrWillClose + queue ← readTVar cQueue + case S.viewr queue of + queue' :> _ + → writeTVar cQueue queue' + EmptyR + → fail "finalize: cQueue is empty, which should never happen." + return $ + do when (((¬) willDiscardBody) ∧ willChunkBody) + $ do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + if willClose ∨ needToClose sentContinue then + -- The RequestReader is probably blocking on + -- hWaitForInput so we have to kill it before + -- closing the socket. + -- THINKME: Couldn't that somehow be avoided? + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx + where + needToClose ∷ Bool → Bool + needToClose sentContinue + -- We've sent both "HTTP/1.1 100 Continue" and a final + -- response, so nothing prevents our connection from keeping + -- alive. + | sentContinue = False + -- We've got "Expect: 100-continue" but have sent a final + -- response without sending "HTTP/1.1 100 + -- Continue". According to the RFC 2616 (HTTP/1.1), it is + -- undecidable whether the client will send us its + -- (rejected) request body OR start a completely new request + -- in this situation. So the only possible thing to do is to + -- brutally shutdown the connection. + | itrExpectedContinue ≡ Just True = True + -- The client didn't expect 100-continue so we haven't sent + -- one. No need to do anything special. + | otherwise = False