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
  19 import Debug.Trace
  20
  21
  22 responseWriter :: Handle -> InteractionQueue -> IO ()
  23 responseWriter h tQueue
  24     = awaitSomethingToWrite
  25     where
  26       awaitSomethingToWrite :: IO ()
  27       awaitSomethingToWrite
  28           = do action
  29                    <- atomically $
  30                       do -- キューが空でなくなるまで待つ
  31                          queue <- readTVar tQueue
  32                          when (S.null queue)
  33                               retry
  34                          let _ :> itr = S.viewr queue
  35
  36                          -- GettingBody 状態にあり、Continue が期待され
  37                          -- てゐて、それがまだ送信前なのであれば、
  38                          -- Continue を送信する。
  39                          state <- readItr itr itrState id
  40
  41                          if state == GettingBody then
  42                              writeContinueIfNecessary itr
  43                            else
  44                              if state >= DecidingBody then
  45                                  writeHeaderOrBodyIfNecessary itr
  46                              else
  47                                  retry
  48                action
  49
  50       writeContinueIfNecessary :: Interaction -> STM (IO ())
  51       writeContinueIfNecessary itr
  52           = do expectedContinue <- readItr itr itrExpectedContinue id
  53                if expectedContinue then
  54
  55                    do wroteContinue <- readItr itr itrWroteContinue id
  56                       if wroteContinue then
  57                           -- 既に Continue を書込み濟
  58                           retry
  59                         else
  60                           return $ writeContinue itr
  61                  else
  62                    retry
  63
  64       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
  65       writeHeaderOrBodyIfNecessary itr
  66           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
  67           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
  68           -- 空でなければ、それを出力する。空である時は、もし状態が
  69           -- Done であれば後処理をする。
  70           = do wroteHeader <- readItr itr itrWroteHeader id
  71
  72                if not wroteHeader then
  73                    return $ writeHeader itr
  74                  else
  75                    do bodyToSend <- readItr itr itrBodyToSend id
  76
  77                       if B.null bodyToSend then
  78                           do state <- readItr itr itrState id
  79
  80                              if state == Done then
  81                                  return $ finalize itr
  82                                else
  83                                  retry
  84                         else
  85                           return $ writeBodyChunk itr
  86
  87       writeContinue :: Interaction -> IO ()
  88       writeContinue itr = fail "FIXME: not implemented"
  89
  90       writeHeader :: Interaction -> IO ()
  91       writeHeader itr
  92           = do res <- atomically $ do writeItr itr itrWroteHeader True
  93                                       readItr itr itrResponse id
  94                hPutResponse h (fromJust res)
  95                hFlush h
  96                awaitSomethingToWrite
  97
  98       writeBodyChunk :: Interaction -> IO ()
  99       writeBodyChunk itr
 100           = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
 101                willChunkBody   <- atomically $ readItr itr itrWillChunkBody   id
 102                chunk           <- atomically $ do chunk <- readItr itr itrBodyToSend id
 103                                                   writeItr itr itrBodyToSend B.empty
 104                                                   return chunk
 105                unless willDiscardBody
 106                           $ do if willChunkBody then
 107                                    fail "FIXME: not implemented"
 108                                  else
 109                                    B.hPut h chunk
 110                                hFlush h
 111                awaitSomethingToWrite
 112
 113       finishBodyChunk :: Interaction -> IO ()
 114       finishBodyChunk itr = return () -- FIXME: not implemented
 115
 116       finalize :: Interaction -> IO ()
 117       finalize itr
 118           = do finishBodyChunk itr
 119                willClose <- atomically $ do queue <- readTVar tQueue
 120
 121                                             let (remaining :> _) = S.viewr queue
 122                                             writeTVar tQueue remaining
 123
 124                                             readItr itr itrWillClose id
 125                if willClose then
 126                    hClose h
 127                  else
 128                    awaitSomethingToWrite