Rename: Resource --> Rsrc; ResourceDef --> Resource

[Lucu.git] / Network / HTTP / Lucu / RequestReader.hs

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 05b30420a95040bf9284b94d19bfb913fde51ae4..4c59b3e9f8b1ac5a1524d634d2595a339c80c853 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE
 {-# LANGUAGE

-    DoAndIfThenElse
+    CPP
+  , DoAndIfThenElse
+  , OverloadedStrings

   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax
   , RecordWildCards
   , ScopedTypeVariables
   , UnicodeSyntax


@@ -8,29 +10,30 @@ module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
     where
     ( requestReader
     )
     where

-import Control.Applicative
+import Control.Concurrent

 import Control.Concurrent.STM
 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 Control.Concurrent.STM
 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.List

 import Data.Maybe
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Maybe
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S

-import Data.Sequence.Unicode hiding ((∅))
+import qualified Data.Text as T
+import Network.HTTP.Lucu.Abortion

 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Chunk
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.Interaction

-import Network.HTTP.Lucu.Postprocess

 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.HTTP.Lucu.Preprocess
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.HTTP.Lucu.Resource.Internal
 import Network.HTTP.Lucu.Resource.Tree

+import Network.HTTP.Lucu.Utils

 import Network.Socket
 import Network.Socket

-import Network.URI

 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
 


@@ -64,47 +67,41 @@ requestReader cnf tree fbs h port addr tQueue
          acceptRequest (Context cnf tree fbs h port addr tQueue) input
       `catches`
       [ Handler handleAsyncE
          acceptRequest (Context cnf tree fbs h port addr tQueue) input
       `catches`
       [ Handler handleAsyncE

-      , Handler handleBIOS

       , Handler handleOthers
       ]
       , Handler handleOthers
       ]

+      `finally`
+      enqueue' tQueue EndOfInteraction

     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
       handleAsyncE e            = dump e
 
     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
       handleAsyncE e            = dump e
 

-      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
-      handleBIOS = dump
-

       handleOthers ∷ SomeException → IO ()
       handleOthers = dump
 
       dump ∷ Exception e ⇒ e → IO ()
       dump e
       handleOthers ∷ SomeException → IO ()
       handleOthers = dump
 
       dump ∷ Exception e ⇒ e → IO ()
       dump e

-          = do hPutStrLn stderr "requestReader caught an exception:"
-               hPutStrLn stderr (show $ toException e)
+          = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
+               hPutStrLn stderr $ show e

 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input

-    -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
-    -- それが限度以下になるまで待つ。

     = do atomically $
              do queue ← readTVar cQueue
     = do atomically $
              do queue ← readTVar cQueue

-                when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
+                when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
+                    -- Too many requests in the pipeline...

                     retry
                     retry

-         -- リクエストを讀む。パースできない場合は直ちに 400 Bad
-         -- Request 應答を設定し、それを出力してから切斷するやうに
-         -- ResponseWriter に通知する。
-         case LP.parse requestP input of
-           LP.Done input' req → acceptParsableRequest ctx req input'
-           LP.Fail _ _ _      → acceptNonparsableRequest ctx BadRequest
+         if Lazy.null input then
+             return ()
+         else
+             case LP.parse request input of
+               LP.Done input' req → acceptParsableRequest ctx req input'
+               LP.Fail _ _ _      → acceptNonparsableRequest ctx

 
 

-acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
-acceptNonparsableRequest ctx@(Context {..}) sc
-    = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
-         atomically $
-             do writeTVar (itrState itr) Done
-                postprocess itr
-                enqueue ctx itr
+acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
+acceptNonparsableRequest ctx@(Context {..})
+    = do syi ← mkSyntacticallyInvalidInteraction cConfig
+         enqueue ctx syi

 
 acceptParsableRequest ∷ HandleLike h
                       ⇒ Context h
 
 acceptParsableRequest ∷ HandleLike h
                       ⇒ Context h


@@ -112,129 +109,116 @@ acceptParsableRequest ∷ HandleLike h
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input
                       → Lazy.ByteString
                       → IO ()
 acceptParsableRequest ctx@(Context {..}) req input

-    = do cert ← hGetPeerCert cHandle
-         itr  ← newInteraction cConfig cPort cAddr cert (Right req)
-         join $ atomically
-              $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
-                   if isErr then
-                       acceptSemanticallyInvalidRequest ctx itr input
-                   else
-                       return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
+    = do let ar = preprocess (cnfServerHost cConfig) cPort req
+         if isError $ arInitialStatus ar then
+             acceptSemanticallyInvalidRequest ctx ar input
+         else
+             do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+                case rsrc of
+                  Nothing
+                      → do let ar' = ar {
+                                       arInitialStatus = fromStatusCode NotFound
+                                     }
+                           acceptSemanticallyInvalidRequest ctx ar' input
+                  Just (path, def)
+                      → acceptRequestForResource ctx ar input path def

 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h
 
 acceptSemanticallyInvalidRequest ∷ HandleLike h
                                  ⇒ Context h

