)
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)
case S.viewr queue of
EmptyR → retry
queue' :> itr → do writeTVar cQueue queue'
- return $ writeContinueIfNeeded ctx itr
+ 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
+ → NormalInteraction
→ IO ()
-writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..})
- = do isNeeded ← atomically $ readTMVar itrSendContinue
+writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
+ = do isNeeded ← atomically $ readTMVar niSendContinue
when isNeeded
$ do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
, resHeaders = (∅)
}
- cont' ← completeUnconditionalHeaders cConfig cont
- hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+ hPutBuilder cHandle $ A.toBuilder $ printResponse cont
hFlush cHandle
- writeHeader ctx itr
+ writeHeader ctx ni
writeHeader ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeHeader ctx@(Context {..}) itr@(Interaction {..})
+writeHeader ctx@(Context {..}) ni@(NI {..})
= do res ← atomically $
- do state ← readTVar itrState
+ do state ← readTVar niState
if state ≥ SendingBody then
- readTVar itrResponse
+ readTVar niResponse
else
retry -- Too early to write header fields.
hPutBuilder cHandle $ A.toBuilder $ printResponse res
hFlush cHandle
- writeBodyIfNeeded ctx itr
+ writeBodyIfNeeded ctx ni
writeBodyIfNeeded ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeBodyIfNeeded ctx itr@(Interaction {..})
+writeBodyIfNeeded ctx ni@(NI {..})
= join $
atomically $
- do willDiscardBody ← readTVar itrWillDiscardBody
+ do willDiscardBody ← readTVar niWillDiscardBody
if willDiscardBody then
- return $ discardBody ctx itr
+ return $ discardBody ctx ni
else
- do willChunkBody ← readTVar itrWillChunkBody
- if willChunkBody then
- return $ writeChunkedBody ctx itr
- else
- return $ writeNonChunkedBody ctx itr
+ if niWillChunkBody then
+ return $ writeChunkedBody ctx ni
+ else
+ return $ writeNonChunkedBody ctx ni
discardBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-discardBody ctx itr@(Interaction {..})
+discardBody ctx ni@(NI {..})
= join $
atomically $
- do chunk ← tryTakeTMVar itrBodyToSend
+ do chunk ← tryTakeTMVar niBodyToSend
case chunk of
- Just _ → return $ discardBody ctx itr
- Nothing → do state ← readTVar itrState
+ Just _ → return $ discardBody ctx ni
+ Nothing → do state ← readTVar niState
if state ≡ Done then
- return $ finalize ctx itr
+ return $ finalize ctx ni
else
retry
writeChunkedBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+writeChunkedBody ctx@(Context {..}) ni@(NI {..})
= join $
atomically $
- do chunk ← tryTakeTMVar itrBodyToSend
+ do chunk ← tryTakeTMVar niBodyToSend
case chunk of
Just b → return $
do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
hFlush cHandle
- writeChunkedBody ctx itr
- Nothing → do state ← readTVar itrState
+ writeChunkedBody ctx ni
+ Nothing → do state ← readTVar niState
if state ≡ Done then
- return $ finalize ctx itr
+ return $
+ do hPutBuilder cHandle BB.chunkedTransferTerminator
+ hFlush cHandle
+ finalize ctx ni
else
retry
writeNonChunkedBody ∷ HandleLike h
⇒ Context h
- → Interaction
+ → NormalInteraction
→ IO ()
-writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..})
+writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
= join $
atomically $
- do chunk ← tryTakeTMVar itrBodyToSend
+ do chunk ← tryTakeTMVar niBodyToSend
case chunk of
Just b → return $
do hPutBuilder cHandle b
hFlush cHandle
- writeNonChunkedBody ctx itr
- Nothing → do state ← readTVar itrState
+ writeNonChunkedBody ctx ni
+ Nothing → do state ← readTVar niState
if state ≡ Done then
- return $ finalize ctx itr
+ return $ finalize ctx ni
else
retry
-finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) (Interaction {..})
+finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
+finalize ctx@(Context {..}) (NI {..})
= 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."
+ do willClose ← readTVar niWillClose
+ sentContinue ← takeTMVar niSendContinue
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
+ 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
- needToClose sentContinue
+ 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.
-- (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
+ | 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
projects / Lucu.git / blobdiff