Network/HTTP/Lucu/ResponseWriter.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , UnicodeSyntax
   4   #-}
   5 module Network.HTTP.Lucu.ResponseWriter
   6     ( responseWriter
   7     )
   8     where
   9
  10 import qualified Data.ByteString.Lazy.Char8 as C8
  11 import           Control.Concurrent
  12 import           Control.Concurrent.STM
  13 import           Control.Exception
  14 import           Control.Monad
  15 import qualified Data.Sequence as S
  16 import           Data.Sequence (ViewR(..))
  17 import           Network.HTTP.Lucu.Config
  18 import           Network.HTTP.Lucu.Format
  19 import           Network.HTTP.Lucu.HandleLike
  20 import           Network.HTTP.Lucu.Headers
  21 import           Network.HTTP.Lucu.HttpVersion
  22 import           Network.HTTP.Lucu.Interaction
  23 import           Network.HTTP.Lucu.Postprocess
  24 import           Network.HTTP.Lucu.Response
  25 import           Prelude hiding (catch)
  26 import           System.IO (stderr)
  27
  28
  29 responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
  30 responseWriter !cnf !h !tQueue !readerTID
  31     = awaitSomethingToWrite
  32       `catches`
  33       [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
  34       , Handler  ( \ ThreadKilled        -> return () )
  35       , Handler  ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
  36       , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
  37       ]
  38     where
  39       awaitSomethingToWrite :: IO ()
  40       awaitSomethingToWrite
  41           = {-# SCC "awaitSomethingToWrite" #-}
  42             join $!
  43                  atomically $!
  44                  -- キューが空でなくなるまで待つ
  45                  do queue <- readTVar tQueue
  46                     -- GettingBody 状態にあり、Continue が期待されてゐ
  47                     -- て、それがまだ送信前なのであれば、Continue を送
  48                     -- 信する。
  49                     case S.viewr queue of
  50                       EmptyR   -> retry
  51                       _ :> itr -> do state <- readItr itr itrState id
  52
  53                                      if state == GettingBody then
  54                                          writeContinueIfNecessary itr
  55                                        else
  56                                          if state >= DecidingBody then
  57                                              writeHeaderOrBodyIfNecessary itr
  58                                          else
  59                                              retry
  60
  61       writeContinueIfNecessary :: Interaction -> STM (IO ())
  62       writeContinueIfNecessary !itr
  63           = {-# SCC "writeContinueIfNecessary" #-}
  64             do expectedContinue <- readItr itr itrExpectedContinue id
  65                if expectedContinue then
  66                    do wroteContinue <- readItr itr itrWroteContinue id
  67                       if wroteContinue then
  68                           -- 既に Continue を書込み濟
  69                           retry
  70                         else
  71                           do reqBodyWanted <- readItr itr itrReqBodyWanted id
  72                              if reqBodyWanted /= Nothing then
  73                                  return $ writeContinue itr
  74                                else
  75                                  retry
  76                  else
  77                    retry
  78
  79       writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
  80       writeHeaderOrBodyIfNecessary !itr
  81           -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
  82           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
  83           -- 空でなければ、それを出力する。空である時は、もし状態が
  84           -- Done であれば後処理をする。
  85           = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
  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             do let cont = Response {
 107                             resVersion = HttpVersion 1 1
 108                           , resStatus  = Continue
 109                           , resHeaders = emptyHeaders
 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             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             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 130                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 131                chunk           <- atomically $! do chunk <- readItr itr itrBodyToSend id
 132                                                    writeItr itr itrBodyToSend C8.empty
 133                                                    return chunk
 134                unless willDiscardBody
 135                           $ do if willChunkBody then
 136                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
 137                                       hPutLBS h (C8.pack "\r\n")
 138                                       hPutLBS h chunk
 139                                       hPutLBS h (C8.pack "\r\n")
 140                                  else
 141                                    hPutLBS h chunk
 142                                hFlush h
 143                awaitSomethingToWrite
 144
 145       finishBodyChunk :: Interaction -> IO ()
 146       finishBodyChunk !itr
 147           = {-# SCC "finishBodyChunk" #-}
 148             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 149                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 150                when (not willDiscardBody && willChunkBody)
 151                         $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
 152
 153       finalize :: Interaction -> IO ()
 154       finalize !itr
 155           = {-# SCC "finalize" #-}
 156             do finishBodyChunk itr
 157                willClose <- atomically $!
 158                             do queue <- readTVar tQueue
 159
 160                                case S.viewr queue of
 161                                  EmptyR         -> return () -- this should never happen
 162                                  remaining :> _ -> writeTVar tQueue remaining
 163
 164                                readItr itr itrWillClose id
 165                if willClose then
 166                    -- reader は恐らく hWaitForInput してゐる最中なので、
 167                    -- スレッドを豫め殺して置かないとをかしくなる。
 168                    do killThread readerTID
 169                       hClose h
 170                  else
 171                    awaitSomethingToWrite