-                                 → Interaction
+                                 → AugmentedRequest

                                  → Lazy.ByteString
                                  → Lazy.ByteString

-                                 → STM (IO ())
-acceptSemanticallyInvalidRequest ctx itr input
-    = do writeTVar (itrState itr) Done
-         postprocess itr
-         enqueue ctx itr
-         return $ acceptRequest ctx input
-
-acceptSemanticallyValidRequest ∷ HandleLike h
-                               ⇒ Context h
-                               → Interaction
-                               → URI
-                               → Lazy.ByteString
-                               → IO ()
-acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
-    = do rsrcM ← findResource cResTree cFallbacks uri
-         case rsrcM of
-           Nothing
-               → acceptRequestForNonexistentResource ctx itr input
-           Just (rsrcPath, rsrcDef)
-               → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
-
-acceptRequestForNonexistentResource ∷ HandleLike h
-                                    ⇒ Context h
-                                    → Interaction
-                                    → Lazy.ByteString
-                                    → IO ()
-acceptRequestForNonexistentResource ctx itr input
-    = do atomically $
-             do setResponseStatus itr NotFound
-                writeTVar (itrState itr) Done
-                postprocess itr
-                enqueue ctx itr
+                                 → IO ()
+acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
+    = do sei ← mkSemanticallyInvalidInteraction cConfig ar
+         enqueue ctx sei

          acceptRequest ctx input
 
          acceptRequest ctx input
 

-acceptRequestForExistentResource ∷ HandleLike h
-                                 ⇒ Context h
-                                 → Interaction
-                                 → Lazy.ByteString
-                                 → [Strict.ByteString]
-                                 → ResourceDef
-                                 → IO ()
-acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
-    = do let itr = oldItr { itrResourcePath = Just rsrcPath }
-         atomically $ enqueue ctx itr
-         do _ ← spawnResource rsrcDef itr
-            if reqMustHaveBody $ fromJust $ itrRequest itr then
-                waitForReceiveBodyReq ctx itr input
-            else
-                acceptRequest ctx input
+acceptRequestForResource ∷ HandleLike h
+                         ⇒ Context h
+                         → AugmentedRequest
+                         → Lazy.ByteString
+                         → [Strict.ByteString]
+                         → Resource
+                         → IO ()
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+    = do
+#if defined(HAVE_SSL)
+         cert ← hGetPeerCert cHandle
+         ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+#else
+         ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
+         tid  ← spawnRsrc rsrcDef ni
+         enqueue ctx ni
+         if reqMustHaveBody arRequest then
+             waitForReceiveBodyReq ctx ni tid input
+         else
+             acceptRequest ctx input

 
 waitForReceiveBodyReq ∷ HandleLike h
                       ⇒ Context h
 
 waitForReceiveBodyReq ∷ HandleLike h
                       ⇒ Context h

-                      → Interaction
+                      → NormalInteraction
+                      → ThreadId

                       → Lazy.ByteString
                       → IO ()
                       → Lazy.ByteString
                       → IO ()

-waitForReceiveBodyReq ctx itr input
-    = case fromJust $ itrReqBodyLength itr of
+waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
+    = case fromJust niReqBodyLength of

         Chunked
         Chunked

-            → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+            → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input

         Fixed len
         Fixed len

-            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
+            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len

 
 -- Toooooo long name for a function...
 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                             ⇒ Context h
 
 -- Toooooo long name for a function...
 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                             ⇒ Context h

-                                            → Interaction
+                                            → NormalInteraction
+                                            → ThreadId

                                             → Lazy.ByteString
                                             → IO ()
                                             → Lazy.ByteString
                                             → IO ()

-waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
+waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input

     = join $
       atomically $
     = join $
       atomically $

-      do req ← takeTMVar itrReceiveBodyReq
+      do req ← takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
-                    return $ readCurrentChunk ctx itr input Initial wanted
+               → do putTMVar niSendContinue niExpectedContinue
+                    return $ readCurrentChunk ctx ni rsrcTid wanted input Initial

            WasteAll
            WasteAll

-               → do putTMVar itrSendContinue False
-                    return $ wasteAllChunks ctx itr input Initial
+               → do putTMVar niSendContinue False
+                    return $ wasteAllChunks ctx rsrcTid input Initial

 
 waitForReceiveChunkedBodyReq ∷ HandleLike h
                              ⇒ Context h
 
 waitForReceiveChunkedBodyReq ∷ HandleLike h
                              ⇒ Context h

