wai-routing 0.7 → 0.8
raw patch · 7 files changed
+170/−22 lines, 7 filesdep +criteriondep ~bytestring-fromdep ~http-typesdep ~wai
Dependencies added: criterion
Dependency ranges changed: bytestring-from, http-types, wai, wai-predicates
Files
- CHANGELOG.md +5/−0
- bench/Bench.hs +102/−0
- src/Network/Wai/Routing/Predicate.hs +7/−7
- src/Network/Wai/Routing/Route.hs +21/−3
- test/TestSuite.hs +4/−0
- test/Tests/Wai/Route.hs +14/−9
- wai-routing.cabal +17/−3
CHANGELOG.md view
@@ -1,3 +1,8 @@+0.8+-----------------------------------------------------------------------------+- Update to `wai-predicates 0.6` and change default error renderer.+- Update `bytestring-from` dependency.+ 0.7 ----------------------------------------------------------------------------- - Update dependencies constraints.
+ bench/Bench.hs view
@@ -0,0 +1,102 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Main (main) where++import Criterion.Main+import Criterion.Config+import Network.HTTP.Types hiding (ok200)+import Network.Wai+import Network.Wai.Predicate+import Network.Wai.Routing++sitemap :: Routes a IO ()+sitemap = do+ get "/a" handlerA (query "foo")+ get "/b" handlerB (query "foo" .&. query "bar")+ get "/c" handlerC (query "foo" .&. query "bar" .&. query "baz")+ get "/d" handlerD (query "foo" .&. query "bar" .&. query "baz" .&. query "zoo")+ get "/z" handlerZ $+ query "foo"+ .&. query "bar"+ .&. query "baz"+ .&. query "zoo"+ .&. query "x1"+ .&. query "x2"+ .&. query "x3"+ .&. query "x4"+ .&. query "x5"+ .&. query "x6"+ .&. query "x7"+ .&. query "x8"++handlerA :: Int -> IO Response+handlerA _ = return ok200++handlerB :: Int ::: Int -> IO Response+handlerB _ = return ok200++handlerC :: Int ::: Int ::: Int -> IO Response+handlerC _ = return ok200++handlerD :: Int ::: Int ::: Int ::: Int -> IO Response+handlerD _ = return ok200++handlerZ :: Int ::: Int ::: Int ::: Int ::: Int ::: Int ::: Int ::: Int ::: Int ::: Int ::: Int ::: Int -> IO Response+handlerZ _ = return ok200++ok200 :: Response+ok200 = responseLBS status200 [] ""++reqABad, reqBBad, reqCBad, reqDBad, reqZBad :: Request+reqABad = defaultRequest { rawPathInfo = "/a" }+reqBBad = reqAOk { rawPathInfo = "/b" }+reqCBad = reqBOk { rawPathInfo = "/c" }+reqDBad = reqCOk { rawPathInfo = "/d" }+reqZBad = defaultRequest+ { rawPathInfo = "/z"+ , queryString =+ [ ("foo", Just "42")+ , ("bar", Just "42")+ , ("naz", Just "42")+ , ("zoo", Just "42")+ , ("x1", Just "42")+ , ("x2", Just "42")+ , ("x3", Just "42")+ , ("x4", Just "42")+ , ("x5", Just "42")+ , ("x6", Just "42")+ , ("x7", Just "42")+ ]+ }++reqAOk, reqBOk, reqCOk, reqDOk, reqZOk :: Request+reqAOk = reqABad { queryString = [("foo", Just "42")] }+reqBOk = reqBBad { queryString = ("bar", Just "100") : queryString reqAOk }+reqCOk = reqCBad { queryString = ("baz", Just "0") : queryString reqBOk }+reqDOk = reqDBad { queryString = ("zoo", Just "1") : queryString reqCOk }+reqZOk = reqZBad { queryString = ("x8", Just "42") : queryString reqZBad }++main :: IO ()+main = defaultMainWith defaultConfig (return ())+ [ bgroup "bench"+ [ bench "a - ok" (whnfIO $ f reqAOk)+ , bench "a - bad" (whnfIO $ f reqABad)+ , bench "b - ok" (whnfIO $ f reqBOk)+ , bench "b - bad" (whnfIO $ f reqBBad)+ , bench "c - ok" (whnfIO $ f reqCOk)+ , bench "c - bad" (whnfIO $ f reqCBad)+ , bench "d - ok" (whnfIO $ f reqDOk)+ , bench "d - bad" (whnfIO $ f reqDBad)+ , bench "z - ok" (whnfIO $ f reqZOk)+ , bench "z - bad" (whnfIO $ f reqZBad)+ ]+ ]+ where+ f = route (prepare sitemap)+
src/Network/Wai/Routing/Predicate.hs view
@@ -9,10 +9,9 @@ -- @wai-predicates@. module Network.Wai.Routing.Predicate where +import Control.Monad (when) import Data.ByteString (ByteString) import Data.ByteString.From-import Data.Monoid-import Network.HTTP.Types import Network.Wai.Predicate import Network.Wai.Predicate.Request import Network.Wai.Predicate.Utility@@ -21,15 +20,16 @@ -- | Request path parameters. capture :: (HasCaptures r, FromByteString a) => ByteString -> Predicate r Error a capture k r = case lookupCapture k r of- [] -> Fail (err status400 ("Missing path parameter '" <> k <> "'."))- cc -> either (Fail . err status400) return (readValues cc)+ [] -> Fail $ e400 & addLabel "path" . setReason NotAvailable . setSource k+ cc -> either (\m -> Fail $ e400 & addLabel "path" . setReason TypeError . setSource k . setMessage m)+ return+ (readValues cc) -- | Request path parameters. hasCapture :: (HasCaptures r) => ByteString -> Predicate r Error () hasCapture k r =- if null (lookupCapture k r)- then Fail (err status400 ("Missing path parameter '" <> k <> "'."))- else return ()+ when (null (lookupCapture k r)) $+ Fail (e400 & addLabel "path" . setReason NotAvailable . setSource k) -- | @param \"foo\"@ is equivalent to @query \"foo\" .|. capture \"foo\"@ param :: (HasCaptures r, HasQuery r, FromByteString a) => ByteString -> Predicate r Error a
src/Network/Wai/Routing/Route.hs view
@@ -34,7 +34,7 @@ import Data.Either import Data.Function import Data.List hiding (head, delete)-import Data.Maybe (fromMaybe, mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe, catMaybes) import Data.Monoid import Network.HTTP.Types import Network.Wai (Request, Response, responseLBS, responseBuilder, rawPathInfo)@@ -78,6 +78,24 @@ renderer :: Renderer -> Routes a m () renderer f = Routes . modify $ \s -> s { renderfn = f } +defRenderer :: Renderer+defRenderer e =+ let r = reason2str <$> reason e+ s = source2str <$> source e+ m = message2str <$> message e+ l = labels2str . map Lazy.fromStrict $ labels e+ x = case catMaybes [s, r, l] of+ [] -> Nothing+ xs -> Just (Lazy.intercalate " " xs)+ in maybe x (\y -> (<> (" -- " <> y)) <$> x) m+ where+ reason2str NotAvailable = "not-available"+ reason2str TypeError = "type-error"+ source2str s = "'" <> Lazy.fromStrict s <> "'"+ message2str s = Lazy.fromStrict s+ labels2str [] = Nothing+ labels2str xs = Just $ "[" <> Lazy.intercalate "," xs <> "]"+ -- | The Routes monad state type. data St a m = St { routes :: [Route a m]@@ -86,7 +104,7 @@ -- | Initial state. zero :: St a m-zero = St [] (fmap Lazy.fromStrict . message)+zero = St [] defRenderer -- | The Routes monad is used to add routing declarations -- via 'addRoute' or one of 'get', 'post', etc.@@ -193,7 +211,7 @@ select render rr req = do let ms = filter ((method req ==) . _method) rr if null ms- then return $ respond render (Error status405 Nothing) [(allow, validMethods)]+ then return $ respond render e405 [(allow, validMethods)] else evalAll ms where allow :: HeaderName
test/TestSuite.hs view
@@ -1,3 +1,7 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.+ module Main where import Test.Tasty
test/Tests/Wai/Route.hs view
@@ -1,3 +1,7 @@+-- This Source Code Form is subject to the terms of the Mozilla Public+-- License, v. 2.0. If a copy of the MPL was not distributed with this+-- file, You can obtain one at http://mozilla.org/MPL/2.0/.+ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeOperators #-}@@ -131,11 +135,11 @@ rs0 <- f rq status400 @=? responseStatus rs0- "Missing query 'baz'." @=? responseBody rs0+ "'baz' not-available [query]" @=? responseBody rs0 rs1 <- f . withQuery "baz" "abc" $ rq status400 @=? responseStatus rs1- "Failed reading: Invalid Int" @=? responseBody rs1+ "'baz' type-error [query] -- Failed reading: Invalid Int" @=? responseBody rs1 rs2 <- f . withQuery "baz" "abc" . withQuery "baz" "123" $ rq status200 @=? responseStatus rs2@@ -155,7 +159,8 @@ "Just 123" @=? responseBody rs1 rs2 <- f . withQuery "foo" "abc" $ rq- status200 @=? responseStatus rs2+ status400 @=? responseStatus rs2+ "'foo' type-error [query] -- Failed reading: Invalid Int" @=? responseBody rs2 testEndpointD :: Application -> Assertion@@ -171,8 +176,8 @@ "42" @=? responseBody rs1 rs2 <- f . withQuery "foo" "yyy" $ rq- status200 @=? responseStatus rs2- "0" @=? responseBody rs2+ status400 @=? responseStatus rs2+ "'foo' type-error [query] -- Failed reading: Invalid Int" @=? responseBody rs2 testEndpointE :: Application -> Assertion@@ -188,8 +193,8 @@ "42" @=? responseBody rs1 rs2 <- f $ withHeader "foo" "abc" rq- status200 @=? responseStatus rs2- "0" @=? responseBody rs2+ status400 @=? responseStatus rs2+ "'foo' type-error [header] -- Failed reading: Invalid Int" @=? responseBody rs2 testEndpointF :: Application -> Assertion@@ -207,11 +212,11 @@ rs0 <- f rq status400 @=? responseStatus rs0- "Missing cookie 'user'." @=? responseBody rs0+ "'user' not-available [cookie]" @=? responseBody rs0 rs1 <- f . withHeader "Cookie" "user=joe" $ rq status400 @=? responseStatus rs1- "Missing cookie 'age'." @=? responseBody rs1+ "'age' not-available [cookie]" @=? responseBody rs1 rs2 <- f . withHeader "Cookie" "user=joe; age=42" $ rq status200 @=? responseStatus rs2
wai-routing.cabal view
@@ -1,5 +1,5 @@ name: wai-routing-version: 0.7+version: 0.8 synopsis: Declarative routing for WAI. license: OtherLicense license-file: LICENSE@@ -79,13 +79,13 @@ attoparsec >= 0.10 && < 0.12 , base == 4.* , bytestring >= 0.9 && < 0.11- , bytestring-from == 0.2.*+ , bytestring-from >= 0.2 && < 0.4 , cookie == 0.4.* , case-insensitive >= 1.1 && < 1.3 , http-types == 0.8.* , transformers >= 0.3 && < 0.5 , wai >= 2.0 && < 2.2- , wai-predicates >= 0.3.1 && < 0.6+ , wai-predicates >= 0.6 && < 0.7 , wai-route == 0.1.* test-suite wai-routing-tests@@ -111,6 +111,20 @@ , tasty >= 0.8 , tasty-hunit >= 0.8 , tasty-quickcheck >= 0.8+ , wai+ , wai-predicates+ , wai-routing++benchmark wai-routing-bench+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ main-is: Bench.hs+ hs-source-dirs: bench+ ghc-options: -Wall -O2 -fwarn-tabs+ build-depends:+ base == 4.*+ , criterion == 0.8.*+ , http-types , wai , wai-predicates , wai-routing