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