From 1b822bc79ce9fd0ee537fe81819e7501af83f7bd Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Wed, 16 Nov 2011 01:24:41 +0900
Subject: [PATCH] Make sure RequestReader tells the writer to stop when the
 reader stops.

---
 Network/HTTP/Lucu/RequestReader.hs  | 20 ++++++++++----------
 Network/HTTP/Lucu/ResponseWriter.hs |  2 +-
 2 files changed, 11 insertions(+), 11 deletions(-)

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 8830b5c..37ab992 100644
--- 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,7 +86,7 @@ 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
@@ -94,16 +96,12 @@ acceptRequest ctx@(Context {..}) input
                     -- Too many requests in the pipeline...
                     retry
          if Lazy.null input then
-             endOfRequests ctx
+             return ()
          else
              case LP.parse request input of
                LP.Done input' req → acceptParsableRequest ctx req input'
                LP.Fail _ _ _      → acceptNonparsableRequest ctx
 
-endOfRequests ∷ HandleLike h ⇒ Context h → IO ()
-endOfRequests ctx
-    = enqueue ctx EndOfInteraction
-
 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
 acceptNonparsableRequest ctx@(Context {..})
     = do syi ← mkSyntacticallyInvalidInteraction cConfig
@@ -381,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)
diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 1370f05..25f2ffb 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -65,7 +65,7 @@ responseWriter cnf h tQueue readerTID
       dump ∷ Exception e ⇒ e → IO ()
       dump e
           = do hPutStrLn stderr "requestWriter caught an exception:"
-               hPutStrLn stderr (show $ toException e)
+               hPutStrLn stderr $ show e
 
 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
 awaitSomethingToWrite ctx@(Context {..})
-- 
2.40.0