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 C8
   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.Headers
  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           = {-# SCC "awaitSomethingToWrite" #-}
  37             do action
  38                    <- atomically $!
  39                       do -- キューが空でなくなるまで待つ
  40                          queue <- readTVar tQueue
  41                          when (S.null queue)
  42                               retry
  43
  44                          -- GettingBody 状態にあり、Continue が期待され
  45                          -- てゐて、それがまだ送信前なのであれば、
  46                          -- Continue を送信する。
  47                          case S.viewr queue of
  48                            _ :> itr -> do state <- readItr itr itrState id
  49
  50                                           if state == GettingBody then
  51                                               writeContinueIfNecessary itr
  52                                             else
  53                                               if state >= DecidingBody then
  54                                                   writeHeaderOrBodyIfNecessary itr
  55                                               else
  56                                                   retry
  57                action
  58
  59       writeContinueIfNecessary :: Interaction -> STM (IO ())
  60       writeContinueIfNecessary itr
  61           = {-# SCC "writeContinueIfNecessary" #-}
  62             itr `seq`
  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           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
  85             itr `seq`
  86             do wroteHeader <- readItr itr itrWroteHeader id
  87
  88                if not wroteHeader then
  89                    return $! writeHeader itr
  90                  else
  91                    do bodyToSend <- readItr itr itrBodyToSend id
  92
  93                       if C8.null bodyToSend then
  94                           do state <- readItr itr itrState id
  95
  96                              if state == Done then
  97                                  return $! finalize itr
  98                                else
  99                                  retry
 100                         else
 101                           return $! writeBodyChunk itr
 102
 103       writeContinue :: Interaction -> IO ()
 104       writeContinue itr
 105           = {-# SCC "writeContinue" #-}
 106             itr `seq`
 107             do let cont = Response {
 108                             resVersion = HttpVersion 1 1
 109                           , resStatus  = Continue
 110                           , resHeaders = emptyHeaders
 111                           }
 112                cont' <- completeUnconditionalHeaders cnf cont
 113                hPutResponse h cont'
 114                hFlush h
 115                atomically $! writeItr itr itrWroteContinue True
 116                awaitSomethingToWrite
 117
 118       writeHeader :: Interaction -> IO ()
 119       writeHeader itr
 120           = {-# SCC "writeHeader" #-}
 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           = {-# SCC "writeBodyChunk" #-}
 131             itr `seq`
 132             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 133                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 134                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
 135                                                    writeItr itr itrBodyToSend C8.empty
 136                                                    return chunk
 137                unless willDiscardBody
 138                           $ do if willChunkBody then
 139                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
 140                                       C8.hPut h (C8.pack "\r\n")
 141                                       C8.hPut h chunk
 142                                       C8.hPut h (C8.pack "\r\n")
 143                                  else
 144                                    C8.hPut h chunk
 145                                hFlush h
 146                awaitSomethingToWrite
 147
 148       finishBodyChunk :: Interaction -> IO ()
 149       finishBodyChunk itr
 150           = {-# SCC "finishBodyChunk" #-}
 151             itr `seq`
 152             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 153                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 154                when (not willDiscardBody && willChunkBody)
 155                         $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
 156
 157       finalize :: Interaction -> IO ()
 158       finalize itr
 159           = {-# SCC "finalize" #-}
 160             itr `seq`
 161             do finishBodyChunk itr
 162                willClose <- atomically $!
 163                             do queue <- readTVar tQueue
 164
 165                                case S.viewr queue of
 166                                  remaining :> _ -> writeTVar tQueue remaining
 167
 168                                readItr itr itrWillClose id
 169                if willClose then
 170                    -- reader は恐らく hWaitForInput してゐる最中なので、
 171                    -- スレッドを豫め殺して置かないとをかしくなる。
 172                    do killThread readerTID
 173                       hClose h
 174                  else
 175                    awaitSomethingToWrite