Bugfix regarding HEAD requests

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index d89ee9e885aa114429489cdef1fb7c59466fb65b..0af4a69df02f1a78604b0bc46d3b71077a545768 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -14,7 +14,9 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
-import qualified Data.Ascii as A
+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils
+import GHC.IO.Exception (IOException(..), IOErrorType(..))
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence (ViewR(..))
@@ -22,54 +24,46 @@ import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.HandleLike
 import Network.HTTP.Lucu.HttpVersion
 import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Prelude.Unicode
 import System.IO (hPutStrLn, stderr)
-import System.IO.Error
 
 data Context h
     = Context {
         cConfig ∷ !Config
       , cHandle ∷ !h
       , cQueue  ∷ !InteractionQueue
-      , cReader ∷ !ThreadId
       }
 
 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
 responseWriter cnf h tQueue readerTID
-    = awaitSomethingToWrite (Context cnf h tQueue readerTID)
+    = awaitSomethingToWrite (Context cnf h tQueue)
       `catches`
       [ Handler handleIOE
       , Handler handleAsyncE
-      , Handler handleBIOS
       , Handler handleOthers
       ]
+      `finally`
+      do killThread readerTID
+         hClose h
     where
       handleIOE ∷ IOException → IO ()
-      handleIOE e
-          | isIllegalOperation e
-              = return () -- EPIPE: should be ignored at all.
-          | otherwise
-              = terminate e
+      handleIOE e@(IOError {..})
+          | ioe_type ≡ ResourceVanished = return ()
+          | otherwise                   = dump e
 
       handleAsyncE ∷ AsyncException → IO ()
-      handleAsyncE ThreadKilled = terminate'
-      handleAsyncE e            = terminate e
-
-      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
-      handleBIOS = terminate
+      handleAsyncE ThreadKilled = return ()
+      handleAsyncE e            = dump e
 
       handleOthers ∷ SomeException → IO ()
-      handleOthers = terminate
-
-      terminate ∷ Exception e ⇒ e → IO ()
-      terminate e
-          = do hPutStrLn stderr "requestWriter caught an exception:"
-               hPutStrLn stderr (show $ toException e)
-               terminate'
+      handleOthers = dump
 
-      terminate' ∷ IO ()
-      terminate' = hClose h
+      dump ∷ Exception e ⇒ e → IO ()
+      dump e
+          = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
+               hPutStrLn stderr $ show e
 
 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
 awaitSomethingToWrite ctx@(Context {..})
@@ -85,7 +79,8 @@ writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
 writeSomething ctx itr
     = let writer = writeResponseForNI  ctx <$> fromInteraction itr <|>
                    writeResponseForSEI ctx <$> fromInteraction itr <|>
-                   writeResponseForSYI ctx <$> fromInteraction itr
+                   writeResponseForSYI ctx <$> fromInteraction itr <|>
+                   endOfResponses          <$> fromInteraction itr
       in
         case writer of
           Just f  → f
@@ -106,10 +101,10 @@ writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
          when isNeeded
              $ do let cont = Response {
                                resVersion = HttpVersion 1 1
-                             , resStatus  = Continue
+                             , resStatus  = fromStatusCode Continue
                              , resHeaders = (∅)
                              }
-                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+                  hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
                   hFlush cHandle
          writeHeader ctx ni
 
@@ -124,7 +119,7 @@ writeHeader ctx@(Context {..}) ni@(NI {..})
                       readTVar niResponse
                   else
                       retry -- Too early to write header fields.
-         hPutBuilder cHandle $ A.toBuilder $ printResponse res
+         hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
          hFlush cHandle
          writeBodyIfNeeded ctx ni
 
@@ -135,14 +130,14 @@ writeBodyIfNeeded ∷ HandleLike h
 writeBodyIfNeeded ctx ni@(NI {..})
     = join $
       atomically $
-      do willDiscardBody ← readTVar niWillDiscardBody
-         if willDiscardBody then
-             return $ discardBody ctx ni
-         else
+      do canHaveBody ← resCanHaveBody <$> readTVar niResponse
+         if canHaveBody ∧ reqMethod niRequest ≢ HEAD then
              if niWillChunkBody then
                  return $ writeChunkedBody    ctx ni
              else
                  return $ writeNonChunkedBody ctx ni
+         else
+             return $ discardBody ctx ni
 
 discardBody ∷ HandleLike h
             ⇒ Context h
@@ -209,12 +204,7 @@ finalize ctx@(Context {..}) (NI {..})
          sentContinue ← takeTMVar niSendContinue
          return $
              if needToClose willClose 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
+                 return ()
              else
                  awaitSomethingToWrite ctx
     where
@@ -243,8 +233,8 @@ writeResponseForSEI ∷ HandleLike h
                     → SemanticallyInvalidInteraction
                     → IO ()
 writeResponseForSEI ctx@(Context {..}) (SEI {..})
-    = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
-         unless seiWillDiscardBody $
+    = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
+         when (reqMethod seiRequest ≢ HEAD) $
              if seiWillChunkBody then
                  do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
                     hPutBuilder cHandle BB.chunkedTransferTerminator
@@ -252,8 +242,7 @@ writeResponseForSEI ctx@(Context {..}) (SEI {..})
                  hPutBuilder cHandle seiBodyToSend
          hFlush cHandle
          if seiWillClose ∨ seiExpectedContinue then
-             do killThread cReader
-                hClose cHandle
+             return ()
          else
              awaitSomethingToWrite ctx
 
@@ -262,8 +251,10 @@ writeResponseForSYI ∷ HandleLike h
                     → SyntacticallyInvalidInteraction
                     → IO ()
 writeResponseForSYI (Context {..}) (SYI {..})
-    = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+    = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
          hPutBuilder cHandle syiBodyToSend
          hFlush cHandle
-         killThread cReader
-         hClose cHandle
+         return ()
+
+endOfResponses ∷ EndOfInteraction → IO ()
+endOfResponses _ = return ()