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           Control.Concurrent
   9 import           Control.Concurrent.STM
  10 import           Control.Exception
  11 import           Control.Monad
  12 import qualified Data.Sequence as S
  13 import           Data.Sequence (ViewR(..))
  14 import           Network.HTTP.Lucu.Config
  15 import           Network.HTTP.Lucu.Format
  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
  23
  24 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
  25 responseWriter cnf h tQueue readerTID
  26     = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
  27       catch awaitSomethingToWrite $ \ exc ->
  28       case exc of
  29         IOException _               -> return ()
  30         AsyncException ThreadKilled -> return ()
  31         BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
  32         _                           -> print exc
  33     where
  34       awaitSomethingToWrite :: IO ()
  35       awaitSomethingToWrite
  36           = do action
  37                    <- atomically $!
  38                       do -- キューが空でなくなるまで待つ
  39                          queue <- readTVar tQueue
  40                          when (S.null queue)
  41                               retry
  42
  43                          -- GettingBody 状態にあり、Continue が期待され
  44                          -- てゐて、それがまだ送信前なのであれば、
  45                          -- Continue を送信する。
  46                          case S.viewr queue of
  47                            _ :> itr -> do state <- readItr itr itrState id
  48
  49                                           if state == GettingBody then
  50                                               writeContinueIfNecessary itr
  51                                             else
  52                                               if state >= DecidingBody then
  53                                                   writeHeaderOrBodyIfNecessary itr
  54                                               else
  55                                                   retry
  56                action
  57
  58       writeContinueIfNecessary :: Interaction -> STM (IO ())
  59       writeContinueIfNecessary itr
  60           = itr `seq`
  61             do expectedContinue <- readItr itr itrExpectedContinue id
  62                if expectedContinue then
  63                    do wroteContinue <- readItr itr itrWroteContinue id
  64                       if wroteContinue then
  65                           -- 既に Continue を書込み濟
  66                           retry
  67                         else
  68                           do reqBodyWanted <- readItr itr itrReqBodyWanted id
  69                              if reqBodyWanted /= Nothing then
  70                                  return $ writeContinue itr
  71                                else
  72                                  retry
  73                  else
  74                    retry
  75
  76       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
  77       writeHeaderOrBodyIfNecessary itr
  78           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
  79           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
  80           -- 空でなければ、それを出力する。空である時は、もし状態が
  81           -- Done であれば後処理をする。
  82           = itr `seq`
  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           = itr `seq`
 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           = itr `seq`
 117             do res <- atomically $! do writeItr itr itrWroteHeader True
 118                                        readItr itr itrResponse id
 119                hPutResponse h res
 120                hFlush h
 121                awaitSomethingToWrite
 122
 123       writeBodyChunk :: Interaction -> IO ()
 124       writeBodyChunk itr
 125           = itr `seq`
 126             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 127                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 128                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
 129                                                    writeItr itr itrBodyToSend B.empty
 130                                                    return chunk
 131                unless willDiscardBody
 132                           $ do if willChunkBody then
 133                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
 134                                       hPutStr h "\r\n"
 135                                       B.hPut  h chunk
 136                                       hPutStr h "\r\n"
 137                                  else
 138                                    B.hPut h chunk
 139                                hFlush h
 140                awaitSomethingToWrite
 141
 142       finishBodyChunk :: Interaction -> IO ()
 143       finishBodyChunk itr
 144           = itr `seq`
 145             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 146                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 147                when (not willDiscardBody && willChunkBody)
 148                         $ hPutStr h "0\r\n\r\n" >> hFlush h
 149
 150       finalize :: Interaction -> IO ()
 151       finalize itr
 152           = itr `seq`
 153             do finishBodyChunk itr
 154                willClose <- atomically $!
 155                             do queue <- readTVar tQueue
 156
 157                                case S.viewr queue of
 158                                  remaining :> _ -> writeTVar tQueue remaining
 159
 160                                readItr itr itrWillClose id
 161                if willClose then
 162                    -- reader は恐らく hWaitForInput してゐる最中なので、
 163                    -- スレッドを豫め殺して置かないとをかしくなる。
 164                    do killThread readerTID
 165                       hClose h
 166                  else
 167                    awaitSomethingToWrite