The library compiles again.

Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa

diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs
index aafaf73271e5048b1986846ed462bf9c7334fa1d..d47854f708997be73e623ca5c572876f7d05293f 100644 (file)
--- 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
     , module Network.HTTP.Lucu.Config
 
       -- * Resource Tree

-    , ResourceDef(..)
-    , emptyResource

     , ResTree
     , mkResTree
 
     , 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.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
 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 86b6dbd4fb85293071f2328eec6c5eab8ac090fd..20b4bc27ec956fffb6b959be6dae9c6359182694 100644 (file)
--- 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)
 
     , itrReceiveBodyReq    ∷ !(TMVar ReceiveBodyRequest)
     , itrReceivedBody      ∷ !(TMVar Strict.ByteString)
 

+    , itrSendContinue      ∷ !(TMVar Bool)

     , itrResponse          ∷ !(TVar Response)
     , itrWillChunkBody     ∷ !(TVar Bool)
     , itrWillDiscardBody   ∷ !(TVar 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
 
          receiveBodyReq   ← newEmptyTMVarIO
          receivedBody     ← newEmptyTMVarIO
 

+         sendContinue     ← newEmptyTMVarIO

          response         ← newTVarIO res
          willChunkBody    ← newTVarIO False
          willDiscardBody  ← newTVarIO (arWillDiscardBody ar)
          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
 
                     , itrReceiveBodyReq   = receiveBodyReq
                     , itrReceivedBody     = receivedBody
 

+                    , itrSendContinue     = sendContinue

                     , itrResponse         = response
                     , itrWillChunkBody    = willChunkBody
                     , itrWillDiscardBody  = willDiscardBody
                     , itrResponse         = response
                     , itrWillChunkBody    = willChunkBody
                     , itrWillDiscardBody  = willDiscardBody

diff --git a/Network/HTTP/Lucu/Postprocess.hs b/Network/HTTP/Lucu/Postprocess.hs
index 131cc8ebb3e65f7426a3bf245cc14185a1502795..bc9363d1115de6740032c1d858ac9baab4e65ea3 100644 (file)
--- 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
 
          new ← unsafeIOToSTM $ f old
          writeTVar itrResponse new
 

+-- FIXME: Narrow the use of IO monad!

 completeUnconditionalHeaders ∷ Config → Response → IO Response
 completeUnconditionalHeaders conf = (compDate =≪) ∘ compServer
       where
 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 ecaaadb1d28a7f9ad479443c7b27e5dcc22493d1..05b30420a95040bf9284b94d19bfb913fde51ae4 100644 (file)
--- 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
     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 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 qualified Data.ByteString.Lazy as Lazy
 import Data.Maybe

+import Data.Monoid.Unicode

 import qualified Data.Sequence as S
 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
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.HandleLike


@@ -44,6 +45,11 @@ data Context h
       , cQueue     ∷ !InteractionQueue
       }
 
       , cQueue     ∷ !InteractionQueue
       }
 

+data ChunkReceivingState
+    = Initial
+    | InChunk !Int -- ^Number of remaining octets in the current
+                   -- chunk. It's always positive.
+

 requestReader ∷ HandleLike h
               ⇒ Config
               → ResTree
 requestReader ∷ HandleLike h
               ⇒ Config
               → ResTree


@@ -157,7 +163,7 @@ acceptRequestForExistentResource ∷ HandleLike h
                                  ⇒ Context h
                                  → Interaction
                                  → Lazy.ByteString
                                  ⇒ Context h
                                  → Interaction
                                  → Lazy.ByteString

-                                 → [Text]
+                                 → [Strict.ByteString]

                                  → ResourceDef
                                  → IO ()
 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
                                  → 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
          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
 
             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
                       ⇒ Context h
                       → Interaction
                       → Lazy.ByteString

-                      → Int

                       → IO ()
                       → 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 $
     = 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
               LP.Fail _ _ _
                   → chunkWasMalformed itr

-    | otherwise
-        = seekNextChunk ctx itr input

 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
                  → Interaction
                  → Lazy.ByteString
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
                  → Interaction
                  → Lazy.ByteString

-                 → Int
+                 → ChunkReceivingState

                  → Int
                  → IO ()
                  → 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'' _
                      LP.Done input'' _

-                         → do atomically $
-                                  writeTVar (itrReqChunkIsOver itr) True
-                              acceptRequest ctx input''
+                         → waitForReceiveChunkedBodyReq ctx itr input'' Initial

                      LP.Fail _ _ _
                          → chunkWasMalformed itr
                      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
 
 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
 
     = 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 $
     = 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
 
 wasteNonChunkedRequestBody ∷ HandleLike h
                            ⇒ Context h

-                           → Interaction

                            → Lazy.ByteString
                            → Int
                            → IO ()
                            → 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
          acceptRequest ctx input'
 
 readNonChunkedRequestBody ∷ HandleLike h


@@ -320,23 +370,24 @@ readNonChunkedRequestBody ∷ HandleLike h
                           → Int
                           → Int
                           → IO ()
                           → 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
 
 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 72b751709132b38b2ef66994d2d551d62a42b99c..3a9890a69305bd91b5edd76600be100559895da6 100644 (file)
--- a/Network/HTTP/Lucu/Resource.hs
+++ b/Network/HTTP/Lucu/Resource.hs
@@ -69,6 +69,8 @@ module Network.HTTP.Lucu.Resource
     (
     -- * Types
       Resource
     (
     -- * Types
       Resource

+    , ResourceDef(..)
+    , emptyResource

     , FormData(..)
 
     -- * Getting request header
     , FormData(..)
 
     -- * Getting request header

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index d13dd84e02d9a12b2f3ab3a8196cf29ec6dcf4e0..02e3938644b2122269d9c98e708c58352b68535d 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -35,11 +35,6 @@ data Context h
       , cReader ∷ !ThreadId
       }
 
       , 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)
 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 $
 awaitSomethingToWrite ctx@(Context {..})
     = join $
       atomically $

-      -- キューが空でなくなるまで待つ

       do queue ← readTVar cQueue
          case S.viewr queue of
            EmptyR        → retry
            queue' :> itr → do writeTVar cQueue queue'
       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
 
 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 {..})
 
 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
          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
     = 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
          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 $
     = 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 ∷ 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