X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=497db9320a0d2e87b6dc23d903bc24b213eb6246;hb=7bb9f32;hp=4c59b3e9f8b1ac5a1524d634d2595a339c80c853;hpb=1ead053df6a792edafa9d714c4c038a8a9c3ad16;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 4c59b3e..497db93 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -14,24 +14,28 @@ import Control.Concurrent import Control.Concurrent.STM import Control.Exception hiding (block) import Control.Monad +import Control.Monad.Trans.Maybe import qualified Data.Attoparsec.Lazy as LP import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy +import Data.Convertible.Base +import Data.Convertible.Instances.Text () +import Data.Default import Data.List import Data.Maybe import Data.Monoid.Unicode import qualified Data.Sequence as S -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.Dispatcher.Internal import Network.HTTP.Lucu.HandleLike import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +import Network.HTTP.Lucu.Response.StatusCode import Network.HTTP.Lucu.Resource.Internal -import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.Utils import Network.Socket import Prelude.Unicode @@ -39,13 +43,12 @@ import System.IO (hPutStrLn, stderr) data Context h = Context { - cConfig ∷ !Config - , cResTree ∷ !ResTree - , cFallbacks ∷ ![FallbackHandler] - , cHandle ∷ !h - , cPort ∷ !PortNumber - , cAddr ∷ !SockAddr - , cQueue ∷ !InteractionQueue + cConfig ∷ !Config + , cHostMap ∷ !HostMap + , cHandle ∷ !h + , cPort ∷ !PortNumber + , cAddr ∷ !SockAddr + , cQueue ∷ !InteractionQueue } data ChunkReceivingState @@ -53,18 +56,17 @@ data ChunkReceivingState | InChunk !Int -- ^Number of remaining octets in the current -- chunk. It's always positive. -requestReader ∷ HandleLike h +requestReader ∷ (HostMapper hm, HandleLike h) ⇒ Config - → ResTree - → [FallbackHandler] + → hm → h → PortNumber → SockAddr → InteractionQueue → IO () -requestReader cnf tree fbs h port addr tQueue +requestReader cnf hm h port addr tQueue = do input ← hGetLBS h - acceptRequest (Context cnf tree fbs h port addr tQueue) input + acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input `catches` [ Handler handleAsyncE , Handler handleOthers @@ -94,7 +96,7 @@ acceptRequest ctx@(Context {..}) input if Lazy.null input then return () else - case LP.parse request input of + case LP.parse def input of LP.Done input' req → acceptParsableRequest ctx req input' LP.Fail _ _ _ → acceptNonparsableRequest ctx @@ -109,19 +111,19 @@ acceptParsableRequest ∷ HandleLike h → Lazy.ByteString → IO () acceptParsableRequest ctx@(Context {..}) req input - = do let ar = preprocess (cnfServerHost cConfig) cPort req + = do let ar = preprocess (cnfServerHost cConfig) cPort (hIsSSL cHandle) req if isError $ arInitialStatus ar then acceptSemanticallyInvalidRequest ctx ar input else - do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar - case rsrc of + do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap + case rsrcM of Nothing → do let ar' = ar { arInitialStatus = fromStatusCode NotFound } acceptSemanticallyInvalidRequest ctx ar' input - Just (path, def) - → acceptRequestForResource ctx ar input path def + Just (path, rsrc) + → acceptRequestForResource ctx ar input path rsrc acceptSemanticallyInvalidRequest ∷ HandleLike h ⇒ Context h @@ -140,7 +142,7 @@ acceptRequestForResource ∷ HandleLike h → [Strict.ByteString] → Resource → IO () -acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef +acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc = do #if defined(HAVE_SSL) cert ← hGetPeerCert cHandle @@ -148,9 +150,9 @@ acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsr #else ni ← mkNormalInteraction cConfig cAddr ar rsrcPath #endif - tid ← spawnRsrc rsrcDef ni + tid ← spawnRsrc rsrc ni enqueue ctx ni - if reqMustHaveBody arRequest then + if reqHasBody arRequest then waitForReceiveBodyReq ctx ni tid input else acceptRequest ctx input @@ -299,11 +301,11 @@ chunkWasMalformed tid eCtx e msg = let abo = mkAbortion BadRequest [("Connection", "close")] $ Just $ "chunkWasMalformed: " - ⊕ T.pack msg + ⊕ cs msg ⊕ ": " - ⊕ T.pack (intercalate ", " eCtx) + ⊕ cs (intercalate ", " eCtx) ⊕ ": " - ⊕ T.pack e + ⊕ cs e in throwTo tid abo