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.Applicative
  13 import Control.Concurrent
  14 import Control.Concurrent.STM
  15 import Control.Exception
  16 import Control.Monad
  17 import Data.Ascii (AsciiBuilder)
  18 import Data.Convertible.Utils
  19 import GHC.IO.Exception (IOException(..), IOErrorType(..))
  20 import Data.Monoid.Unicode
  21 import qualified Data.Sequence as S
  22 import Data.Sequence (ViewR(..))
  23 import Network.HTTP.Lucu.Config
  24 import Network.HTTP.Lucu.HandleLike
  25 import Network.HTTP.Lucu.HttpVersion
  26 import Network.HTTP.Lucu.Interaction
  27 import Network.HTTP.Lucu.Response
  28 import Prelude.Unicode
  29 import System.IO (hPutStrLn, stderr)
  30
  31 data Context h
  32     = Context {
  33         cConfig ∷ !Config
  34       , cHandle ∷ !h
  35       , cQueue  ∷ !InteractionQueue
  36       }
  37
  38 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
  39 responseWriter cnf h tQueue readerTID
  40     = awaitSomethingToWrite (Context cnf h tQueue)
  41       `catches`
  42       [ Handler handleIOE
  43       , Handler handleAsyncE
  44       , Handler handleOthers
  45       ]
  46       `finally`
  47       do killThread readerTID
  48          hClose h
  49     where
  50       handleIOE ∷ IOException → IO ()
  51       handleIOE e@(IOError {..})
  52           | ioe_type ≡ ResourceVanished = return ()
  53           | otherwise                   = dump e
  54
  55       handleAsyncE ∷ AsyncException → IO ()
  56       handleAsyncE ThreadKilled = return ()
  57       handleAsyncE e            = dump e
  58
  59       handleOthers ∷ SomeException → IO ()
  60       handleOthers = dump
  61
  62       dump ∷ Exception e ⇒ e → IO ()
  63       dump e
  64           = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
  65                hPutStrLn stderr $ show e
  66
  67 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
  68 awaitSomethingToWrite ctx@(Context {..})
  69     = join $
  70       atomically $
  71       do queue ← readTVar cQueue
  72          case S.viewr queue of
  73            EmptyR        → retry
  74            queue' :> itr → do writeTVar cQueue queue'
  75                               return $ writeSomething ctx itr
  76
  77 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
  78 writeSomething ctx itr
  79     = let writer = writeResponseForNI  ctx <$> fromInteraction itr <|>
  80                    writeResponseForSEI ctx <$> fromInteraction itr <|>
  81                    writeResponseForSYI ctx <$> fromInteraction itr <|>
  82                    endOfResponses          <$> fromInteraction itr
  83       in
  84         case writer of
  85           Just f  → f
  86           Nothing → fail "Internal error: unknown interaction type"
  87
  88 writeResponseForNI ∷ HandleLike h
  89                    ⇒ Context h
  90                    → NormalInteraction
  91                    → IO ()
  92 writeResponseForNI = writeContinueIfNeeded
  93
  94 writeContinueIfNeeded ∷ HandleLike h
  95                       ⇒ Context h
  96                       → NormalInteraction
  97                       → IO ()
  98 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
  99     = do isNeeded ← atomically $ readTMVar niSendContinue
 100          when isNeeded
 101              $ do let cont = Response {
 102                                resVersion = HttpVersion 1 1
 103                              , resStatus  = fromStatusCode Continue
 104                              , resHeaders = (∅)
 105                              }
 106                   hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
 107                   hFlush cHandle
 108          writeHeader ctx ni
 109
 110 writeHeader ∷ HandleLike h
 111             ⇒ Context h
 112             → NormalInteraction
 113             → IO ()
 114 writeHeader ctx@(Context {..}) ni@(NI {..})
 115     = do res ← atomically $
 116                do state ← readTVar niState
 117                   if state ≥ SendingBody then
 118                       readTVar niResponse
 119                   else
 120                       retry -- Too early to write header fields.
 121          hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
 122          hFlush cHandle
 123          writeBodyIfNeeded ctx ni
 124
 125 writeBodyIfNeeded ∷ HandleLike h
 126                   ⇒ Context h
 127                   → NormalInteraction
 128                   → IO ()
 129 writeBodyIfNeeded ctx ni@(NI {..})
 130     = join $
 131       atomically $
 132       do willDiscardBody ← readTVar niWillDiscardBody
 133          if willDiscardBody then
 134              return $ discardBody ctx ni
 135          else
 136              if niWillChunkBody then
 137                  return $ writeChunkedBody    ctx ni
 138              else
 139                  return $ writeNonChunkedBody ctx ni
 140
 141 discardBody ∷ HandleLike h
 142             ⇒ Context h
 143             → NormalInteraction
 144             → IO ()
 145 discardBody ctx ni@(NI {..})
 146     = join $
 147       atomically $
 148       do chunk ← tryTakeTMVar niBodyToSend
 149          case chunk of
 150            Just _  → return $ discardBody ctx ni
 151            Nothing → do state ← readTVar niState
 152                         if state ≡ Done then
 153                             return $ finalize ctx ni
 154                         else
 155                             retry
 156
 157 writeChunkedBody ∷ HandleLike h
 158                  ⇒ Context h
 159                  → NormalInteraction
 160                  → IO ()
 161 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
 162     = join $
 163       atomically $
 164       do chunk ← tryTakeTMVar niBodyToSend
 165          case chunk of
 166            Just b  → return $
 167                      do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
 168                         hFlush cHandle
 169                         writeChunkedBody ctx ni
 170            Nothing → do state ← readTVar niState
 171                         if state ≡ Done then
 172                             return $
 173                             do hPutBuilder cHandle BB.chunkedTransferTerminator
 174                                hFlush cHandle
 175                                finalize ctx ni
 176                         else
 177                             retry
 178
 179 writeNonChunkedBody ∷ HandleLike h
 180                     ⇒ Context h
 181                     → NormalInteraction
 182                     → IO ()
 183 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
 184     = join $
 185       atomically $
 186       do chunk ← tryTakeTMVar niBodyToSend
 187          case chunk of
 188            Just b  → return $
 189                      do hPutBuilder cHandle b
 190                         hFlush cHandle
 191                         writeNonChunkedBody ctx ni
 192            Nothing → do state ← readTVar niState
 193                         if state ≡ Done then
 194                             return $ finalize ctx ni
 195                         else
 196                             retry
 197
 198 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
 199 finalize ctx@(Context {..}) (NI {..})
 200     = join $
 201       atomically $
 202       do willClose    ← readTVar  niWillClose
 203          sentContinue ← takeTMVar niSendContinue
 204          return $
 205              if needToClose willClose sentContinue then
 206                  return ()
 207              else
 208                  awaitSomethingToWrite ctx
 209     where
 210       needToClose ∷ Bool → Bool → Bool
 211       needToClose willClose sentContinue
 212           -- Explicitly instructed to close the connection.
 213           | willClose = True
 214           -- We've sent both "HTTP/1.1 100 Continue" and a final
 215           -- response, so nothing prevents our connection from keeping
 216           -- alive.
 217           | sentContinue = False
 218           -- We've got "Expect: 100-continue" but have sent a final
 219           -- response without sending "HTTP/1.1 100
 220           -- Continue". According to the RFC 2616 (HTTP/1.1), it is
 221           -- undecidable whether the client will send us its
 222           -- (rejected) request body OR start a completely new request
 223           -- in this situation. So the only possible thing to do is to
 224           -- brutally shutdown the connection.
 225           | niExpectedContinue = True
 226           -- The client didn't expect 100-continue so we haven't sent
 227           -- one. No need to do anything special.
 228           | otherwise = False
 229
 230 writeResponseForSEI ∷ HandleLike h
 231                     ⇒ Context h
 232                     → SemanticallyInvalidInteraction
 233                     → IO ()
 234 writeResponseForSEI ctx@(Context {..}) (SEI {..})
 235     = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
 236          unless seiWillDiscardBody $
 237              if seiWillChunkBody then
 238                  do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
 239                     hPutBuilder cHandle BB.chunkedTransferTerminator
 240              else
 241                  hPutBuilder cHandle seiBodyToSend
 242          hFlush cHandle
 243          if seiWillClose ∨ seiExpectedContinue then
 244              return ()
 245          else
 246              awaitSomethingToWrite ctx
 247
 248 writeResponseForSYI ∷ HandleLike h
 249                     ⇒ Context h
 250                     → SyntacticallyInvalidInteraction
 251                     → IO ()
 252 writeResponseForSYI (Context {..}) (SYI {..})
 253     = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
 254          hPutBuilder cHandle syiBodyToSend
 255          hFlush cHandle
 256          return ()
 257
 258 endOfResponses ∷ EndOfInteraction → IO ()
 259 endOfResponses _ = return ()