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