From 17020e406a20cbef8ec17594868db559c4c5a5db Mon Sep 17 00:00:00 2001 From: PHO Date: Sat, 8 Oct 2011 22:26:34 +0900 Subject: [PATCH] RequestReader now compiles... Ditz-issue: 8959dadc07db1bd363283dee401073f6e48dc7fa --- Network/HTTP/Lucu/Preprocess.hs | 1 + Network/HTTP/Lucu/RequestReader.hs | 299 +++++++++++++++++------------ 2 files changed, 180 insertions(+), 120 deletions(-) diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index f2212ab..99c4beb 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -41,6 +41,7 @@ data AugmentedRequest data RequestBodyLength = Fixed !Int | Chunked + deriving (Eq, Show) preprocess ∷ Text → PortNumber diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 5818378..fbc8551 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -9,28 +9,29 @@ module Network.HTTP.Lucu.RequestReader ) where import Control.Applicative -import Control.Concurrent.STM -import Control.Exception -import Control.Monad +import Control.Concurrent.STM +import Control.Exception +import Control.Monad import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString.Lazy as Lazy -import Data.Maybe +import Data.Maybe import qualified Data.Sequence as S import Data.Sequence.Unicode -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.Chunk -import Network.HTTP.Lucu.DefaultPage -import Network.HTTP.Lucu.HandleLike -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Postprocess -import Network.HTTP.Lucu.Preprocess -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -import Network.HTTP.Lucu.Resource.Tree +import Data.Text (Text) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Chunk +import Network.HTTP.Lucu.DefaultPage +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Preprocess +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Resource.Tree import Network.Socket import Network.URI import Prelude.Unicode -import System.IO (hPutStrLn, stderr) +import System.IO (hPutStrLn, stderr) data Context h = Context { @@ -76,43 +77,44 @@ acceptRequest ctx@(Context {..}) input -- Request 應答を設定し、それを出力してから切斷するやうに -- ResponseWriter に通知する。 case LP.parse requestP input of - LP.Done input' req → acceptParsableRequest req input' + LP.Done input' req → acceptParsableRequest ctx req input' LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO () -acceptNonparsableRequest (Context {..}) status - = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing +acceptNonparsableRequest ctx@(Context {..}) sc + = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc) atomically $ - do setResponseStatus itr status - writeTVar (itrWillClose itr) True - writeTVar (itrState itr) Done + do writeTVar (itrState itr) Done writeDefaultPage itr postprocess itr - enqueue itr + enqueue ctx itr acceptParsableRequest ∷ HandleLike h ⇒ Context h → Request → Lazy.ByteString → IO () -acceptParsableRequest (Context {..}) req input +acceptParsableRequest ctx@(Context {..}) req input = do cert ← hGetPeerCert cHandle itr ← newInteraction cConfig cPort cAddr cert (Right req) join $ atomically - $ do preprocess itr - isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr) + $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr) if isErr then - acceptSemanticallyInvalidRequest itr input + acceptSemanticallyInvalidRequest ctx itr input else - acceptSemanticallyValidRequest itr (reqURI req) input + return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input -acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ()) -acceptSemanticallyInvalidRequest itr input - = do writeTVar (itr itrState) Done +acceptSemanticallyInvalidRequest ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → STM (IO ()) +acceptSemanticallyInvalidRequest ctx itr input + = do writeTVar (itrState itr) Done writeDefaultPage itr postprocess itr - enqueue itr - return $ acceptRequest input + enqueue ctx itr + return $ acceptRequest ctx input acceptSemanticallyValidRequest ∷ HandleLike h ⇒ Context h @@ -120,73 +122,106 @@ acceptSemanticallyValidRequest ∷ HandleLike h → URI → Lazy.ByteString → IO () -acceptSemanticallyValidRequest (Context {..}) itr uri input +acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input = do rsrcM ← findResource cResTree cFallbacks uri case rsrcM of Nothing - → acceptRequestForNonexistentResource itr input + → acceptRequestForNonexistentResource ctx itr input Just (rsrcPath, rsrcDef) - → acceptRequestForExistentResource itr input rsrcPath rsrcDef + → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef -acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ()) -acceptRequestForNonexistentResource itr input - = do setResponseStatus itr NotFound - writeTVar (itrState itr) Done - writeDefaultPage itr - postprocess itr - enqueue itr - return $ acceptRequest input +acceptRequestForNonexistentResource ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → IO () +acceptRequestForNonexistentResource ctx itr input + = do atomically $ + do setResponseStatus itr NotFound + writeTVar (itrState itr) Done + writeDefaultPage itr + postprocess itr + enqueue ctx itr + acceptRequest ctx input -acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ()) -acceptRequestForExistentResource oldItr input rsrcPath rsrcDef +acceptRequestForExistentResource ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → [Text] + → ResourceDef + → IO () +acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef = do let itr = oldItr { itrResourcePath = Just rsrcPath } - enqueue itr - return $ do _ ← runResource rsrcDef itr - if reqHasBody $ fromJust $ itrRequest itr then - observeRequest itr input - else - acceptRequest input + atomically $ enqueue ctx itr + do _ ← runResource rsrcDef itr + if reqHasBody $ fromJust $ itrRequest itr then + observeRequest ctx itr input + else + acceptRequest ctx input -observeRequest ∷ Interaction → Lazy.ByteString → IO () -observeRequest itr input - | itrReqBodyLength itr ≡ Just Chunked - = observeChunkedRequest itr input - | otherwise - = observeNonChunkedRequest itr 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 ∷ Interaction → Lazy.ByteString → IO () -observeChunkedRequest itr input +observeChunkedRequest ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → Int + → IO () +observeChunkedRequest ctx itr input remaining = join $ atomically $ do isOver ← readTVar $ itrReqChunkIsOver itr if isOver then - return $ acceptRequest input + return $ acceptRequest ctx input else do wantedM ← readTVar $ itrReqBodyWanted itr - if isNothing wantedM then - do wasteAll ← readTVar $ itrReqBodyWasteAll itr - if wasteAll then - wasteCurrentChunk input - else - retry - else - readCurrentChunk (fromJust wantedM) + case wantedM of + Nothing + → do wasteAll ← readTVar $ itrReqBodyWasteAll itr + if wasteAll then + return $ wasteCurrentChunk ctx itr input remaining + else + retry + Just wanted + → return $ readCurrentChunk ctx itr input wanted remaining -wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO () -wasteCurrentChunk itr input len +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 itr input'' + → observeChunkedRequest ctx itr input'' 0 LP.Fail _ _ _ → chunkWasMalformed itr | otherwise - = seekNextChunk itr input + = seekNextChunk ctx itr input -readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO () -readCurrentChunk itr input wanted remaining +readCurrentChunk ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → Int + → Int + → IO () +readCurrentChunk ctx itr input wanted remaining | remaining > 0 = do let bytesToRead = fromIntegral $ min wanted remaining (chunk, input') = Lazy.splitAt bytesToRead input @@ -194,87 +229,111 @@ readCurrentChunk itr input wanted remaining newWanted = case wanted - actualReadBytes of 0 → Nothing n → Just n - newRemaining = Just $ remaining - actualReadBytes - updateStates = do writeTVar (itrReqBodyWanted itr) newWanted + 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 (itrReceivedBody itr) $ oldBody ⋈ chunk' writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes - if newRemaining ≡ Just 0 then + if newRemaining ≡ 0 then case LP.parse chunkFooterP input' of LP.Done input'' _ → do updateStates - observeChunkedRequest itr input'' + observeChunkedRequest ctx itr input'' 0 LP.Fail _ _ _ → chunkWasMalformed itr else do updateStates - observeChunkedRequest itr input' + observeChunkedRequest ctx itr input' newRemaining | otherwise - = seekNextChunk itr input + = seekNextChunk ctx itr input -seekNextChunk ∷ Interaction → Lazy.ByteString → IO () -seekNextChunk itr input +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 LP.Done input'' _ - → do writeTVar (itrReqChunkIsOver itr) True - acceptRequest input'' + → do atomically $ + writeTVar (itrReqChunkIsOver itr) True + acceptRequest ctx input'' LP.Fail _ _ _ → chunkWasMalformed itr | otherwise -- Non-final chunk - → do observeChunkedRequest itr input' + → observeChunkedRequest ctx itr input' len LP.Fail _ _ _ → chunkWasMalformed itr chunkWasMalformed ∷ Interaction → IO () chunkWasMalformed itr = atomically $ - do setResponseStatus BadRequest - writeTVar (itrWillClose itr) True - writeTVar (itrState itr) Done - writeDefaultPage itr - postprocess itr + do setResponseStatus itr BadRequest + writeTVar (itrWillClose itr) True + writeTVar (itrState itr) Done + writeDefaultPage itr + postprocess itr -observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO () -observeNonChunkedRequest itr input +observeNonChunkedRequest ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → Int + → IO () +observeNonChunkedRequest ctx itr input remaining = join $ atomically $ do wantedM ← readTVar $ itrReqBodyWanted itr - if isNothing wantedM then - do wasteAll ← readTVar itr itrReqBodyWasteAll id - if wasteAll then - wasteNonChunkedRequestBody itr input - else - retry - else - readNonChunkedRequestBody itr input + case wantedM of + Nothing + → do wasteAll ← readTVar $ itrReqBodyWasteAll itr + if wasteAll then + return $ wasteNonChunkedRequestBody ctx itr input remaining + else + retry + Just wanted + → return $ readNonChunkedRequestBody ctx itr input wanted remaining -wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO () -wasteNonChunkedRequestBody itr input remaining - = do let input' = case remaining of - Just len → Lazy.drop len input - Nothing → (∅) - writeTVar (itrReqChunkIsOver itr) True - acceptRequest input' +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 + acceptRequest ctx input' -readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO () -readNonChunkedRequestBody itr input wanted remaining - = do let bytesToRead = fromIntegral $ maybe wanted (min wanted) remaining - (chunk, input') = Lazy.splitAt bytesToRead input +readNonChunkedRequestBody ∷ HandleLike h + ⇒ Context h + → Interaction + → Lazy.ByteString + → 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 - newRemaining = (- actualReadBytes) <$> remaining - isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0 - writeTVar (itrReqChunkIsOver itr) isOver - writeTVar (itrReqBodyWanted itr) Nothing - writeTVar (itrReceivedBody itr) chunk - writeTVar (itrReceivedBodyLen itr) actualReadBytes + newRemaining = remaining - actualReadBytes + isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0 + chunk' = S.fromList $ Lazy.toChunks chunk + atomically $ + do writeTVar (itrReqChunkIsOver itr) isOver + writeTVar (itrReqBodyWanted itr) Nothing + writeTVar (itrReceivedBody itr) chunk' + writeTVar (itrReceivedBodyLen itr) actualReadBytes if isOver then - acceptRequest input' + acceptRequest ctx input' else - observeNonChunkedRequest itr input' + observeNonChunkedRequest ctx itr input' newRemaining enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM () enqueue (Context {..}) itr -- 2.40.0