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.Concurrent
  13 import Control.Concurrent.STM
  14 import Control.Exception
  15 import Control.Monad
  16 import qualified Data.Ascii as A
  17 import Data.Monoid.Unicode
  18 import qualified Data.Sequence as S
  19 import Data.Sequence (ViewR(..))
  20 import Network.HTTP.Lucu.Config
  21 import Network.HTTP.Lucu.HandleLike
  22 import Network.HTTP.Lucu.HttpVersion
  23 import Network.HTTP.Lucu.Interaction
  24 import Network.HTTP.Lucu.Postprocess
  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 $ writeContinueIfNeeded ctx itr
  83
  84 writeContinueIfNeeded ∷ HandleLike h
  85                       ⇒ Context h
  86                       → Interaction
  87                       → IO ()
  88 writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
  89     = do isNeeded ← atomically $ readTMVar itrSendContinue
  90          when isNeeded
  91              $ do let cont = Response {
  92                                resVersion = HttpVersion 1 1
  93                              , resStatus  = Continue
  94                              , resHeaders = (∅)
  95                              }
  96                   cont' ← completeUnconditionalHeaders cConfig cont
  97                   hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
  98                   hFlush cHandle
  99          writeHeader ctx itr
 100
 101 writeHeader ∷ HandleLike h
 102             ⇒ Context h
 103             → Interaction
 104             → IO ()
 105 writeHeader ctx@(Context {..}) itr@(Interaction {..})
 106     = do res ← atomically $
 107                do state ← readTVar itrState
 108                   if state ≥ SendingBody then
 109                       readTVar itrResponse
 110                   else
 111                       retry -- Too early to write header fields.
 112          hPutBuilder cHandle $ A.toBuilder $ printResponse res
 113          hFlush cHandle
 114          writeBodyIfNeeded ctx itr
 115
 116 writeBodyIfNeeded ∷ HandleLike h
 117                   ⇒ Context h
 118                   → Interaction
 119                   → IO ()
 120 writeBodyIfNeeded ctx itr@(Interaction {..})
 121     = join $
 122       atomically $
 123       do willDiscardBody ← readTVar itrWillDiscardBody
 124          if willDiscardBody then
 125              return $ discardBody ctx itr
 126          else
 127              do willChunkBody ← readTVar itrWillChunkBody
 128                 if willChunkBody then
 129                     return $ writeChunkedBody ctx itr
 130                 else
 131                     return $ writeNonChunkedBody ctx itr
 132
 133 discardBody ∷ HandleLike h
 134             ⇒ Context h
 135             → Interaction
 136             → IO ()
 137 discardBody ctx itr@(Interaction {..})
 138     = join $
 139       atomically $
 140       do chunk ← tryTakeTMVar itrBodyToSend
 141          case chunk of
 142            Just _  → return $ discardBody ctx itr
 143            Nothing → do state ← readTVar itrState
 144                         if state ≡ Done then
 145                             return $ finalize ctx itr
 146                         else
 147                             retry
 148
 149 writeChunkedBody ∷ HandleLike h
 150                  ⇒ Context h
 151                  → Interaction
 152                  → IO ()
 153 writeChunkedBody ctx@(Context {..}) itr@(Interaction {..})
 154     = join $
 155       atomically $
 156       do chunk ← tryTakeTMVar itrBodyToSend
 157          case chunk of
 158            Just b  → return $
 159                      do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
 160                         hFlush cHandle
 161                         writeChunkedBody ctx itr
 162            Nothing → do state ← readTVar itrState
 163                         if state ≡ Done then
 164                             return $ finalize ctx itr
 165                         else
 166                             retry
 167
 168 writeNonChunkedBody ∷ HandleLike h
 169                     ⇒ Context h
 170                     → Interaction
 171                     → IO ()
 172 writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..})
 173     = join $
 174       atomically $
 175       do chunk ← tryTakeTMVar itrBodyToSend
 176          case chunk of
 177            Just b  → return $
 178                      do hPutBuilder cHandle b
 179                         hFlush cHandle
 180                         writeNonChunkedBody ctx itr
 181            Nothing → do state ← readTVar itrState
 182                         if state ≡ Done then
 183                             return $ finalize ctx itr
 184                         else
 185                             retry
 186
 187 finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 188 finalize ctx@(Context {..}) (Interaction {..})
 189     = join $
 190       atomically $
 191       do sentContinue    ← takeTMVar itrSendContinue
 192          willDiscardBody ← readTVar  itrWillDiscardBody
 193          willChunkBody   ← readTVar  itrWillChunkBody
 194          willClose       ← readTVar  itrWillClose
 195          queue           ← readTVar  cQueue
 196          case S.viewr queue of
 197            queue' :> _
 198                → writeTVar cQueue queue'
 199            EmptyR
 200                → fail "finalize: cQueue is empty, which should never happen."
 201          return $
 202              do when (((¬) willDiscardBody) ∧ willChunkBody)
 203                     $ do hPutBuilder cHandle BB.chunkedTransferTerminator
 204                          hFlush cHandle
 205                 if willClose ∨ needToClose sentContinue then
 206                     -- The RequestReader is probably blocking on
 207                     -- hWaitForInput so we have to kill it before
 208                     -- closing the socket.
 209                     -- THINKME: Couldn't that somehow be avoided?
 210                     do killThread cReader
 211                        hClose cHandle
 212                 else
 213                     awaitSomethingToWrite ctx
 214     where
 215       needToClose ∷ Bool → Bool
 216       needToClose sentContinue
 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           | itrExpectedContinue ≡ Just True = 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