Make sure RequestReader tells the writer to stop when the reader stops.

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index ab70998d648e30a0e4a7f1ac74d62d190423c5d7..37ab99296c2e0b7dff2eb7321e37ef6633e70a54 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -70,6 +70,8 @@ requestReader cnf tree fbs h port addr tQueue
       , Handler handleBIOS
       , Handler handleOthers
       ]
+      `finally`
+      enqueue' tQueue EndOfInteraction
     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
@@ -84,22 +86,21 @@ requestReader cnf tree fbs h port addr tQueue
       dump ∷ Exception e ⇒ e → IO ()
       dump e
           = do hPutStrLn stderr "requestReader caught an exception:"
-               hPutStrLn stderr (show $ toException e)
+               hPutStrLn stderr $ show e
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input
-    -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
-    -- それが限度以下になるまで待つ。
     = 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
-         -- リクエストを讀む。パースできない場合は直ちに 400 Bad
-         -- Request 應答を設定し、それを出力してから切斷するやうに
-         -- ResponseWriter に通知する。
-         case LP.parse request input of
-           LP.Done input' req → acceptParsableRequest ctx req input'
-           LP.Fail _ _ _      → acceptNonparsableRequest ctx
+         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 → IO ()
 acceptNonparsableRequest ctx@(Context {..})
@@ -378,8 +379,10 @@ readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
                acceptRequest ctx input
 
 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
-{-# INLINEABLE enqueue #-}
-enqueue (Context {..}) itr
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
     = atomically $
-      do queue ← readTVar cQueue
-         writeTVar cQueue (toInteraction itr ⊲ queue)
+      do queue ← readTVar tQueue
+         writeTVar tQueue (toInteraction itr ⊲ queue)