Network/HTTP/Lucu/ResponseWriter.hs

   1 module Network.HTTP.Lucu.ResponseWriter
   2     ( responseWriter -- Handle -> InteractionQueue -> IO ()
   3     )
   4     where
   5
   6 import qualified Data.ByteString.Lazy.Char8 as B
   7 import           Data.ByteString.Lazy.Char8 (ByteString)
   8 import           Control.Concurrent.STM
   9 import           Control.Exception
  10 import           Control.Monad
  11 import           Data.Maybe
  12 import qualified Data.Sequence as S
  13 import           Data.Sequence (Seq, ViewR(..))
  14 import           Network.HTTP.Lucu.Interaction
  15 import           Network.HTTP.Lucu.Response
  16 import           Prelude hiding (catch)
  17 import           System.IO
  18 import           Text.Printf
  19
  20 import Control.Concurrent
  21 import Debug.Trace
  22
  23
  24 responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO ()
  25 responseWriter h tQueue readerTID
  26     = catch awaitSomethingToWrite $ \ exc ->
  27       case exc of
  28         IOException _               -> return ()
  29         AsyncException ThreadKilled -> return ()
  30         BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
  31         _                           -> print exc
  32     where
  33       awaitSomethingToWrite :: IO ()
  34       awaitSomethingToWrite
  35           = do action
  36                    <- atomically $
  37                       do -- キューが空でなくなるまで待つ
  38                          queue <- readTVar tQueue
  39                          when (S.null queue)
  40                               retry
  41                          let _ :> itr = S.viewr queue
  42
  43                          -- GettingBody 状態にあり、Continue が期待され
  44                          -- てゐて、それがまだ送信前なのであれば、
  45                          -- Continue を送信する。
  46                          state <- readItr itr itrState id
  47
  48                          if state == GettingBody then
  49                              writeContinueIfNecessary itr
  50                            else
  51                              if state >= DecidingBody then
  52                                  writeHeaderOrBodyIfNecessary itr
  53                              else
  54                                  retry
  55                action
  56
  57       writeContinueIfNecessary :: Interaction -> STM (IO ())
  58       writeContinueIfNecessary itr
  59           = do expectedContinue <- readItr itr itrExpectedContinue id
  60                if expectedContinue then
  61
  62                    do wroteContinue <- readItr itr itrWroteContinue id
  63                       if wroteContinue then
  64                           -- 既に Continue を書込み濟
  65                           retry
  66                         else
  67                           return $ writeContinue itr
  68                  else
  69                    retry
  70
  71       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
  72       writeHeaderOrBodyIfNecessary itr
  73           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
  74           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
  75           -- 空でなければ、それを出力する。空である時は、もし状態が
  76           -- Done であれば後処理をする。
  77           = do wroteHeader <- readItr itr itrWroteHeader id
  78
  79                if not wroteHeader then
  80                    return $ writeHeader itr
  81                  else
  82                    do bodyToSend <- readItr itr itrBodyToSend id
  83
  84                       if B.null bodyToSend then
  85                           do state <- readItr itr itrState id
  86
  87                              if state == Done then
  88                                  return $ finalize itr
  89                                else
  90                                  retry
  91                         else
  92                           return $ writeBodyChunk itr
  93
  94       writeContinue :: Interaction -> IO ()
  95       writeContinue itr = fail "FIXME: not implemented"
  96
  97       writeHeader :: Interaction -> IO ()
  98       writeHeader itr
  99           = do res <- atomically $ do writeItr itr itrWroteHeader True
 100                                       readItr itr itrResponse id
 101                hPutResponse h (fromJust res)
 102                hFlush h
 103                awaitSomethingToWrite
 104
 105       writeBodyChunk :: Interaction -> IO ()
 106       writeBodyChunk itr
 107           = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
 108                willChunkBody   <- atomically $ readItr itr itrWillChunkBody   id
 109                chunk           <- atomically $ do chunk <- readItr itr itrBodyToSend id
 110                                                   writeItr itr itrBodyToSend B.empty
 111                                                   return chunk
 112                unless willDiscardBody
 113                           $ do if willChunkBody then
 114                                    do hPrintf h "%x\r\n" (toInteger $ B.length chunk)
 115                                       B.hPut  h chunk
 116                                       hPutStr h "\r\n"
 117                                  else
 118                                    B.hPut h chunk
 119                                hFlush h
 120                awaitSomethingToWrite
 121
 122       finishBodyChunk :: Interaction -> IO ()
 123       finishBodyChunk itr
 124           = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
 125                willChunkBody   <- atomically $ readItr itr itrWillChunkBody   id
 126                when (not willDiscardBody && willChunkBody)
 127                         $ hPutStr h "0\r\n\r\n" >> hFlush h
 128
 129       finalize :: Interaction -> IO ()
 130       finalize itr
 131           = do finishBodyChunk itr
 132                willClose <- atomically $ do queue <- readTVar tQueue
 133
 134                                             let (remaining :> _) = S.viewr queue
 135                                             writeTVar tQueue remaining
 136
 137                                             readItr itr itrWillClose id
 138                if willClose then
 139                    -- reader は恐らく hWaitForInput してゐる最中なので、
 140                    -- スレッドを豫め殺して置かないとをかしくなる。
 141                    do killThread readerTID
 142                       hClose h
 143                  else
 144                    awaitSomethingToWrite