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