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