-                             → Interaction
+                             → NormalInteraction
+                             → ThreadId

                              → Lazy.ByteString
                              → ChunkReceivingState
                              → IO ()
                              → Lazy.ByteString
                              → ChunkReceivingState
                              → IO ()

-waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
-    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
+    = do req ← atomically $ takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → readCurrentChunk ctx itr input st wanted
+               → readCurrentChunk ctx ni rsrcTid wanted input st

            WasteAll
            WasteAll

-               → wasteAllChunks ctx itr input st
+               → wasteAllChunks ctx rsrcTid input st

 
 wasteAllChunks ∷ HandleLike h
                ⇒ Context h
 
 wasteAllChunks ∷ HandleLike h
                ⇒ Context h

-               → Interaction
+               → ThreadId

                → Lazy.ByteString
                → ChunkReceivingState
                → IO ()
                → Lazy.ByteString
                → ChunkReceivingState
                → IO ()

-wasteAllChunks ctx itr = go
+wasteAllChunks ctx rsrcTid = go

     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial

-          = case LP.parse chunkHeaderP input of
+          = case LP.parse chunkHeader input of

               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen
               LP.Done input' chunkLen
                   | chunkLen ≡ 0 → gotFinalChunk input'
                   | otherwise    → gotChunk input' chunkLen

-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                       "wasteAllChunks: chunkHeader"

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -242,44 +226,43 @@ wasteAllChunks ctx itr = go
       gotChunk input chunkLen
           = let input' = Lazy.drop (fromIntegral chunkLen) input
             in
       gotChunk input chunkLen
           = let input' = Lazy.drop (fromIntegral chunkLen) input
             in

-              case LP.parse chunkFooterP input' of
+              case LP.parse chunkFooter input' of

                 LP.Done input'' _
                     → go input'' Initial
                 LP.Done input'' _
                     → go input'' Initial

-                LP.Fail _ _ _
-                    → chunkWasMalformed itr
+                LP.Fail _ eCtx e
+                    → chunkWasMalformed rsrcTid eCtx e
+                          "wasteAllChunks: chunkFooter"

 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input

-          = case LP.parse chunkFooterP input of
+          = case LP.parse chunkTrailer input of

               LP.Done input' _
               LP.Done input' _

-                  → case LP.parse chunkTrailerP input' of
-                       LP.Done input'' _
-                           → acceptRequest ctx input''
-                       LP.Fail _ _ _
-                           → chunkWasMalformed itr
-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+                  → acceptRequest ctx input'
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "wasteAllChunks: chunkTrailer"

 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h
 
 readCurrentChunk ∷ HandleLike h
                  ⇒ Context h

-                 → Interaction
+                 → NormalInteraction
+                 → ThreadId
+                 → Int

                  → Lazy.ByteString
                  → ChunkReceivingState
                  → Lazy.ByteString
                  → ChunkReceivingState

-                 → Int

                  → IO ()
                  → IO ()

-readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
-    = go input0 st0
+readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go

     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial
     where
       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
       go input Initial

-          = case LP.parse chunkHeaderP input of
+          = case LP.parse chunkHeader input of

               LP.Done input' chunkLen
                   | chunkLen ≡ 0
                       → gotFinalChunk input'
                   | otherwise
                       → gotChunk input' chunkLen
               LP.Done input' chunkLen
                   | chunkLen ≡ 0
                       → gotFinalChunk input'
                   | otherwise
                       → gotChunk input' chunkLen

-              LP.Fail _ _ _
-                  → chunkWasMalformed itr
+              LP.Fail _ eCtx e
+                  → chunkWasMalformed rsrcTid eCtx e
+                        "readCurrentChunk: chunkHeader"

       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 
       go input (InChunk chunkLen)
           = gotChunk input chunkLen
 


@@ -290,67 +273,69 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    chunkLen'       = chunkLen - actualReadBytes
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    chunkLen'       = chunkLen - actualReadBytes

-               atomically $ putTMVar itrReceivedBody block'
+               atomically $ putTMVar niReceivedBody block'

                if chunkLen' ≡ 0 then
                if chunkLen' ≡ 0 then

-                   case LP.parse chunkFooterP input' of
+                   case LP.parse chunkFooter input' of

                      LP.Done input'' _
                      LP.Done input'' _

-                         → waitForReceiveChunkedBodyReq ctx itr input'' Initial
-                     LP.Fail _ _ _
-                         → chunkWasMalformed itr
+                         → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
+                     LP.Fail _ eCtx e
+                         → chunkWasMalformed rsrcTid eCtx e
+                               "readCurrentChunk: chunkFooter"

                else
                else

