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