Network/HTTP/Lucu/ResponseWriter.hs

   1 {-# LANGUAGE
   2     DoAndIfThenElse
   3   , RecordWildCards
   4   , ScopedTypeVariables
   5   , UnicodeSyntax
   6   #-}
   7 module Network.HTTP.Lucu.ResponseWriter
   8     ( responseWriter
   9     )
  10     where
  11 import qualified Blaze.ByteString.Builder.HTTP as BB
  12 import qualified Data.Ascii as A
  13 import Control.Concurrent
  14 import Control.Concurrent.STM
  15 import Control.Exception
  16 import Control.Monad
  17 import Data.Monoid.Unicode
  18 import qualified Data.Sequence as S
  19 import Data.Sequence (ViewR(..))
  20 import Network.HTTP.Lucu.Config
  21 import Network.HTTP.Lucu.HandleLike
  22 import Network.HTTP.Lucu.HttpVersion
  23 import Network.HTTP.Lucu.Interaction
  24 import Network.HTTP.Lucu.Postprocess
  25 import Network.HTTP.Lucu.Response
  26 import Prelude.Unicode
  27 import System.IO (hPutStrLn, stderr)
  28
  29 data Context h
  30     = Context {
  31         cConfig ∷ !Config
  32       , cHandle ∷ !h
  33       , cQueue  ∷ !InteractionQueue
  34       , cReader ∷ !ThreadId
  35       }
  36
  37 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
  38 responseWriter cnf h tQueue readerTID
  39     = awaitSomethingToWrite (Context cnf h tQueue readerTID)
  40       `catches`
  41       [ Handler $ \ (_ ∷ IOException)        → return ()
  42       , Handler $ \ e → case e of
  43                            ThreadKilled      → return ()
  44                            _                 → hPutStrLn stderr (show e)
  45       , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
  46       , Handler $ \ (e ∷ SomeException)      → hPutStrLn stderr (show e)
  47       ]
  48
  49 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
  50 awaitSomethingToWrite ctx@(Context {..})
  51     = join $
  52       atomically $
  53       -- キューが空でなくなるまで待つ
  54       do queue ← readTVar cQueue
  55          -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
  56          -- だ送信前なのであれば、Continue を送信する。
  57          case S.viewr queue of
  58            EmptyR   → retry
  59            _ :> itr → do state ← readTVar $ itrState itr
  60                          if state ≡ GettingBody then
  61                              writeContinueIfNeeded ctx itr
  62                          else
  63                              if state ≥ DecidingBody then
  64                                  writeHeaderOrBodyIfNeeded ctx itr
  65                              else
  66                                  retry
  67
  68 writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
  69 writeContinueIfNeeded ctx itr@(Interaction {..})
  70     = do expectedContinue ← readTVar itrExpectedContinue
  71          if expectedContinue then
  72              do wroteContinue ← readTVar itrWroteContinue
  73                 if wroteContinue then
  74                     -- 既に Continue を書込み濟
  75                     retry
  76                 else
  77                     do reqBodyWanted ← readTVar itrReqBodyWanted
  78                        if reqBodyWanted ≢ Nothing then
  79                            return $ writeContinue ctx itr
  80                        else
  81                            retry
  82          else
  83              retry
  84
  85 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
  86 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
  87 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
  88 writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
  89 writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
  90     = do wroteHeader ← readTVar itrWroteHeader
  91          if not wroteHeader then
  92              return $ writeHeader ctx itr
  93          else
  94              do noBodyToWrite ← isEmptyTMVar itrBodyToSend
  95                 if noBodyToWrite then
  96                     do state ← readTVar itrState
  97                        if state ≡ Done then
  98                            return $ finalize ctx itr
  99                        else
 100                            retry
 101                 else
 102                     return $ writeBodyChunk ctx itr
 103
 104 writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 105 writeContinue ctx@(Context {..}) (Interaction {..})
 106     = do let cont = Response {
 107                       resVersion = HttpVersion 1 1
 108                     , resStatus  = Continue
 109                     , resHeaders = (∅)
 110                     }
 111          cont' ← completeUnconditionalHeaders cConfig cont
 112          hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
 113          hFlush cHandle
 114          atomically $ writeTVar itrWroteContinue True
 115          awaitSomethingToWrite ctx
 116
 117 writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 118 writeHeader ctx@(Context {..}) (Interaction {..})
 119     = do res ← atomically
 120                $ do writeTVar itrWroteHeader True
 121                     readTVar itrResponse
 122          hPutBuilder cHandle $ A.toBuilder $ printResponse res
 123          hFlush cHandle
 124          awaitSomethingToWrite ctx
 125
 126 writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 127 writeBodyChunk ctx@(Context {..}) (Interaction {..})
 128     = join $
 129       atomically $
 130       do willDiscardBody ← readTVar itrWillDiscardBody
 131          if willDiscardBody then
 132              do _ ← tryTakeTMVar itrBodyToSend
 133                 return $ awaitSomethingToWrite ctx
 134          else
 135              do willChunkBody ← readTVar itrWillChunkBody
 136                 chunk         ← takeTMVar itrBodyToSend
 137                 return $
 138                     do if willChunkBody then
 139                            hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
 140                        else
 141                            hPutBuilder cHandle chunk
 142                        hFlush cHandle
 143                        awaitSomethingToWrite ctx
 144
 145 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 146 finishBodyChunk (Context {..}) (Interaction {..})
 147     = join $
 148       atomically $
 149       do willDiscardBody ← readTVar itrWillDiscardBody
 150          willChunkBody   ← readTVar itrWillChunkBody
 151          if ((¬) willDiscardBody) ∧ willChunkBody then
 152              return $
 153                  do hPutBuilder cHandle BB.chunkedTransferTerminator
 154                     hFlush cHandle
 155          else
 156              return $ return ()
 157
 158 finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 159 finalize ctx@(Context {..}) itr@(Interaction {..})
 160     = do finishBodyChunk ctx itr
 161          willClose ← atomically $
 162                      do queue ← readTVar cQueue
 163                         case S.viewr queue of
 164                           EmptyR         → return () -- this should never happen
 165                           remaining :> _ → writeTVar cQueue remaining
 166                         readTVar itrWillClose
 167          if willClose then
 168              -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
 169              -- ドを豫め殺して置かないとをかしくなる。
 170              do killThread cReader
 171                 hClose cHandle
 172          else
 173              awaitSomethingToWrite ctx