+{-# LANGUAGE
+ DoAndIfThenElse
+ , RecordWildCards
+ , ScopedTypeVariables
+ , UnicodeSyntax
+ #-}
module Network.HTTP.Lucu.ResponseWriter
- ( responseWriter -- Handle -> InteractionQueue -> IO ()
+ ( responseWriter
)
where
-
-import qualified Data.ByteString.Lazy.Char8 as B
-import Data.ByteString.Lazy.Char8 (ByteString)
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
-import Data.Maybe
+import qualified Blaze.ByteString.Builder.HTTP as BB
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.Ascii as A
+import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import Data.Sequence (Seq, ViewR(..))
-import Network.HTTP.Lucu.Interaction
-import Network.HTTP.Lucu.Response
-import Prelude hiding (catch)
-import System.IO
-
-import Debug.Trace
-
-
-responseWriter :: Handle -> InteractionQueue -> IO ()
-responseWriter h tQueue
- = catch awaitSomethingToWrite $ \ exc
- -> case exc of
- IOException _ -> return ()
- _ -> print exc
+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.Postprocess
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import System.IO (hPutStrLn, stderr)
+import System.IO.Error
+
+data Context h
+ = Context {
+ cConfig ∷ !Config
+ , cHandle ∷ !h
+ , cQueue ∷ !InteractionQueue
+ , cReader ∷ !ThreadId
+ }
+
+responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
+responseWriter cnf h tQueue readerTID
+ = awaitSomethingToWrite (Context cnf h tQueue readerTID)
+ `catches`
+ [ Handler handleIOE
+ , Handler handleAsyncE
+ , Handler handleBIOS
+ , Handler handleOthers
+ ]
where
- awaitSomethingToWrite :: IO ()
- awaitSomethingToWrite
- = do action
- <- atomically $
- do -- キューが空でなくなるまで待つ
- queue <- readTVar tQueue
- when (S.null queue)
- retry
- let _ :> itr = S.viewr queue
-
- -- GettingBody 状態にあり、Continue が期待され
- -- てゐて、それがまだ送信前なのであれば、
- -- Continue を送信する。
- state <- readTVar (itrState itr)
-
- if state == GettingBody then
- writeContinueIfNecessary itr
- else
- if state >= DecidingBody then
- writeHeaderOrBodyIfNecessary itr
- else
- retry
- action
-
- writeContinueIfNecessary :: Interaction -> STM (IO ())
- writeContinueIfNecessary itr
- = do expectedContinue <- readTVar (itrExpectedContinue itr)
- if expectedContinue then
-
- do wroteContinue <- readTVar $ itrWroteContinue itr
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
+ handleIOE ∷ IOException → IO ()
+ handleIOE e
+ | isIllegalOperation e
+ = return () -- EPIPE: should be ignored at all.
+ | otherwise
+ = terminate e
+
+ handleAsyncE ∷ AsyncException → IO ()
+ handleAsyncE ThreadKilled = terminate'
+ handleAsyncE e = terminate e
+
+ handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
+ handleBIOS = terminate
+
+ handleOthers ∷ SomeException → IO ()
+ handleOthers = terminate
+
+ terminate ∷ Exception e ⇒ e → IO ()
+ terminate e
+ = do hPutStrLn stderr "requestWriter caught an exception:"
+ hPutStrLn stderr (show $ toException e)
+ terminate'
+
+ terminate' ∷ IO ()
+ terminate' = hClose h
+
+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 $ writeContinueIfNeeded ctx itr
+
+writeContinueIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
+ = do isNeeded ← atomically $ readTMVar itrSendContinue
+ when isNeeded
+ $ do let cont = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Continue
+ , resHeaders = (∅)
+ }
+ cont' ← completeUnconditionalHeaders cConfig cont
+ hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+ hFlush cHandle
+ writeHeader ctx itr
+
+writeHeader ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeHeader ctx@(Context {..}) itr@(Interaction {..})
+ = do res ← atomically $
+ do state ← readTVar itrState
+ if state ≥ SendingBody then
+ readTVar itrResponse
+ else
+ retry -- Too early to write header fields.
+ hPutBuilder cHandle $ A.toBuilder $ printResponse res
+ hFlush cHandle
+ writeBodyIfNeeded ctx itr
+
+writeBodyIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeBodyIfNeeded ctx itr@(Interaction {..})
+ = join $
+ atomically $
+ do willDiscardBody ← readTVar itrWillDiscardBody
+ if willDiscardBody then
+ return $ discardBody ctx itr
+ else
+ do willChunkBody ← readTVar itrWillChunkBody
+ if willChunkBody then
+ return $ writeChunkedBody ctx itr
+ else
+ return $ writeNonChunkedBody ctx itr
+
+discardBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+discardBody ctx itr@(Interaction {..})
+ = join $
+ atomically $
+ do chunk ← tryTakeTMVar itrBodyToSend
+ case chunk of
+ Just _ → return $ discardBody ctx itr
+ Nothing → do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
else
- return $ writeContinue itr
- else
- retry
-
- writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
- writeHeaderOrBodyIfNecessary itr
- -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
- -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
- -- 空でなければ、それを出力する。空である時は、もし状態が
- -- Done であれば後処理をする。
- = do wroteHeader <- readTVar (itrWroteHeader itr)
-
- if not wroteHeader then
- return $ writeHeader itr
- else
- do bodyToSend <- readTVar (itrBodyToSend itr)
-
- if B.null bodyToSend then
- do state <- readTVar (itrState itr)
-
- if state == Done then
- return $ finalize itr
- else
- retry
+ retry
+
+writeChunkedBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+ = join $
+ atomically $
+ do chunk ← tryTakeTMVar itrBodyToSend
+ case chunk of
+ Just b → return $
+ do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
+ hFlush cHandle
+ writeChunkedBody ctx itr
+ Nothing → do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
else
- return $ writeBodyChunk itr
-
- writeContinue :: Interaction -> IO ()
- writeContinue itr = fail "FIXME: not implemented"
-
- writeHeader :: Interaction -> IO ()
- writeHeader itr
- = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
- readTVar (itrResponse itr)
- hPutResponse h (fromJust res)
- hFlush h
- awaitSomethingToWrite
-
- writeBodyChunk :: Interaction -> IO ()
- writeBodyChunk itr = fail "FIXME: not implemented"
-
- finishBodyChunk :: Interaction -> IO ()
- finishBodyChunk itr = return () -- FIXME: not implemented
-
- finalize :: Interaction -> IO ()
- finalize itr
- = do finishBodyChunk itr
- willClose <- atomically $ do queue <- readTVar tQueue
-
- let (remaining :> _) = S.viewr queue
- writeTVar tQueue remaining
-
- readTVar $ itrWillClose itr
- if willClose then
- hClose h
- else
- awaitSomethingToWrite
+ retry
+
+writeNonChunkedBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+ = join $
+ atomically $
+ do chunk ← tryTakeTMVar itrBodyToSend
+ case chunk of
+ Just b → return $
+ do hPutBuilder cHandle b
+ hFlush cHandle
+ writeNonChunkedBody ctx itr
+ Nothing → do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+
+finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+finalize ctx@(Context {..}) (Interaction {..})
+ = 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."
+ 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
+ where
+ needToClose ∷ Bool → Bool
+ needToClose sentContinue
+ -- 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.
+ | itrExpectedContinue ≡ Just True = True
+ -- The client didn't expect 100-continue so we haven't sent
+ -- one. No need to do anything special.
+ | otherwise = False
projects / Lucu.git / blobdiff