Network/HTTP/Lucu/ResponseWriter.hs

   1 module Network.HTTP.Lucu.ResponseWriter
   2     ( responseWriter
   3     )
   4     where
   5
   6 import qualified Data.ByteString.Lazy.Char8 as B
   7 import           Control.Concurrent
   8 import           Control.Concurrent.STM
   9 import           Control.Exception
  10 import           Control.Monad
  11 import qualified Data.Sequence as S
  12 import           Data.Sequence (ViewR(..))
  13 import           Network.HTTP.Lucu.Config
  14 import           Network.HTTP.Lucu.Format
  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
  22
  23 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
  24 responseWriter cnf h tQueue readerTID
  25     = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
  26       catch awaitSomethingToWrite $ \ exc ->
  27       case exc of
  28         IOException _               -> return ()
  29         AsyncException ThreadKilled -> return ()
  30         BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
  31         _                           -> print exc
  32     where
  33       awaitSomethingToWrite :: IO ()
  34       awaitSomethingToWrite
  35           = {-# SCC "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           = {-# SCC "writeContinueIfNecessary" #-}
  61             itr `seq`
  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           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
  84             itr `seq`
  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           = {-# SCC "writeContinue" #-}
 105             itr `seq`
 106             do let cont = Response {
 107                             resVersion = HttpVersion 1 1
 108                           , resStatus  = Continue
 109                           , resHeaders = []
 110                           }
 111                cont' <- completeUnconditionalHeaders cnf cont
 112                hPutResponse h cont'
 113                hFlush h
 114                atomically $! writeItr itr itrWroteContinue True
 115                awaitSomethingToWrite
 116
 117       writeHeader :: Interaction -> IO ()
 118       writeHeader itr
 119           = {-# SCC "writeHeader" #-}
 120             itr `seq`
 121             do res <- atomically $! do writeItr itr itrWroteHeader True
 122                                        readItr itr itrResponse id
 123                hPutResponse h res
 124                hFlush h
 125                awaitSomethingToWrite
 126
 127       writeBodyChunk :: Interaction -> IO ()
 128       writeBodyChunk itr
 129           = {-# SCC "writeBodyChunk" #-}
 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           = {-# SCC "finishBodyChunk" #-}
 150             itr `seq`
 151             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 152                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 153                when (not willDiscardBody && willChunkBody)
 154                         $ hPutStr h "0\r\n\r\n" >> hFlush h
 155
 156       finalize :: Interaction -> IO ()
 157       finalize itr
 158           = {-# SCC "finalize" #-}
 159             itr `seq`
 160             do finishBodyChunk itr
 161                willClose <- atomically $!
 162                             do queue <- readTVar tQueue
 163
 164                                case S.viewr queue of
 165                                  remaining :> _ -> writeTVar tQueue remaining
 166
 167                                readItr itr itrWillClose id
 168                if willClose then
 169                    -- reader は恐らく hWaitForInput してゐる最中なので、
 170                    -- スレッドを豫め殺して置かないとをかしくなる。
 171                    do killThread readerTID
 172                       hClose h
 173                  else
 174                    awaitSomethingToWrite