{-# LANGUAGE DoAndIfThenElse , RecordWildCards , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.ResponseWriter ( responseWriter ) where import qualified Blaze.ByteString.Builder.HTTP as BB import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad import Data.Ascii (AsciiBuilder) import Data.Convertible.Utils import GHC.IO.Exception (IOException(..), IOErrorType(..)) import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence (ViewR(..)) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) data Context h = Context { cConfig ∷ !Config , cHandle ∷ !h , cQueue ∷ !InteractionQueue } responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () responseWriter cnf h tQueue readerTID = awaitSomethingToWrite (Context cnf h tQueue) `catches` [ Handler handleIOE , Handler handleAsyncE , Handler handleOthers ] `finally` do killThread readerTID hClose h where handleIOE ∷ IOException → IO () handleIOE e@(IOError {..}) | ioe_type ≡ ResourceVanished = return () | otherwise = dump e handleAsyncE ∷ AsyncException → IO () handleAsyncE ThreadKilled = return () handleAsyncE e = dump e handleOthers ∷ SomeException → IO () handleOthers = dump dump ∷ Exception e ⇒ e → IO () dump e = do hPutStrLn stderr "Lucu: responseWriter caught an exception:" hPutStrLn stderr $ show e awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO () awaitSomethingToWrite ctx@(Context {..}) = join $ atomically $ do queue ← readTVar cQueue case S.viewr queue of EmptyR → retry queue' :> itr → do writeTVar cQueue queue' return $ writeSomething ctx itr writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO () writeSomething ctx itr = let writer = writeResponseForNI ctx <$> fromInteraction itr <|> writeResponseForSEI ctx <$> fromInteraction itr <|> writeResponseForSYI ctx <$> fromInteraction itr <|> endOfResponses <$> fromInteraction itr in case writer of Just f → f Nothing → fail "Internal error: unknown interaction type" writeResponseForNI ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () writeResponseForNI = writeContinueIfNeeded writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) = do isNeeded ← atomically $ readTMVar niSendContinue when isNeeded $ do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = fromStatusCode Continue , resHeaders = (∅) } hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont hFlush cHandle writeHeader ctx ni writeHeader ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () writeHeader ctx@(Context {..}) ni@(NI {..}) = do res ← atomically $ do state ← readTVar niState if state ≥ SendingBody then readTVar niResponse else retry -- Too early to write header fields. hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res hFlush cHandle writeBodyIfNeeded ctx ni writeBodyIfNeeded ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () writeBodyIfNeeded ctx ni@(NI {..}) = join $ atomically $ do canHaveBody ← resCanHaveBody <$> readTVar niResponse if canHaveBody ∧ reqMethod niRequest ≢ HEAD then if niWillChunkBody then return $ writeChunkedBody ctx ni else return $ writeNonChunkedBody ctx ni else return $ discardBody ctx ni discardBody ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () discardBody ctx ni@(NI {..}) = join $ atomically $ do chunk ← tryTakeTMVar niBodyToSend case chunk of Just _ → return $ discardBody ctx ni Nothing → do state ← readTVar niState if state ≡ Done then return $ finalize ctx ni else retry writeChunkedBody ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () writeChunkedBody ctx@(Context {..}) ni@(NI {..}) = join $ atomically $ do chunk ← tryTakeTMVar niBodyToSend case chunk of Just b → return $ do hPutBuilder cHandle $ BB.chunkedTransferEncoding b hFlush cHandle writeChunkedBody ctx ni Nothing → do state ← readTVar niState if state ≡ Done then return $ do hPutBuilder cHandle BB.chunkedTransferTerminator hFlush cHandle finalize ctx ni else retry writeNonChunkedBody ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () writeNonChunkedBody ctx@(Context {..}) ni@(NI {..}) = join $ atomically $ do chunk ← tryTakeTMVar niBodyToSend case chunk of Just b → return $ do hPutBuilder cHandle b hFlush cHandle writeNonChunkedBody ctx ni Nothing → do state ← readTVar niState if state ≡ Done then return $ finalize ctx ni else retry finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () finalize ctx@(Context {..}) (NI {..}) = join $ atomically $ do willClose ← readTVar niWillClose sentContinue ← takeTMVar niSendContinue return $ if needToClose willClose sentContinue then return () else awaitSomethingToWrite ctx where needToClose ∷ Bool → Bool → Bool needToClose willClose sentContinue -- Explicitly instructed to close the connection. | willClose = True -- We've sent both "HTTP/1.1 100 Continue" and a final -- response, so nothing prevents our connection from keeping -- alive. | sentContinue = False -- We've got "Expect: 100-continue" but have sent a final -- response without sending "HTTP/1.1 100 -- Continue". According to the RFC 2616 (HTTP/1.1), it is -- undecidable whether the client will send us its -- (rejected) request body OR start a completely new request -- in this situation. So the only possible thing to do is to -- brutally shutdown the connection. | niExpectedContinue = True -- The client didn't expect 100-continue so we haven't sent -- one. No need to do anything special. | otherwise = False writeResponseForSEI ∷ HandleLike h ⇒ Context h → SemanticallyInvalidInteraction → IO () writeResponseForSEI ctx@(Context {..}) (SEI {..}) = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse when (reqMethod seiRequest ≢ HEAD) $ if seiWillChunkBody then do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend hPutBuilder cHandle BB.chunkedTransferTerminator else hPutBuilder cHandle seiBodyToSend hFlush cHandle if seiWillClose ∨ seiExpectedContinue then return () else awaitSomethingToWrite ctx writeResponseForSYI ∷ HandleLike h ⇒ Context h → SyntacticallyInvalidInteraction → IO () writeResponseForSYI (Context {..}) (SYI {..}) = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse hPutBuilder cHandle syiBodyToSend hFlush cHandle return () endOfResponses ∷ EndOfInteraction → IO () endOfResponses _ = return ()