)
where
import qualified Blaze.ByteString.Builder.HTTP as BB
+import Control.Applicative
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
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)
, 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)
awaitSomethingToWrite ctx@(Context {..})
= join $
atomically $
- -- キューが空でなくなるまで待つ
do queue ← readTVar cQueue
case S.viewr queue of
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
- if state ≥ SendingBody then
- writeHeaderOrBodyIfNeeded ctx itr phase
- else
- retry
+ 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
- → 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
- → 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@(Interaction {..})
- = do let cont = Response {
- resVersion = HttpVersion 1 1
- , resStatus = Continue
- , resHeaders = (∅)
- }
- cont' ← completeUnconditionalHeaders cConfig cont
- hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
- hFlush cHandle
- awaitSomethingToWriteOn ctx itr WroteContinue
+ → 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 $ A.toBuilder $ printResponse cont
+ hFlush cHandle
+ writeHeader ctx ni
writeHeader ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeHeader ctx@(Context {..}) itr@(Interaction {..})
- = do res ← atomically $ readTVar itrResponse
+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 $ A.toBuilder $ printResponse res
hFlush cHandle
- awaitSomethingToWriteOn ctx itr WroteHeader
-
-writeBodyChunk ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Phase
- → IO ()
-writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
+ writeBodyIfNeeded ctx ni
+
+writeBodyIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → IO ()
+writeBodyIfNeeded ctx ni@(NI {..})
= join $
atomically $
- do willDiscardBody ← readTVar itrWillDiscardBody
+ do willDiscardBody ← readTVar niWillDiscardBody
if willDiscardBody then
- do _ ← tryTakeTMVar itrBodyToSend
- return $ awaitSomethingToWriteOn ctx itr phase
+ return $ discardBody ctx ni
else
- do willChunkBody ← readTVar itrWillChunkBody
- chunk ← takeTMVar itrBodyToSend
- return $
- do if willChunkBody then
- hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
- else
- hPutBuilder cHandle chunk
- hFlush cHandle
- awaitSomethingToWriteOn ctx itr phase
-
-finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finishBodyChunk (Context {..}) (Interaction {..})
+ if niWillChunkBody then
+ return $ writeChunkedBody ctx ni
+ else
+ return $ writeNonChunkedBody ctx ni
+
+discardBody ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → IO ()
+discardBody ctx ni@(NI {..})
= join $
atomically $
- do willDiscardBody ← readTVar itrWillDiscardBody
- willChunkBody ← readTVar itrWillChunkBody
- if ((¬) willDiscardBody) ∧ willChunkBody then
- return $
- do hPutBuilder cHandle BB.chunkedTransferTerminator
- hFlush cHandle
- else
- return $ return ()
-
-finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-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
- readTVar itrWillClose
- if willClose then
- -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
- -- ドを豫め殺して置かないとをかしくなる。
+ 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
+ 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
+ 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
+ -- 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 → 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 $ 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