X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=d89ee9e885aa114429489cdef1fb7c59466fb65b;hp=02e3938644b2122269d9c98e708c58352b68535d;hb=f402841101b4b84f263eea1a43c848f81c48ff93;hpb=0aa4f6d758fc12fba468f7cd399bbcc48f693d1e diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 02e3938..d89ee9e 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,6 +9,7 @@ module Network.HTTP.Lucu.ResponseWriter ) where import qualified Blaze.ByteString.Builder.HTTP as BB +import Control.Applicative import Control.Concurrent import Control.Concurrent.STM import Control.Exception @@ -21,7 +22,6 @@ import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -79,141 +79,149 @@ awaitSomethingToWrite ctx@(Context {..}) case S.viewr queue of EmptyR → retry queue' :> itr → do writeTVar cQueue queue' - return $ writeContinueIfNeeded ctx itr + 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 + 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 - → Interaction + → NormalInteraction → IO () -writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..}) - = do isNeeded ← atomically $ readTMVar itrSendContinue +writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) + = do isNeeded ← atomically $ readTMVar niSendContinue when isNeeded $ do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue , resHeaders = (∅) } - cont' ← completeUnconditionalHeaders cConfig cont - hPutBuilder cHandle $ A.toBuilder $ printResponse cont' + hPutBuilder cHandle $ A.toBuilder $ printResponse cont hFlush cHandle - writeHeader ctx itr + writeHeader ctx ni writeHeader ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeHeader ctx@(Context {..}) itr@(Interaction {..}) +writeHeader ctx@(Context {..}) ni@(NI {..}) = do res ← atomically $ - do state ← readTVar itrState + do state ← readTVar niState if state ≥ SendingBody then - readTVar itrResponse + readTVar niResponse else retry -- Too early to write header fields. hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle - writeBodyIfNeeded ctx itr + writeBodyIfNeeded ctx ni writeBodyIfNeeded ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeBodyIfNeeded ctx itr@(Interaction {..}) +writeBodyIfNeeded ctx ni@(NI {..}) = join $ atomically $ - do willDiscardBody ← readTVar itrWillDiscardBody + do willDiscardBody ← readTVar niWillDiscardBody if willDiscardBody then - return $ discardBody ctx itr + return $ discardBody ctx ni else - do willChunkBody ← readTVar itrWillChunkBody - if willChunkBody then - return $ writeChunkedBody ctx itr - else - return $ writeNonChunkedBody ctx itr + if niWillChunkBody then + return $ writeChunkedBody ctx ni + else + return $ writeNonChunkedBody ctx ni discardBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -discardBody ctx itr@(Interaction {..}) +discardBody ctx ni@(NI {..}) = join $ atomically $ - do chunk ← tryTakeTMVar itrBodyToSend + do chunk ← tryTakeTMVar niBodyToSend case chunk of - Just _ → return $ discardBody ctx itr - Nothing → do state ← readTVar itrState + Just _ → return $ discardBody ctx ni + Nothing → do state ← readTVar niState if state ≡ Done then - return $ finalize ctx itr + return $ finalize ctx ni else retry writeChunkedBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeChunkedBody ctx@(Context {..}) itr@(Interaction {..}) +writeChunkedBody ctx@(Context {..}) ni@(NI {..}) = join $ atomically $ - do chunk ← tryTakeTMVar itrBodyToSend + do chunk ← tryTakeTMVar niBodyToSend case chunk of Just b → return $ do hPutBuilder cHandle $ BB.chunkedTransferEncoding b hFlush cHandle - writeChunkedBody ctx itr - Nothing → do state ← readTVar itrState + writeChunkedBody ctx ni + Nothing → do state ← readTVar niState if state ≡ Done then - return $ finalize ctx itr + return $ + do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + finalize ctx ni else retry writeNonChunkedBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → IO () -writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..}) +writeNonChunkedBody ctx@(Context {..}) ni@(NI {..}) = join $ atomically $ - do chunk ← tryTakeTMVar itrBodyToSend + do chunk ← tryTakeTMVar niBodyToSend case chunk of Just b → return $ do hPutBuilder cHandle b hFlush cHandle - writeNonChunkedBody ctx itr - Nothing → do state ← readTVar itrState + writeNonChunkedBody ctx ni + Nothing → do state ← readTVar niState if state ≡ Done then - return $ finalize ctx itr + return $ finalize ctx ni else retry -finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -finalize ctx@(Context {..}) (Interaction {..}) +finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () +finalize ctx@(Context {..}) (NI {..}) = join $ atomically $ - do sentContinue ← takeTMVar itrSendContinue - willDiscardBody ← readTVar itrWillDiscardBody - willChunkBody ← readTVar itrWillChunkBody - willClose ← readTVar itrWillClose - queue ← readTVar cQueue - case S.viewr queue of - queue' :> _ - → writeTVar cQueue queue' - EmptyR - → fail "finalize: cQueue is empty, which should never happen." + do willClose ← readTVar niWillClose + sentContinue ← takeTMVar niSendContinue return $ - do when (((¬) willDiscardBody) ∧ willChunkBody) - $ do hPutBuilder cHandle BB.chunkedTransferTerminator - hFlush cHandle - if willClose ∨ needToClose sentContinue then - -- The RequestReader is probably blocking on - -- hWaitForInput so we have to kill it before - -- closing the socket. - -- THINKME: Couldn't that somehow be avoided? - do killThread cReader - hClose cHandle - else - awaitSomethingToWrite ctx + if needToClose willClose sentContinue then + -- The RequestReader is probably blocking on + -- hWaitForInput so we have to kill it before closing + -- the socket. THINKME: Couldn't that somehow be + -- avoided? + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx where - needToClose ∷ Bool → Bool - needToClose sentContinue + 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. @@ -225,7 +233,37 @@ finalize ctx@(Context {..}) (Interaction {..}) -- (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. - | itrExpectedContinue ≡ Just True = True + | 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 $ A.toBuilder $ printResponse seiResponse + unless seiWillDiscardBody $ + if seiWillChunkBody then + do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend + hPutBuilder cHandle BB.chunkedTransferTerminator + else + hPutBuilder cHandle seiBodyToSend + hFlush cHandle + if seiWillClose ∨ seiExpectedContinue then + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx + +writeResponseForSYI ∷ HandleLike h + ⇒ Context h + → SyntacticallyInvalidInteraction + → IO () +writeResponseForSYI (Context {..}) (SYI {..}) + = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse + hPutBuilder cHandle syiBodyToSend + hFlush cHandle + killThread cReader + hClose cHandle