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