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.HandleLike
  16 import           Network.HTTP.Lucu.Headers
  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 (stderr)
  23
  24
  25 responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
  26 responseWriter !cnf !h !tQueue !readerTID
  27     = awaitSomethingToWrite
  28       `catches`
  29       [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
  30       , Handler  ( \ ThreadKilled        -> return () )
  31       , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
  32       , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
  33       ]
  34     where
  35       awaitSomethingToWrite :: IO ()
  36       awaitSomethingToWrite
  37           = {-# SCC "awaitSomethingToWrite" #-}
  38             join $!
  39                  atomically $!
  40                  -- キューが空でなくなるまで待つ
  41                  do queue <- readTVar tQueue
  42                     -- GettingBody 状態にあり、Continue が期待されてゐ
  43                     -- て、それがまだ送信前なのであれば、Continue を送
  44                     -- 信する。
  45                     case S.viewr queue of
  46                       EmptyR   -> retry
  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
  57       writeContinueIfNecessary :: Interaction -> STM (IO ())
  58       writeContinueIfNecessary !itr
  59           = {-# SCC "writeContinueIfNecessary" #-}
  60             do expectedContinue <- readItr itr itrExpectedContinue id
  61                if expectedContinue then
  62                    do wroteContinue <- readItr itr itrWroteContinue id
  63                       if wroteContinue then
  64                           -- 既に Continue を書込み濟
  65                           retry
  66                         else
  67                           do reqBodyWanted <- readItr itr itrReqBodyWanted id
  68                              if reqBodyWanted /= Nothing then
  69                                  return $ writeContinue itr
  70                                else
  71                                  retry
  72                  else
  73                    retry
  74
  75       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
  76       writeHeaderOrBodyIfNecessary !itr
  77           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
  78           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
  79           -- 空でなければ、それを出力する。空である時は、もし状態が
  80           -- Done であれば後処理をする。
  81           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
  82             do wroteHeader <- readItr itr itrWroteHeader id
  83
  84                if not wroteHeader then
  85                    return $! writeHeader itr
  86                  else
  87                    do bodyToSend <- readItr itr itrBodyToSend id
  88
  89                       if C8.null bodyToSend then
  90                           do state <- readItr itr itrState id
  91
  92                              if state == Done then
  93                                  return $! finalize itr
  94                                else
  95                                  retry
  96                         else
  97                           return $! writeBodyChunk itr
  98
  99       writeContinue :: Interaction -> IO ()
 100       writeContinue !itr
 101           = {-# SCC "writeContinue" #-}
 102             do let cont = Response {
 103                             resVersion = HttpVersion 1 1
 104                           , resStatus  = Continue
 105                           , resHeaders = emptyHeaders
 106                           }
 107                cont' <- completeUnconditionalHeaders cnf cont
 108                hPutResponse h cont'
 109                hFlush h
 110                atomically $! writeItr itr itrWroteContinue True
 111                awaitSomethingToWrite
 112
 113       writeHeader :: Interaction -> IO ()
 114       writeHeader !itr
 115           = {-# SCC "writeHeader" #-}
 116             do res <- atomically $! do writeItr itr itrWroteHeader True
 117                                        readItr itr itrResponse id
 118                hPutResponse h res
 119                hFlush h
 120                awaitSomethingToWrite
 121
 122       writeBodyChunk :: Interaction -> IO ()
 123       writeBodyChunk !itr
 124           = {-# SCC "writeBodyChunk" #-}
 125             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 126                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 127                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
 128                                                    writeItr itr itrBodyToSend C8.empty
 129                                                    return chunk
 130                unless willDiscardBody
 131                           $ do if willChunkBody then
 132                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
 133                                       hPutLBS h (C8.pack "\r\n")
 134                                       hPutLBS h chunk
 135                                       hPutLBS h (C8.pack "\r\n")
 136                                  else
 137                                    hPutLBS h chunk
 138                                hFlush h
 139                awaitSomethingToWrite
 140
 141       finishBodyChunk :: Interaction -> IO ()
 142       finishBodyChunk !itr
 143           = {-# SCC "finishBodyChunk" #-}
 144             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 145                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 146                when (not willDiscardBody && willChunkBody)
 147                         $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
 148
 149       finalize :: Interaction -> IO ()
 150       finalize !itr
 151           = {-# SCC "finalize" #-}
 152             do finishBodyChunk itr
 153                willClose <- atomically $!
 154                             do queue <- readTVar tQueue
 155
 156                                case S.viewr queue of
 157                                  EmptyR         -> return () -- this should never happen
 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