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