-                   waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+                   waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'

 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input
 
       gotFinalChunk ∷ Lazy.ByteString → IO ()
       gotFinalChunk input

-          = do atomically $ putTMVar itrReceivedBody (∅)
-               case LP.parse chunkFooterP input of
+          = do atomically $ putTMVar niReceivedBody (∅)
+               case LP.parse chunkTrailer input of

                  LP.Done input' _
                  LP.Done input' _

-                     → case LP.parse chunkTrailerP input' of
-                          LP.Done input'' _
-                              → acceptRequest ctx input''
-                          LP.Fail _ _ _
-                              → chunkWasMalformed itr
-                 LP.Fail _ _ _
-                     → chunkWasMalformed itr
+                     → acceptRequest ctx input'
+                 LP.Fail _ eCtx e
+                     → chunkWasMalformed rsrcTid eCtx e
+                           "readCurrentChunk: chunkTrailer"

 
 

-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
+chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
+chunkWasMalformed tid eCtx e msg
+    = let abo = mkAbortion BadRequest [("Connection", "close")]
+                $ Just
+                $ "chunkWasMalformed: "
+                ⊕ T.pack msg
+                ⊕ ": "
+                ⊕ T.pack (intercalate ", " eCtx)
+                ⊕ ": "
+                ⊕ T.pack e
+      in
+        throwTo tid abo

 
 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                                ⇒ Context h
 
 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                                ⇒ Context h

-                                               → Interaction
+                                               → NormalInteraction

                                                → Lazy.ByteString
                                                → Int
                                                → IO ()
                                                → Lazy.ByteString
                                                → Int
                                                → IO ()

-waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen

     = join $
       atomically $
     = join $
       atomically $

-      do req ← takeTMVar itrReceiveBodyReq
+      do req ← takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
-                    return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+               → do putTMVar niSendContinue niExpectedContinue
+                    return $ readNonChunkedRequestBody ctx ni input bodyLen wanted

            WasteAll
            WasteAll

-               → do putTMVar itrSendContinue False
+               → do putTMVar niSendContinue False

                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 
 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                 ⇒ Context h
                     return $ wasteNonChunkedRequestBody ctx input bodyLen
 
 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                 ⇒ Context h

-                                → Interaction
+                                → NormalInteraction

                                 → Lazy.ByteString
                                 → Int
                                 → IO ()
                                 → Lazy.ByteString
                                 → Int
                                 → IO ()

-waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
-    = do req ← atomically $ takeTMVar itrReceiveBodyReq
+waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
+    = do req ← atomically $ takeTMVar niReceiveBodyReq

          case req of
            ReceiveBody wanted
          case req of
            ReceiveBody wanted

-               → readNonChunkedRequestBody ctx itr input bodyLen wanted
+               → readNonChunkedRequestBody ctx ni input bodyLen wanted

            WasteAll
                → wasteNonChunkedRequestBody ctx input bodyLen
 
            WasteAll
                → wasteNonChunkedRequestBody ctx input bodyLen
 


@@ -365,12 +350,12 @@ wasteNonChunkedRequestBody ctx input bodyLen
 
 readNonChunkedRequestBody ∷ HandleLike h
                           ⇒ Context h
 
 readNonChunkedRequestBody ∷ HandleLike h
                           ⇒ Context h

-                          → Interaction
+                          → NormalInteraction

                           → Lazy.ByteString
                           → Int
                           → Int
                           → IO ()
                           → Lazy.ByteString
                           → Int
                           → Int
                           → IO ()

-readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted

     | bodyLen ≡ 0 = gotEndOfRequest
     | otherwise   = gotBody
     where
     | bodyLen ≡ 0 = gotEndOfRequest
     | otherwise   = gotBody
     where


@@ -381,15 +366,19 @@ readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    bodyLen'        = bodyLen - actualReadBytes
                    block'          = Strict.concat $ Lazy.toChunks block
                    actualReadBytes = Strict.length block'
                    bodyLen'        = bodyLen - actualReadBytes

-               atomically $ putTMVar itrReceivedBody block'
-               waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
+               atomically $ putTMVar niReceivedBody block'
+               waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'

 
       gotEndOfRequest ∷ IO ()
       gotEndOfRequest
 
       gotEndOfRequest ∷ IO ()
       gotEndOfRequest

-          = do atomically $ putTMVar itrReceivedBody (∅)
+          = do atomically $ putTMVar niReceivedBody (∅)

                acceptRequest ctx input
 
                acceptRequest ctx input
 

-enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
-enqueue (Context {..}) itr
-    = do queue ← readTVar cQueue
-         writeTVar cQueue (itr ⊲ queue)
+enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
+    = atomically $
+      do queue ← readTVar tQueue
+         writeTVar tQueue (toInteraction itr ⊲ queue)