+{-# LANGUAGE
+ DoAndIfThenElse
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.ResponseWriter
( responseWriter
)
where
-
-import qualified Data.ByteString.Lazy.Char8 as C8
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
+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.Format
-import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.HttpVersion
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Postprocess
-import Network.HTTP.Lucu.Response
-import Prelude hiding (catch)
-import System.IO
-
-
-responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
+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
- = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
- catch awaitSomethingToWrite $ \ exc ->
- case exc of
- IOException _ -> return ()
- AsyncException ThreadKilled -> return ()
- BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
- _ -> print exc
+ = awaitSomethingToWrite (Context cnf h tQueue)
+ `catches`
+ [ Handler handleIOE
+ , Handler handleAsyncE
+ , Handler handleOthers
+ ]
+ `finally`
+ do killThread readerTID
+ hClose h
where
- awaitSomethingToWrite :: IO ()
- awaitSomethingToWrite
- = {-# SCC "awaitSomethingToWrite" #-}
- do action
- <- atomically $!
- -- キューが空でなくなるまで待つ
- do queue <- readTVar tQueue
- -- GettingBody 状態にあり、Continue が期待され
- -- てゐて、それがまだ送信前なのであれば、
- -- Continue を送信する。
- case S.viewr queue of
- EmptyR -> retry
- _ :> itr -> do state <- readItr itr itrState id
-
- if state == GettingBody then
- writeContinueIfNecessary itr
- else
- if state >= DecidingBody then
- writeHeaderOrBodyIfNecessary itr
- else
- retry
- action
-
- writeContinueIfNecessary :: Interaction -> STM (IO ())
- writeContinueIfNecessary itr
- = {-# SCC "writeContinueIfNecessary" #-}
- itr `seq`
- do expectedContinue <- readItr itr itrExpectedContinue id
- if expectedContinue then
- do wroteContinue <- readItr itr itrWroteContinue id
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
+ 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
- do reqBodyWanted <- readItr itr itrReqBodyWanted id
- if reqBodyWanted /= Nothing then
- return $ writeContinue itr
- else
- retry
- else
- retry
-
- writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
- writeHeaderOrBodyIfNecessary itr
- -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
- -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
- -- 空でなければ、それを出力する。空である時は、もし状態が
- -- Done であれば後処理をする。
- = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
- itr `seq`
- do wroteHeader <- readItr itr itrWroteHeader id
-
- if not wroteHeader then
- return $! writeHeader itr
- else
- do bodyToSend <- readItr itr itrBodyToSend id
-
- if C8.null bodyToSend then
- do state <- readItr itr itrState id
-
- if state == Done then
- return $! finalize itr
- else
- retry
+ 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
- return $! writeBodyChunk itr
-
- writeContinue :: Interaction -> IO ()
- writeContinue itr
- = {-# SCC "writeContinue" #-}
- itr `seq`
- do let cont = Response {
- resVersion = HttpVersion 1 1
- , resStatus = Continue
- , resHeaders = emptyHeaders
- }
- cont' <- completeUnconditionalHeaders cnf cont
- hPutResponse h cont'
- hFlush h
- atomically $! writeItr itr itrWroteContinue True
- awaitSomethingToWrite
-
- writeHeader :: Interaction -> IO ()
- writeHeader itr
- = {-# SCC "writeHeader" #-}
- itr `seq`
- do res <- atomically $! do writeItr itr itrWroteHeader True
- readItr itr itrResponse id
- hPutResponse h res
- hFlush h
- awaitSomethingToWrite
-
- writeBodyChunk :: Interaction -> IO ()
- writeBodyChunk itr
- = {-# SCC "writeBodyChunk" #-}
- itr `seq`
- do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
- willChunkBody <- atomically $! readItr itr itrWillChunkBody id
- chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
- writeItr itr itrBodyToSend C8.empty
- return chunk
- unless willDiscardBody
- $ do if willChunkBody then
- do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
- C8.hPut h (C8.pack "\r\n")
- C8.hPut h chunk
- C8.hPut h (C8.pack "\r\n")
- else
- C8.hPut h chunk
- hFlush h
- awaitSomethingToWrite
-
- finishBodyChunk :: Interaction -> IO ()
- finishBodyChunk itr
- = {-# SCC "finishBodyChunk" #-}
- itr `seq`
- do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
- willChunkBody <- atomically $! readItr itr itrWillChunkBody id
- when (not willDiscardBody && willChunkBody)
- $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
-
- finalize :: Interaction -> IO ()
- finalize itr
- = {-# SCC "finalize" #-}
- itr `seq`
- do finishBodyChunk itr
- willClose <- atomically $!
- do queue <- readTVar tQueue
-
- case S.viewr queue of
- EmptyR -> return () -- this should never happen
- remaining :> _ -> writeTVar tQueue remaining
-
- readItr itr itrWillClose id
- if willClose then
- -- reader は恐らく hWaitForInput してゐる最中なので、
- -- スレッドを豫め殺して置かないとをかしくなる。
- do killThread readerTID
- hClose h
- else
- awaitSomethingToWrite
+ 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 ()
projects / Lucu.git / blobdiff