Network/HTTP/Lucu/ResponseWriter.hs

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