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