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           = do action
  36                    <- atomically $!
  37                       do -- キューが空でなくなるまで待つ
  38                          queue <- readTVar tQueue
  39                          when (S.null queue)
  40                               retry
  41
  42                          -- GettingBody 状態にあり、Continue が期待され
  43                          -- てゐて、それがまだ送信前なのであれば、
  44                          -- Continue を送信する。
  45                          case S.viewr queue of
  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           = itr `seq`
  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           = itr `seq`
  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 B.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           = itr `seq`
 102             do let cont = Response {
 103                             resVersion = HttpVersion 1 1
 104                           , resStatus  = Continue
 105                           , resHeaders = []
 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           = itr `seq`
 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           = itr `seq`
 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 B.empty
 129                                                    return chunk
 130                unless willDiscardBody
 131                           $ do if willChunkBody then
 132                                    do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
 133                                       hPutStr h "\r\n"
 134                                       B.hPut  h chunk
 135                                       hPutStr h "\r\n"
 136                                  else
 137                                    B.hPut h chunk
 138                                hFlush h
 139                awaitSomethingToWrite
 140
 141       finishBodyChunk :: Interaction -> IO ()
 142       finishBodyChunk itr
 143           = itr `seq`
 144             do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
 145                willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
 146                when (not willDiscardBody && willChunkBody)
 147                         $ hPutStr h "0\r\n\r\n" >> hFlush h
 148
 149       finalize :: Interaction -> IO ()
 150       finalize itr
 151           = itr `seq`
 152             do finishBodyChunk itr
 153                willClose <- atomically $!
 154                             do queue <- readTVar tQueue
 155
 156                                case S.viewr queue of
 157                                  remaining :> _ -> writeTVar tQueue remaining
 158
 159                                readItr itr itrWillClose id
 160                if willClose then
 161                    -- reader は恐らく hWaitForInput してゐる最中なので、
 162                    -- スレッドを豫め殺して置かないとをかしくなる。
 163                    do killThread readerTID
 164                       hClose h
 165                  else
 166                    awaitSomethingToWrite