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