Code clean-up using convertible-text.

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 1370f05ea5581e59b7d072c3475698b2811e9f80..15f3d6884064715c1281f9f0c42fe12bdca6bc78 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -14,8 +14,9 @@ import Control.Concurrent
 import Control.Concurrent.STM
 import Control.Exception
 import Control.Monad
+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils
 import GHC.IO.Exception (IOException(..), IOErrorType(..))
-import qualified Data.Ascii as A
 import Data.Monoid.Unicode
 import qualified Data.Sequence as S
 import Data.Sequence (ViewR(..))
@@ -40,7 +41,6 @@ responseWriter cnf h tQueue readerTID
       `catches`
       [ Handler handleIOE
       , Handler handleAsyncE
-      , Handler handleBIOS
       , Handler handleOthers
       ]
       `finally`
@@ -56,16 +56,13 @@ responseWriter cnf h tQueue readerTID
       handleAsyncE ThreadKilled = return ()
       handleAsyncE e            = dump e
 
-      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
-      handleBIOS = dump
-
       handleOthers ∷ SomeException → IO ()
       handleOthers = dump
 
       dump ∷ Exception e ⇒ e → IO ()
       dump e
-          = do hPutStrLn stderr "requestWriter caught an exception:"
-               hPutStrLn stderr (show $ toException e)
+          = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
+               hPutStrLn stderr $ show e
 
 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
 awaitSomethingToWrite ctx@(Context {..})
@@ -106,7 +103,7 @@ writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
                              , resStatus  = fromStatusCode Continue
                              , resHeaders = (∅)
                              }
-                  hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+                  hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
                   hFlush cHandle
          writeHeader ctx ni
 
@@ -121,7 +118,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
 
@@ -235,7 +232,7 @@ writeResponseForSEI ∷ HandleLike h
                     → SemanticallyInvalidInteraction
                     → IO ()
 writeResponseForSEI ctx@(Context {..}) (SEI {..})
-    = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
+    = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
          unless seiWillDiscardBody $
              if seiWillChunkBody then
                  do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
@@ -253,7 +250,7 @@ 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
          return ()