)
where
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 Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
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.Postprocess
-import Network.HTTP.Lucu.Response
-import Prelude hiding (catch)
+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 {
, 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 ← readItr 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
- = do expectedContinue ← readItr itrExpectedContinue itr
- if expectedContinue then
- do wroteContinue ← readItr itrWroteContinue itr
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
- else
- do reqBodyWanted ← readItr itrReqBodyWanted itr
- 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 ≡ GettingBody then
+ writeContinueIfNeeded ctx itr phase
else
- retry
+ if state ≥ DecidingBody 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 itrGetBodyRequest
+ 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
- = do wroteHeader ← readItr itrWroteHeader itr
- if not wroteHeader then
- return $ writeHeader ctx itr
- else
- do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr)
- if noBodyToWrite then
- do state ← readItr itrState itr
- 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 {..}) itr
+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 $ writeItr itrWroteContinue True itr
- awaitSomethingToWrite ctx
-
-writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) itr
- = do res ← atomically
- $ do writeItr itrWroteHeader True itr
- readItr itrResponse itr
+ 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 {..}) itr
+writeBodyChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → IO ()
+writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
= join $
atomically $
- do willDiscardBody ← readItr itrWillDiscardBody itr
+ do willDiscardBody ← readTVar itrWillDiscardBody
if willDiscardBody then
- do _ ← tryTakeTMVar (itrBodyToSend itr)
- return $ awaitSomethingToWrite ctx
+ do _ ← tryTakeTMVar itrBodyToSend
+ return $ awaitSomethingToWriteOn ctx itr phase
else
- do willChunkBody ← readItr itrWillChunkBody itr
- chunk ← takeTMVar (itrBodyToSend itr)
+ do willChunkBody ← readTVar itrWillChunkBody
+ chunk ← takeTMVar itrBodyToSend
return $
do if willChunkBody then
hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
else
hPutBuilder cHandle chunk
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr phase
finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finishBodyChunk (Context {..}) itr
+finishBodyChunk (Context {..}) (Interaction {..})
= join $
atomically $
- do willDiscardBody ← readItr itrWillDiscardBody itr
- willChunkBody ← readItr itrWillChunkBody itr
+ do willDiscardBody ← readTVar itrWillDiscardBody
+ willChunkBody ← readTVar itrWillChunkBody
if ((¬) willDiscardBody) ∧ willChunkBody then
return $
do hPutBuilder cHandle BB.chunkedTransferTerminator
return $ return ()
finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) itr
+finalize ctx@(Context {..}) itr@(Interaction {..})
= do finishBodyChunk ctx itr
willClose ← atomically $
do queue ← readTVar cQueue
case S.viewr queue of
EmptyR → return () -- this should never happen
remaining :> _ → writeTVar cQueue remaining
- readItr itrWillClose itr
+ readTVar itrWillClose
if willClose then
-- reader は恐らく hWaitForInput してゐる最中なので、スレッ
-- ドを豫め殺して置かないとをかしくなる。