where
import Control.Applicative
import Control.Concurrent.STM
-import Control.Exception
+import Control.Exception hiding (block)
import Control.Monad
import qualified Data.Attoparsec.Lazy as LP
+import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.Maybe
+import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import Data.Sequence.Unicode
-import Data.Text (Text)
+import Data.Sequence.Unicode hiding ((∅))
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
import Network.HTTP.Lucu.HandleLike
, cQueue ∷ !InteractionQueue
}
+data ChunkReceivingState
+ = Initial
+ | InChunk !Int -- ^Number of remaining octets in the current
+ -- chunk. It's always positive.
+
requestReader ∷ HandleLike h
⇒ Config
→ ResTree
⇒ Context h
→ Interaction
→ Lazy.ByteString
- → [Text]
+ → [Strict.ByteString]
→ ResourceDef
→ IO ()
acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
atomically $ enqueue ctx itr
do _ ← spawnResource rsrcDef itr
if reqMustHaveBody $ fromJust $ itrRequest itr then
- observeRequest ctx itr input
+ waitForReceiveBodyReq ctx itr input
else
acceptRequest ctx input
-observeRequest ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → IO ()
-observeRequest ctx itr input
- = case fromJust $ itrReqBodyLength itr of
- Chunked
- → observeChunkedRequest ctx itr input 0
- Fixed len
- → observeNonChunkedRequest ctx itr input len
-
-observeChunkedRequest ∷ HandleLike h
+waitForReceiveBodyReq ∷ HandleLike h
⇒ Context h
→ Interaction
→ Lazy.ByteString
- → Int
→ IO ()
-observeChunkedRequest ctx itr input remaining
+waitForReceiveBodyReq ctx itr input
+ = case fromJust $ itrReqBodyLength itr of
+ Chunked
+ → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
+ Fixed len
+ → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len
+
+-- Toooooo long name for a function...
+waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → IO ()
+waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
= join $
atomically $
- do isOver ← readTVar $ itrReqChunkIsOver itr
- if isOver then
- return $ acceptRequest ctx input
- else
- do wanted ← readTVar $ itrReqBodyWanted itr
- case wanted of
- 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
- if wasteAll then
- return $ wasteCurrentChunk ctx itr input remaining
- else
- retry
- _ → return $ readCurrentChunk ctx itr input wanted remaining
+ do req ← takeTMVar itrReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
+ return $ readCurrentChunk ctx itr input Initial wanted
+ WasteAll
+ → do putTMVar itrSendContinue False
+ return $ wasteAllChunks ctx itr input Initial
-wasteCurrentChunk ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → Int
- → IO ()
-wasteCurrentChunk ctx itr input len
- | len > 0
- = let input' = Lazy.drop (fromIntegral len) input
- in
- case LP.parse chunkFooterP input' of
- LP.Done input'' _
- → observeChunkedRequest ctx itr input'' 0
+waitForReceiveChunkedBodyReq ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → ChunkReceivingState
+ → IO ()
+waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
+ = do req ← atomically $ takeTMVar itrReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → readCurrentChunk ctx itr input st wanted
+ WasteAll
+ → wasteAllChunks ctx itr input st
+
+wasteAllChunks ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → ChunkReceivingState
+ → IO ()
+wasteAllChunks ctx itr = go
+ where
+ go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
+ go input Initial
+ = case LP.parse chunkHeaderP input of
+ LP.Done input' chunkLen
+ | chunkLen ≡ 0 → gotFinalChunk input'
+ | otherwise → gotChunk input' chunkLen
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+ go input (InChunk chunkLen)
+ = gotChunk input chunkLen
+
+ gotChunk ∷ Lazy.ByteString → Int → IO ()
+ gotChunk input chunkLen
+ = let input' = Lazy.drop (fromIntegral chunkLen) input
+ in
+ case LP.parse chunkFooterP input' of
+ LP.Done input'' _
+ → go input'' Initial
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+
+ gotFinalChunk ∷ Lazy.ByteString → IO ()
+ gotFinalChunk input
+ = case LP.parse chunkFooterP input of
+ LP.Done input' _
+ → case LP.parse chunkTrailerP input' of
+ LP.Done input'' _
+ → acceptRequest ctx input''
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
LP.Fail _ _ _
→ chunkWasMalformed itr
- | otherwise
- = seekNextChunk ctx itr input
readCurrentChunk ∷ HandleLike h
⇒ Context h
→ Interaction
→ Lazy.ByteString
- → Int
+ → ChunkReceivingState
→ Int
→ IO ()
-readCurrentChunk ctx itr input wanted remaining
- | remaining > 0
- = do let bytesToRead = fromIntegral $ min wanted remaining
- (chunk, input') = Lazy.splitAt bytesToRead input
- actualReadBytes = fromIntegral $ Lazy.length chunk
- newWanted = wanted - actualReadBytes
- newRemaining = remaining - actualReadBytes
- chunk' = S.fromList $ Lazy.toChunks chunk
- updateStates = atomically $
- do writeTVar (itrReqBodyWanted itr) newWanted
- oldBody ← readTVar $ itrReceivedBody itr
- oldBodyLen ← readTVar $ itrReceivedBodyLen itr
- writeTVar (itrReceivedBody itr) $ oldBody ⋈ chunk'
- writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
- if newRemaining ≡ 0 then
- case LP.parse chunkFooterP input' of
- LP.Done input'' _
- → do updateStates
- observeChunkedRequest ctx itr input'' 0
- LP.Fail _ _ _
- → chunkWasMalformed itr
- else
- do updateStates
- observeChunkedRequest ctx itr input' newRemaining
- | otherwise
- = seekNextChunk ctx itr input
+readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
+ = go input0 st0
+ where
+ go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
+ go input Initial
+ = case LP.parse chunkHeaderP input of
+ LP.Done input' chunkLen
+ | chunkLen ≡ 0
+ → gotFinalChunk input'
+ | otherwise
+ → gotChunk input' chunkLen
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+ go input (InChunk chunkLen)
+ = gotChunk input chunkLen
-seekNextChunk ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → IO ()
-seekNextChunk ctx itr input
- = case LP.parse chunkHeaderP input of
- LP.Done input' len
- | len ≡ 0 -- Final chunk
- → case LP.parse chunkTrailerP input' of
+ gotChunk ∷ Lazy.ByteString → Int → IO ()
+ gotChunk input chunkLen
+ = do let bytesToRead = min wanted chunkLen
+ (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
+ block' = Strict.concat $ Lazy.toChunks block
+ actualReadBytes = Strict.length block'
+ chunkLen' = chunkLen - actualReadBytes
+ atomically $ putTMVar itrReceivedBody block'
+ if chunkLen' ≡ 0 then
+ case LP.parse chunkFooterP input' of
LP.Done input'' _
- → do atomically $
- writeTVar (itrReqChunkIsOver itr) True
- acceptRequest ctx input''
+ → waitForReceiveChunkedBodyReq ctx itr input'' Initial
LP.Fail _ _ _
→ chunkWasMalformed itr
- | otherwise -- Non-final chunk
- → observeChunkedRequest ctx itr input' len
- LP.Fail _ _ _
- → chunkWasMalformed itr
+ else
+ waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'
+
+ gotFinalChunk ∷ Lazy.ByteString → IO ()
+ gotFinalChunk input
+ = do atomically $ putTMVar itrReceivedBody (∅)
+ case LP.parse chunkFooterP input of
+ LP.Done input' _
+ → case LP.parse chunkTrailerP input' of
+ LP.Done input'' _
+ → acceptRequest ctx input''
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
+ LP.Fail _ _ _
+ → chunkWasMalformed itr
chunkWasMalformed ∷ Interaction → IO ()
chunkWasMalformed itr
+ -- FIXME: This is a totally wrong way to abort!
= atomically $
do setResponseStatus itr BadRequest
writeTVar (itrWillClose itr) True
writeTVar (itrState itr) Done
postprocess itr
-observeNonChunkedRequest ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Lazy.ByteString
- → Int
- → IO ()
-observeNonChunkedRequest ctx itr input remaining
+waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
= join $
atomically $
- do wanted ← readTVar $ itrReqBodyWanted itr
- case wanted of
- 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
- if wasteAll then
- return $ wasteNonChunkedRequestBody ctx itr input remaining
- else
- retry
- _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
+ do req ← takeTMVar itrReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
+ return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
+ WasteAll
+ → do putTMVar itrSendContinue False
+ return $ wasteNonChunkedRequestBody ctx input bodyLen
+
+waitForReceiveNonChunkedBodyReq ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
+ = do req ← atomically $ takeTMVar itrReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → readNonChunkedRequestBody ctx itr input bodyLen wanted
+ WasteAll
+ → wasteNonChunkedRequestBody ctx input bodyLen
wasteNonChunkedRequestBody ∷ HandleLike h
⇒ Context h
- → Interaction
→ Lazy.ByteString
→ Int
→ IO ()
-wasteNonChunkedRequestBody ctx itr input remaining
- = do let input' = Lazy.drop (fromIntegral remaining) input
- atomically $ writeTVar (itrReqChunkIsOver itr) True
+wasteNonChunkedRequestBody ctx input bodyLen
+ = do let input' = Lazy.drop (fromIntegral bodyLen) input
acceptRequest ctx input'
readNonChunkedRequestBody ∷ HandleLike h
→ Int
→ Int
→ IO ()
-readNonChunkedRequestBody ctx itr input wanted remaining
- = do let bytesToRead = min wanted remaining
- (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
- actualReadBytes = fromIntegral $ Lazy.length chunk
- newWanted = wanted - actualReadBytes
- newRemaining = remaining - actualReadBytes
- isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
- chunk' = S.fromList $ Lazy.toChunks chunk
- atomically $
- do writeTVar (itrReqChunkIsOver itr) isOver
- writeTVar (itrReqBodyWanted itr) newWanted
- writeTVar (itrReceivedBody itr) chunk'
- writeTVar (itrReceivedBodyLen itr) actualReadBytes
- if isOver then
- acceptRequest ctx input'
- else
- observeNonChunkedRequest ctx itr input' newRemaining
+readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted
+ | bodyLen ≡ 0 = gotEndOfRequest
+ | otherwise = gotBody
+ where
+ gotBody ∷ IO ()
+ gotBody
+ = do let bytesToRead = min wanted bodyLen
+ (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
+ block' = Strict.concat $ Lazy.toChunks block
+ actualReadBytes = Strict.length block'
+ bodyLen' = bodyLen - actualReadBytes
+ atomically $ putTMVar itrReceivedBody block'
+ waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'
+
+ gotEndOfRequest ∷ IO ()
+ gotEndOfRequest
+ = do atomically $ putTMVar itrReceivedBody (∅)
+ acceptRequest ctx input
enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
enqueue (Context {..}) itr
, 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 $ writeContinueIfNeeded ctx itr
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
+ → 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 $ readTVar itrResponse
+ = 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
- awaitSomethingToWriteOn ctx itr WroteHeader
+ writeBodyIfNeeded ctx itr
-writeBodyChunk ∷ HandleLike h
- ⇒ Context h
- → Interaction
- → Phase
- → IO ()
-writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
+writeBodyIfNeeded ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+writeBodyIfNeeded ctx itr@(Interaction {..})
= join $
atomically $
do willDiscardBody ← readTVar itrWillDiscardBody
if willDiscardBody then
- do _ ← tryTakeTMVar itrBodyToSend
- return $ awaitSomethingToWriteOn ctx itr phase
+ return $ discardBody ctx itr
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
+ if willChunkBody then
+ return $ writeChunkedBody ctx itr
+ else
+ return $ writeNonChunkedBody ctx itr
-finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finishBodyChunk (Context {..}) (Interaction {..})
+discardBody ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → IO ()
+discardBody ctx itr@(Interaction {..})
= join $
atomically $
- do willDiscardBody ← readTVar itrWillDiscardBody
- willChunkBody ← readTVar itrWillChunkBody
- if ((¬) willDiscardBody) ∧ willChunkBody then
- return $
- do hPutBuilder cHandle BB.chunkedTransferTerminator
- hFlush cHandle
- else
- return $ return ()
+ 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
+ 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
+ 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 {..}) 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 killThread cReader
- hClose cHandle
- else
- awaitSomethingToWrite ctx
+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 / commitdiff