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