SSL Support

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 830baa68eb05ae0944c2cb19a35a412d5a58f971..63174b7cb5ea3d8f727c860d77efdea0710134dd 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -12,24 +12,25 @@ import qualified Data.Sequence as S
 import           Data.Sequence (ViewR(..))
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Format
+import           Network.HTTP.Lucu.HandleLike
 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Postprocess
 import           Network.HTTP.Lucu.Response
 import           Prelude hiding (catch)
-import           System.IO
+import           System.IO (stderr)
 
 
-responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter cnf h tQueue readerTID
-    = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
-      catch awaitSomethingToWrite $ \ exc ->
-      case exc of
-        IOException _               -> return ()
-        AsyncException ThreadKilled -> return ()
-        BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
-        _                           -> print exc
+responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
+responseWriter !cnf !h !tQueue !readerTID
+    = awaitSomethingToWrite
+      `catches`
+      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
+      , Handler  ( \ ThreadKilled        -> return () )
+      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
+      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+      ]
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
@@ -135,11 +136,11 @@ responseWriter cnf h tQueue readerTID
                unless willDiscardBody
                           $ do if willChunkBody then
                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
-                                      C8.hPut h (C8.pack "\r\n")
-                                      C8.hPut h chunk
-                                      C8.hPut h (C8.pack "\r\n")
+                                      hPutLBS h (C8.pack "\r\n")
+                                      hPutLBS h chunk
+                                      hPutLBS h (C8.pack "\r\n")
                                  else
-                                   C8.hPut h chunk
+                                   hPutLBS h chunk
                                hFlush h
                awaitSomethingToWrite
 
@@ -150,7 +151,7 @@ responseWriter cnf h tQueue readerTID
             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                when (not willDiscardBody && willChunkBody)
-                        $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
+                        $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
 
       finalize :: Interaction -> IO ()
       finalize itr