Network/HTTP/Lucu/ResponseWriter.hs

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