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