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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 8830b5c010f8adf9d562207dfb1b43a33543a7d9..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
       ]
       , Handler handleBIOS
       , Handler handleOthers
       ]

+      `finally`
+      enqueue' tQueue EndOfInteraction

     where
       handleAsyncE ∷ AsyncException → IO ()
       handleAsyncE ThreadKilled = return ()
     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:"
       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
 
 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
                     -- 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
 
          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
 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 ()
                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 $
     = 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 1370f05ea5581e59b7d072c3475698b2811e9f80..25f2ffbead481571c609fcd221d877390a6031d5 100644 (file)
--- 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:"
       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 {..})
 
 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
 awaitSomethingToWrite ctx@(Context {..})