X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=05b30420a95040bf9284b94d19bfb913fde51ae4;hp=ecaaadb1d28a7f9ad479443c7b27e5dcc22493d1;hb=8225cc5;hpb=7bc27fc4e86df6cb4d269b42252de735247f8c57 diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index ecaaadb..05b3042 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -10,14 +10,15 @@ module Network.HTTP.Lucu.RequestReader 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 @@ -44,6 +45,11 @@ data Context h , cQueue ∷ !InteractionQueue } +data ChunkReceivingState + = Initial + | InChunk !Int -- ^Number of remaining octets in the current + -- chunk. It's always positive. + requestReader ∷ HandleLike h ⇒ Config → ResTree @@ -157,7 +163,7 @@ acceptRequestForExistentResource ∷ HandleLike h ⇒ Context h → Interaction → Lazy.ByteString - → [Text] + → [Strict.ByteString] → ResourceDef → IO () acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef @@ -165,152 +171,196 @@ 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 @@ -320,23 +370,24 @@ 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