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     = awaitSomethingToWrite
  27       `catches`
  28       [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
  29       , Handler  ( \ ThreadKilled        -> return () )
  30       , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
  31       , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
  32       ]
  33     where
  34       awaitSomethingToWrite :: IO ()
  35       awaitSomethingToWrite
  36           = {-# SCC "awaitSomethingToWrite" #-}
  37             do action
  38                    <- atomically $!
  39                       -- キューが空でなくなるまで待つ
  40                       do queue <- readTVar tQueue
  41                          -- GettingBody 状態にあり、Continue が期待され
  42                          -- てゐて、それがまだ送信前なのであれば、
  43                          -- Continue を送信する。
  44                          case S.viewr queue of
  45                            EmptyR   -> retry
  46                            _ :> itr -> do state <- readItr itr itrState id
  47
  48                                           if state == GettingBody then
  49                                               writeContinueIfNecessary itr
  50                                             else
  51                                               if state >= DecidingBody then
  52                                                   writeHeaderOrBodyIfNecessary itr
  53                                               else
  54                                                   retry
  55                action
  56
  57       writeContinueIfNecessary :: Interaction -> STM (IO ())
  58       writeContinueIfNecessary itr
  59           = {-# SCC "writeContinueIfNecessary" #-}
  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           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
  83             itr `seq`
  84             do wroteHeader <- readItr itr itrWroteHeader id
  85
  86                if not wroteHeader then
  87                    return $! writeHeader itr
  88                  else
  89                    do bodyToSend <- readItr itr itrBodyToSend id
  90
  91                       if C8.null bodyToSend then
  92                           do state <- readItr itr itrState id
  93
  94                              if state == Done then
  95                                  return $! finalize itr
  96                                else
  97                                  retry
  98                         else
  99                           return $! writeBodyChunk itr
 100
 101       writeContinue :: Interaction -> IO ()
 102       writeContinue itr
 103           = {-# SCC "writeContinue" #-}
 104             itr `seq`
 105             do let cont = Response {
 106                             resVersion = HttpVersion 1 1
 107                           , resStatus  = Continue
 108                           , resHeaders = emptyHeaders
 109                           }
 110                cont' <- completeUnconditionalHeaders cnf cont
 111                hPutResponse h cont'
 112                hFlush h
 113                atomically $! writeItr itr itrWroteContinue True
 114                awaitSomethingToWrite
 115
 116       writeHeader :: Interaction -> IO ()
 117       writeHeader itr
 118           = {-# SCC "writeHeader" #-}
 119             itr `seq`
 120             do res <- atomically $! do writeItr itr itrWroteHeader True
 121                                        readItr itr itrResponse id
 122                hPutResponse h res
 123                hFlush h
 124                awaitSomethingToWrite
 125
 126       writeBodyChunk :: Interaction -> IO ()
 127       writeBodyChunk itr
 128           = {-# SCC "writeBodyChunk" #-}
 129             itr `seq`
 130             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 131                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 132                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
 133                                                    writeItr itr itrBodyToSend C8.empty
 134                                                    return chunk
 135                unless willDiscardBody
 136                           $ do if willChunkBody then
 137                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
 138                                       C8.hPut h (C8.pack "\r\n")
 139                                       C8.hPut h chunk
 140                                       C8.hPut h (C8.pack "\r\n")
 141                                  else
 142                                    C8.hPut h chunk
 143                                hFlush h
 144                awaitSomethingToWrite
 145
 146       finishBodyChunk :: Interaction -> IO ()
 147       finishBodyChunk itr
 148           = {-# SCC "finishBodyChunk" #-}
 149             itr `seq`
 150             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 151                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 152                when (not willDiscardBody && willChunkBody)
 153                         $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
 154
 155       finalize :: Interaction -> IO ()
 156       finalize itr
 157           = {-# SCC "finalize" #-}
 158             itr `seq`
 159             do finishBodyChunk itr
 160                willClose <- atomically $!
 161                             do queue <- readTVar tQueue
 162
 163                                case S.viewr queue of
 164                                  EmptyR         -> return () -- this should never happen
 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