)
where
import qualified Blaze.ByteString.Builder.HTTP as BB
-import qualified Data.Ascii as A
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 (ViewR(..))
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
+import System.IO.Error
data Context h
= Context {
, cReader ∷ !ThreadId
}
+data Phase = Initial
+ | WroteContinue
+ | WroteHeader
+ deriving (Eq, Ord, Show)
+
responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
responseWriter cnf h tQueue readerTID
= awaitSomethingToWrite (Context cnf h tQueue readerTID)
`catches`
- [ Handler $ \ (_ ∷ IOException) → return ()
- , Handler $ \ e → case e of
- ThreadKilled → return ()
- _ → hPutStrLn stderr (show e)
- , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
- , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
+ [ Handler handleIOE
+ , Handler handleAsyncE
+ , Handler handleBIOS
+ , Handler handleOthers
]
+ where
+ 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 {..})
atomically $
-- キューが空でなくなるまで待つ
do queue ← readTVar cQueue
- -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
- -- だ送信前なのであれば、Continue を送信する。
case S.viewr queue of
- EmptyR → retry
- _ :> itr → do state ← readTVar $ itrState itr
- if state ≡ GettingBody then
- writeContinueIfNeeded ctx itr
- else
- if state ≥ DecidingBody then
- writeHeaderOrBodyIfNeeded ctx itr
- else
- retry
-
-writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeContinueIfNeeded ctx itr@(Interaction {..})
- = do expectedContinue ← readTVar itrExpectedContinue
- if expectedContinue then
- do wroteContinue ← readTVar itrWroteContinue
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
- else
- do reqBodyWanted ← readTVar itrReqBodyWanted
- if reqBodyWanted ≢ Nothing then
- return $ writeContinue ctx itr
- else
- retry
+ EmptyR → retry
+ queue' :> itr → do writeTVar cQueue queue'
+ return $ awaitSomethingToWriteOn ctx itr Initial
+
+-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
+-- なのであれば、Continue を送信する。
+awaitSomethingToWriteOn ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → IO ()
+awaitSomethingToWriteOn ctx itr phase
+ = join $
+ atomically $
+ do state ← readTVar $ itrState itr
+ if state ≡ ReceivingBody then
+ writeContinueIfNeeded ctx itr phase
else
- retry
+ if state ≥ SendingBody then
+ writeHeaderOrBodyIfNeeded ctx itr phase
+ else
+ retry
+
+writeContinueIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → STM (IO ())
+writeContinueIfNeeded ctx itr@(Interaction {..}) phase
+ | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
+ = do isRequested ← isEmptyTMVar itrReceiveBodyReq
+ if isRequested then
+ return $ writeContinue ctx itr
+ else
+ retry
+ | otherwise
+ = retry
-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
-- 出力する。空である時は、もし状態がDone であれば後処理をする。
-writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
- = do wroteHeader ← readTVar itrWroteHeader
- if not wroteHeader then
- return $ writeHeader ctx itr
- else
- do noBodyToWrite ← isEmptyTMVar itrBodyToSend
- if noBodyToWrite then
- do state ← readTVar itrState
- if state ≡ Done then
- return $ finalize ctx itr
- else
- retry
- else
- return $ writeBodyChunk ctx itr
+writeHeaderOrBodyIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → STM (IO ())
+writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
+ | phase < WroteHeader
+ = return $ writeHeader ctx itr
+ | otherwise
+ = do noBodyToWrite ← isEmptyTMVar itrBodyToSend
+ if noBodyToWrite then
+ do state ← readTVar itrState
+ if state ≡ Done then
+ return $ finalize ctx itr
+ else
+ retry
+ else
+ return $ writeBodyChunk ctx itr phase
writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeContinue ctx@(Context {..}) (Interaction {..})
+writeContinue ctx@(Context {..}) itr@(Interaction {..})
= do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
cont' ← completeUnconditionalHeaders cConfig cont
hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
hFlush cHandle
- atomically $ writeTVar itrWroteContinue True
- awaitSomethingToWrite ctx
-
-writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) (Interaction {..})
- = do res ← atomically
- $ do writeTVar itrWroteHeader True
- readTVar itrResponse
+ awaitSomethingToWriteOn ctx itr WroteContinue
+
+writeHeader ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeHeader ctx@(Context {..}) itr@(Interaction {..})
+ = do res ← atomically $ readTVar itrResponse
hPutBuilder cHandle $ A.toBuilder $ printResponse res
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr WroteHeader
-writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeBodyChunk ctx@(Context {..}) (Interaction {..})
+writeBodyChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → IO ()
+writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
= join $
atomically $
do willDiscardBody ← readTVar itrWillDiscardBody
if willDiscardBody then
do _ ← tryTakeTMVar itrBodyToSend
- return $ awaitSomethingToWrite ctx
+ return $ awaitSomethingToWriteOn ctx itr phase
else
do willChunkBody ← readTVar itrWillChunkBody
chunk ← takeTMVar itrBodyToSend
else
hPutBuilder cHandle chunk
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr phase
finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
finishBodyChunk (Context {..}) (Interaction {..})