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