X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=b0af8d1f38d773571c8374ce4c5cff2101992b75;hp=05b30420a95040bf9284b94d19bfb913fde51ae4;hb=f402841101b4b84f263eea1a43c848f81c48ff93;hpb=0aa4f6d758fc12fba468f7cd399bbcc48f693d1e diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 05b3042..b0af8d1 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DoAndIfThenElse + , OverloadedStrings , RecordWildCards , ScopedTypeVariables , UnicodeSyntax @@ -8,29 +9,29 @@ module Network.HTTP.Lucu.RequestReader ( requestReader ) where -import Control.Applicative +import Control.Concurrent import Control.Concurrent.STM 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 qualified Data.Strict.Maybe as S import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence.Unicode hiding ((∅)) +import qualified Data.Text as T +import Network.HTTP.Lucu.Abortion import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk 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.Internal import Network.HTTP.Lucu.Resource.Tree import Network.Socket -import Network.URI import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -96,15 +97,12 @@ acceptRequest ctx@(Context {..}) input -- ResponseWriter に通知する。 case LP.parse requestP input of LP.Done input' req → acceptParsableRequest ctx req input' - LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest + LP.Fail _ _ _ → acceptNonparsableRequest ctx -acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO () -acceptNonparsableRequest ctx@(Context {..}) sc - = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc) - atomically $ - do writeTVar (itrState itr) Done - postprocess itr - enqueue ctx itr +acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO () +acceptNonparsableRequest ctx@(Context {..}) + = do syi ← mkSyntacticallyInvalidInteraction cConfig + enqueue ctx syi acceptParsableRequest ∷ HandleLike h ⇒ Context h @@ -112,120 +110,98 @@ acceptParsableRequest ∷ HandleLike h → Lazy.ByteString → IO () acceptParsableRequest ctx@(Context {..}) req input - = do cert ← hGetPeerCert cHandle - itr ← newInteraction cConfig cPort cAddr cert (Right req) - join $ atomically - $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr) - if isErr then - acceptSemanticallyInvalidRequest ctx itr input - else - return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input + = do let ar = preprocess (cnfServerHost cConfig) cPort req + if isError $ arInitialStatus ar then + acceptSemanticallyInvalidRequest ctx ar input + else + do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar + case rsrc of + Nothing + → do let ar' = ar { arInitialStatus = NotFound } + acceptSemanticallyInvalidRequest ctx ar' input + Just (path, def) + → acceptRequestForResource ctx ar input path def acceptSemanticallyInvalidRequest ∷ HandleLike h ⇒ Context h - → Interaction + → AugmentedRequest → Lazy.ByteString - → STM (IO ()) -acceptSemanticallyInvalidRequest ctx itr input - = do writeTVar (itrState itr) Done - postprocess itr - enqueue ctx itr - return $ acceptRequest ctx input - -acceptSemanticallyValidRequest ∷ HandleLike h - ⇒ Context h - → Interaction - → URI - → Lazy.ByteString - → IO () -acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input - = do rsrcM ← findResource cResTree cFallbacks uri - case rsrcM of - Nothing - → acceptRequestForNonexistentResource ctx itr input - Just (rsrcPath, rsrcDef) - → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef - -acceptRequestForNonexistentResource ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → IO () -acceptRequestForNonexistentResource ctx itr input - = do atomically $ - do setResponseStatus itr NotFound - writeTVar (itrState itr) Done - postprocess itr - enqueue ctx itr + → IO () +acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input + = do sei ← mkSemanticallyInvalidInteraction cConfig ar + enqueue ctx sei acceptRequest ctx input -acceptRequestForExistentResource ∷ HandleLike h - ⇒ Context h - → Interaction - → Lazy.ByteString - → [Strict.ByteString] - → ResourceDef - → IO () -acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef - = do let itr = oldItr { itrResourcePath = Just rsrcPath } - atomically $ enqueue ctx itr - do _ ← spawnResource rsrcDef itr - if reqMustHaveBody $ fromJust $ itrRequest itr then - waitForReceiveBodyReq ctx itr input - else - acceptRequest ctx input +acceptRequestForResource ∷ HandleLike h + ⇒ Context h + → AugmentedRequest + → Lazy.ByteString + → [Strict.ByteString] + → ResourceDef + → IO () +acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef + = do cert ← hGetPeerCert cHandle + ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath + tid ← spawnResource rsrcDef ni + if reqMustHaveBody arRequest then + waitForReceiveBodyReq ctx ni tid input + else + acceptRequest ctx input waitForReceiveBodyReq ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId → Lazy.ByteString → IO () -waitForReceiveBodyReq ctx itr input - = case fromJust $ itrReqBodyLength itr of +waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input + = case S.fromJust niReqBodyLength of Chunked - → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input + → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input Fixed len - → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len + → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len -- Toooooo long name for a function... waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId → Lazy.ByteString → IO () -waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input +waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input = join $ atomically $ - do req ← takeTMVar itrReceiveBodyReq + do req ← takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → do putTMVar itrSendContinue $ fromJust itrExpectedContinue - return $ readCurrentChunk ctx itr input Initial wanted + → do putTMVar niSendContinue niExpectedContinue + return $ readCurrentChunk ctx ni rsrcTid wanted input Initial WasteAll - → do putTMVar itrSendContinue False - return $ wasteAllChunks ctx itr input Initial + → do putTMVar niSendContinue False + return $ wasteAllChunks ctx rsrcTid input Initial waitForReceiveChunkedBodyReq ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId → Lazy.ByteString → ChunkReceivingState → IO () -waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st - = do req ← atomically $ takeTMVar itrReceiveBodyReq +waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st + = do req ← atomically $ takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → readCurrentChunk ctx itr input st wanted + → readCurrentChunk ctx ni rsrcTid wanted input st WasteAll - → wasteAllChunks ctx itr input st + → wasteAllChunks ctx rsrcTid input st wasteAllChunks ∷ HandleLike h ⇒ Context h - → Interaction + → ThreadId → Lazy.ByteString → ChunkReceivingState → IO () -wasteAllChunks ctx itr = go +wasteAllChunks ctx rsrcTid = go where go ∷ Lazy.ByteString → ChunkReceivingState → IO () go input Initial @@ -233,8 +209,9 @@ wasteAllChunks ctx itr = go LP.Done input' chunkLen | chunkLen ≡ 0 → gotFinalChunk input' | otherwise → gotChunk input' chunkLen - LP.Fail _ _ _ - → chunkWasMalformed itr + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "wasteAllChunks: chunkHeaderP: " ⧺ msg go input (InChunk chunkLen) = gotChunk input chunkLen @@ -245,30 +222,28 @@ wasteAllChunks ctx itr = go case LP.parse chunkFooterP input' of LP.Done input'' _ → go input'' Initial - LP.Fail _ _ _ - → chunkWasMalformed itr + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "wasteAllChunks: chunkFooterP: " ⧺ msg gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input - = case LP.parse chunkFooterP input of + = case LP.parse chunkTrailerP 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 + → acceptRequest ctx input' + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "wasteAllChunks: chunkTrailerP: " ⧺ msg readCurrentChunk ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction + → ThreadId + → Int → Lazy.ByteString → ChunkReceivingState - → Int → IO () -readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted - = go input0 st0 +readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go where go ∷ Lazy.ByteString → ChunkReceivingState → IO () go input Initial @@ -278,8 +253,9 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted → gotFinalChunk input' | otherwise → gotChunk input' chunkLen - LP.Fail _ _ _ - → chunkWasMalformed itr + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "readCurrentChunk: chunkHeaderP: " ⧺ msg go input (InChunk chunkLen) = gotChunk input chunkLen @@ -290,67 +266,64 @@ readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted block' = Strict.concat $ Lazy.toChunks block actualReadBytes = Strict.length block' chunkLen' = chunkLen - actualReadBytes - atomically $ putTMVar itrReceivedBody block' + atomically $ putTMVar niReceivedBody block' if chunkLen' ≡ 0 then case LP.parse chunkFooterP input' of LP.Done input'' _ - → waitForReceiveChunkedBodyReq ctx itr input'' Initial - LP.Fail _ _ _ - → chunkWasMalformed itr + → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "readCurrentChunk: chunkFooterP: " ⧺ msg else - waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen' + waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen' gotFinalChunk ∷ Lazy.ByteString → IO () gotFinalChunk input - = do atomically $ putTMVar itrReceivedBody (∅) - case LP.parse chunkFooterP input of + = do atomically $ putTMVar niReceivedBody (∅) + case LP.parse chunkTrailerP 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 + → acceptRequest ctx input' + LP.Fail _ _ msg + → chunkWasMalformed rsrcTid + $ "readCurrentChunk: chunkTrailerP: " ⧺ msg -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 +chunkWasMalformed ∷ ThreadId → String → IO () +chunkWasMalformed tid msg + = let abo = mkAbortion BadRequest [("Connection", "close")] + $ Just + $ "chunkWasMalformed: " ⊕ T.pack msg + in + throwTo tid abo waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → Lazy.ByteString → Int → IO () -waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen +waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen = join $ atomically $ - do req ← takeTMVar itrReceiveBodyReq + do req ← takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → do putTMVar itrSendContinue $ fromJust itrExpectedContinue - return $ readNonChunkedRequestBody ctx itr input bodyLen wanted + → do putTMVar niSendContinue niExpectedContinue + return $ readNonChunkedRequestBody ctx ni input bodyLen wanted WasteAll - → do putTMVar itrSendContinue False + → do putTMVar niSendContinue False return $ wasteNonChunkedRequestBody ctx input bodyLen waitForReceiveNonChunkedBodyReq ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → Lazy.ByteString → Int → IO () -waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen - = do req ← atomically $ takeTMVar itrReceiveBodyReq +waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen + = do req ← atomically $ takeTMVar niReceiveBodyReq case req of ReceiveBody wanted - → readNonChunkedRequestBody ctx itr input bodyLen wanted + → readNonChunkedRequestBody ctx ni input bodyLen wanted WasteAll → wasteNonChunkedRequestBody ctx input bodyLen @@ -365,12 +338,12 @@ wasteNonChunkedRequestBody ctx input bodyLen readNonChunkedRequestBody ∷ HandleLike h ⇒ Context h - → Interaction + → NormalInteraction → Lazy.ByteString → Int → Int → IO () -readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted +readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted | bodyLen ≡ 0 = gotEndOfRequest | otherwise = gotBody where @@ -381,15 +354,17 @@ readNonChunkedRequestBody ctx itr@(Interaction {..}) input bodyLen wanted block' = Strict.concat $ Lazy.toChunks block actualReadBytes = Strict.length block' bodyLen' = bodyLen - actualReadBytes - atomically $ putTMVar itrReceivedBody block' - waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen' + atomically $ putTMVar niReceivedBody block' + waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen' gotEndOfRequest ∷ IO () gotEndOfRequest - = do atomically $ putTMVar itrReceivedBody (∅) + = do atomically $ putTMVar niReceivedBody (∅) acceptRequest ctx input -enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM () +enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO () +{-# INLINEABLE enqueue #-} enqueue (Context {..}) itr - = do queue ← readTVar cQueue - writeTVar cQueue (itr ⊲ queue) + = atomically $ + do queue ← readTVar cQueue + writeTVar cQueue (toInteraction itr ⊲ queue)