Use base64-bytestring instead of dataenc

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 3ab4bda714fc37295a3f2992e854e4179518e722..9751a7699c7b175ba062ae750d4c5f710fffeac0 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,3 +1,7 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.ResponseWriter
     ( responseWriter
     )
@@ -12,52 +16,51 @@ 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 :: 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  ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
       , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
       ]
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
           = {-# SCC "awaitSomethingToWrite" #-}
-            do action
-                   <- atomically $!
-                      -- キューが空でなくなるまで待つ
-                      do queue <- readTVar tQueue
-                         -- GettingBody 状態にあり、Continue が期待され
-                         -- ã\81¦ã\82\90ã\81¦ã\80\81ã\81\9dã\82\8cã\81\8cã\81¾ã\81 é\80\81ä¿¡å\89\8dã\81ªã\81®ã\81§ã\81\82ã\82\8cã\81°ã\80\81
-                         -- Continue を送信する。
-                         case S.viewr queue of
-                           EmptyR   -> retry
-                           _ :> itr -> do state <- readItr itr itrState id
+            join $!
+                 atomically $!
+                 -- キューが空でなくなるまで待つ
+                 do queue <- readTVar tQueue
+                    -- GettingBody 状態にあり、Continue が期待されてゐ
+                    -- ã\81¦ã\80\81ã\81\9dã\82\8cã\81\8cã\81¾ã\81 é\80\81ä¿¡å\89\8dã\81ªã\81®ã\81§ã\81\82ã\82\8cã\81°ã\80\81Continue ã\82\92é\80\81
+                    -- 信する。
+                    case S.viewr queue of
+                      EmptyR   -> retry
+                      _ :> itr -> do state <- readItr itr itrState id
 
-                                          if state == GettingBody then
-                                              writeContinueIfNecessary itr
-                                            else
-                                              if state >= DecidingBody then
-                                                  writeHeaderOrBodyIfNecessary itr
-                                              else
-                                                  retry
-               action
+                                     if state == GettingBody then
+                                         writeContinueIfNecessary itr
+                                       else
+                                         if state >= DecidingBody then
+                                             writeHeaderOrBodyIfNecessary itr
+                                         else
+                                             retry
 
       writeContinueIfNecessary :: Interaction -> STM (IO ())
-      writeContinueIfNecessary itr
+      writeContinueIfNecessary !itr
           = {-# SCC "writeContinueIfNecessary" #-}
-            itr `seq`
             do expectedContinue <- readItr itr itrExpectedContinue id
                if expectedContinue then
                    do wroteContinue <- readItr itr itrWroteContinue id
@@ -74,13 +77,12 @@ responseWriter !cnf !h !tQueue !readerTID
                    retry
 
       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
-      writeHeaderOrBodyIfNecessary itr
+      writeHeaderOrBodyIfNecessary !itr
           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
           -- 空でなければ、それを出力する。空である時は、もし状態が
           -- Done であれば後処理をする。
           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
-            itr `seq`
             do wroteHeader <- readItr itr itrWroteHeader id
                
                if not wroteHeader then
@@ -99,9 +101,8 @@ responseWriter !cnf !h !tQueue !readerTID
                           return $! writeBodyChunk itr
 
       writeContinue :: Interaction -> IO ()
-      writeContinue itr
+      writeContinue !itr
           = {-# SCC "writeContinue" #-}
-            itr `seq`
             do let cont = Response {
                             resVersion = HttpVersion 1 1
                           , resStatus  = Continue
@@ -114,9 +115,8 @@ responseWriter !cnf !h !tQueue !readerTID
                awaitSomethingToWrite
 
       writeHeader :: Interaction -> IO ()
-      writeHeader itr
+      writeHeader !itr
           = {-# SCC "writeHeader" #-}
-            itr `seq`
             do res <- atomically $! do writeItr itr itrWroteHeader True
                                        readItr itr itrResponse id
                hPutResponse h res
@@ -124,9 +124,8 @@ responseWriter !cnf !h !tQueue !readerTID
                awaitSomethingToWrite
       
       writeBodyChunk :: Interaction -> IO ()
-      writeBodyChunk itr
+      writeBodyChunk !itr
           = {-# SCC "writeBodyChunk" #-}
-            itr `seq`
             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
@@ -135,27 +134,25 @@ 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
 
       finishBodyChunk :: Interaction -> IO ()
-      finishBodyChunk itr
+      finishBodyChunk !itr
           = {-# SCC "finishBodyChunk" #-}
-            itr `seq`
             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
+      finalize !itr
           = {-# SCC "finalize" #-}
-            itr `seq`
             do finishBodyChunk itr
                willClose <- atomically $!
                             do queue <- readTVar tQueue