X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=543c82e52e182524460a13d95efb09295fdd4578;hb=90fca0675b1694e69b8e431c989343855cbd125d;hp=2cdc45dc472a42e284472badd85df1f31582c9f5;hpb=3baf479eba12bc3e9c4ef966df770cd70aa5cd81;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 2cdc45d..543c82e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -18,11 +18,13 @@ 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 @@ -93,7 +95,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 @@ -112,15 +114,15 @@ acceptParsableRequest ctx@(Context {..}) req input if isError $ arInitialStatus ar then acceptSemanticallyInvalidRequest ctx ar input else - do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap - 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 @@ -139,7 +141,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 @@ -147,9 +149,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 @@ -298,11 +300,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