wai-route 0.3.1.2 → 0.4.0

raw patch · 4 files changed

+131/−74 lines, 4 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• src/Network/Wai/Route/Tree.hs +21/−16
• test/Test/Network/Wai/Route.hs +88/−55
• wai-route.cabal +17/−3

@@ -1,3 +1,8 @@+## 0.4.0++  * GHC 8.4 compatibility.+  * Drop support for GHC < 8.0+ ## 0.3.1.2    * Adapt to QuickCheck >= 2.10

@@ -30,7 +30,7 @@ import Data.List (foldl') import Data.HashMap.Strict (HashMap) import Data.Maybe (fromMaybe)-import Data.Monoid+import Data.Semigroup import Data.Word import Network.HTTP.Types (urlDecode, urlEncode) import Prelude hiding (lookup)@@ -42,24 +42,27 @@     { subtree :: HashMap ByteString (Tree a)     , capture :: Maybe (Tree a)     , payload :: Maybe (Payload a)-    }+    } deriving (Eq, Show)  data Payload a = Payload-    { value    :: !a-    , path     :: !ByteString+    { path     :: !ByteString+    , value    :: !a     , captures :: !Captures-    }+    } deriving (Eq, Show)  data Captures = Captures     { params :: [ByteString]     , values :: [ByteString]-    }+    } deriving (Eq, Show) +instance Semigroup (Tree a) where+    a <> b =  Tree (subtree a <> subtree b)+                   (capture a <> capture b)+                   (payload a <|> payload b)+ instance Monoid (Tree a) where-    mempty        = Tree mempty Nothing Nothing-    a `mappend` b = Tree (subtree a <> subtree b)-                         (capture a <> capture b)-                         (payload a <|> payload b)+    mempty  = Tree mempty Nothing Nothing+    mappend = (<>)  captureParams :: Captures -> [ByteString] captureParams = params@@ -73,14 +76,15 @@ fromList :: [(ByteString, a)] -> Tree a fromList = foldl' addRoute mempty   where-    addRoute t p = go t (segments (fst p)) []+    addRoute t (p,a) = go t (segments p) []       where         go n [] cs =-            n { payload = Just (Payload (snd p) (fst p) (Captures cs [])) }+            let pa = Payload p a (Captures cs [])+            in n { payload = Just pa }          go n (c:ps) cs | B.head c == colon =-            let b = fromMaybe mempty $ capture n in-            n { capture = Just $! go b ps (B.tail c : cs) }+            let b = fromMaybe mempty $ capture n+            in n { capture = Just $! go b ps (B.tail c : cs) }          go n (d:ps) cs =             let d' = urlEncode False d@@ -91,8 +95,8 @@ lookup t p = go p [] t   where     go [] cvs n =-        let f e = e { captures = Captures (params (captures e)) cvs } in-        f <$> payload n+        let f e = e { captures = Captures (params (captures e)) cvs }+        in f <$> payload n      go (s:ss) cvs n =         maybe (capture n >>= go ss (urlDecode False s : cvs))@@ -122,3 +126,4 @@ colon = 0x3A {-# INLINE slash #-} {-# INLINE colon #-}+

@@ -2,99 +2,132 @@ -- 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 OverloadedStrings    #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings #-}  module Test.Network.Wai.Route (tests) where -import Control.Arrow (first)-import Control.Applicative ((<$>)) import Control.Monad.State.Strict import Data.ByteString (ByteString)-import Data.List (nub)-import Data.Monoid ((<>))+import Data.Semigroup import Network.HTTP.Types import Network.Wai import Network.Wai.Internal (ResponseReceived (..)) import Network.Wai.Route+import Network.Wai.Route.Tree (Tree) import Test.Tasty import Test.Tasty.QuickCheck -import qualified Data.ByteString.Char8 as C-import qualified Data.ByteString.Lazy  as L+import qualified Data.ByteString.Char8  as C+import qualified Network.Wai.Route.Tree as Tree  tests :: TestTree-tests = testProperty "Routing" checkRouting+tests = testGroup "Network.Wai.Route"+    [ testProperty "route" checkRouting+    , testGroup "Network.Wai.Route.Tree"+        [ testProperty "identity" checkMonoidId+        , testProperty "associativity" checkMonoidAssoc+        ]+    ]  checkRouting :: Property checkRouting = forAll genRoutes check   where     check routes =-        let h1  = route $ map (fmap unHandler) routes-            rsv = routes >>= C.split '/' . fst-            res = const $ return ResponseReceived-        in conjoin . flip map routes $ \(r, TestHandler h2) ->-            forAll (genReq r rsv) $ \(params2, rq) ->-                let result1 = h1 rq res    -- routed-                    result2 = h2 [] rq res -- direct-                    (hId1, params1) = execState result1 (-1, [])-                    (hId2,       _) = execState result2 (-1, [])-                in hId1 == hId2 && params1 == params2+        let f = route $ map (fmap unHandler) routes+            k = const $ return ResponseReceived+        in conjoin . flip map routes $ \(p, h) ->+            forAll (genReq p) $ \(params, rq) ->+                let s = execState (f rq k) (-1, [])+                in s == (handlerId h, params) +checkMonoidId :: Property+checkMonoidId = forAll genTree $ \t ->+    t <> mempty == t && mempty <> t == t++checkMonoidAssoc :: Property+checkMonoidAssoc = forAll (replicateM 3 genTree) $ \[t1,t2,t3] ->+    (t1 <> t2) <> t3 == t1 <> (t2 <> t3)+ ------------------------------------------------------------------------------- -- Generators & helpers -newtype TestHandler = TestHandler-    { unHandler :: Handler (State (Int, [(ByteString, ByteString)])) }+type Params = [(ByteString, ByteString)] +data TestHandler = TestHandler+    { handlerId :: !Int+    , unHandler :: Handler (State (Int, Params))+    }++instance Eq TestHandler where+    h1 == h2 = handlerId h1 == handlerId h2+ instance Show TestHandler where-    show _ = "<test-handler>"+    show h = "<test-handler-" ++ show (handlerId h) ++ ">"  handler :: Int -> TestHandler-handler i = TestHandler $ \p _ k -> do+handler i = TestHandler i $ \p _ k -> do     put (i, p)-    k $ responseLBS status200 [] L.empty+    k $ responseLBS status200 [] mempty +-- Generate a name for a capture segment in a route.+genCapture :: Gen ByteString+genCapture = (":"<>) . C.pack <$> listOf1 arbitraryASCIIChar `suchThat` f+  where+    f d = '/' `notElem` d++-- Generate a name for a static segment in a route. These are disambiguated from+-- generated parameter values by a fixed prefix, namely '_'. See 'genParam'. genDir :: Gen ByteString-genDir = C.pack <$> listOf1 arbitraryASCIIChar `suchThat` f+genDir = C.pack . ('_':) <$> listOf1 arbitraryASCIIChar `suchThat` f   where     f d = head d /= ':' && '/' `notElem` d -genCapture :: Gen ByteString-genCapture =  (":"<>) . C.pack <$> listOf1 arbitraryASCIIChar `suchThat` notElem '/'+-- Generate a parameter value for a capture segment to be used in a request.+-- These are disambiguated from static segments by a fixed prefix, namely 'p',+-- in order not to generate values that accidentily match a static segment of+-- some other route.+genParam :: Gen ByteString+genParam = C.pack . ('p':) <$> listOf1 arbitraryASCIIChar -genRoute :: Gen ByteString-genRoute = do+genRoute :: ByteString -> Gen ByteString+genRoute prefix = do     n <- choose (1, 10)     s <- vectorOf n (oneof [genDir, genCapture])-    return $ C.intercalate "/" s+    return $ prefix <> C.intercalate "/" s --- Generates random routing tables without ambiguous routes.--- Two routes are ambiguous if they have an equal number of segments and--- equal static segments appear in the same positions.+-- Generates routing tables without ambiguous routes (by giving every route a+-- prefix that is unique in this routing table). genRoutes :: Gen [(ByteString, TestHandler)] genRoutes = do-    n <- choose (0, 10)-    r <- vectorOf n genRoute `suchThat` noAmbiguity-    return $ r `zip` map handler [0..n]-  where-    noAmbiguity rs = let rs' = map normalize rs-                     in length (nub rs') == length rs'-    normalize = filter ((/=':') . C.head . snd)-              . zip ([0..] :: [Int])-              . C.split '/'+    n <- choose (0, 100)+    r <- mapM (genRoute . C.pack . show) [1..n]+    return $ r `zip` map handler [1..n] --- Generate a request with a path matching the given route.-genReq :: ByteString   -- ^ Route-       -> [ByteString] -- ^ Reserved names-       -> Gen ([(ByteString, ByteString)], Request)-genReq r reserved = do-    values <- vectorOf (length segs) genDir `suchThat` all (`notElem` reserved)-    let zipped = segs `zip` values-        params = reverse . map (first C.tail) . filter ((==':') . C.head . fst) $ zipped-        rq = defaultRequest { rawPathInfo = C.intercalate "/"  $ map toSeg zipped }-    return (params, rq)+genTree :: Gen (Tree TestHandler)+genTree = Tree.fromList <$> genRoutes++-- Generate a request with a path matching the given route,+-- replacing captures with actual parameter values.+genReq :: ByteString -> Gen (Params, Request)+genReq r = do+    -- Pair each segment of the route with a potential parameter value.+    -- Those values which are paired with a capture are the actual parameters.+    let segs = C.split '/' r+    values <- vectorOf (length segs) genParam+    let segs' = segs `zip` values+    return (mkParams segs', mkReq segs')   where-    segs = C.split '/' r-    toSeg (s, v) | C.head s == ':' = urlEncode False v-                 | otherwise       = urlEncode False s+    mkReq segs = defaultRequest+          { rawPathInfo = C.intercalate "/" (map mkSeg segs)+          }++    mkSeg (seg, val)+        | C.head seg == ':' = urlEncode False val+        | otherwise         = urlEncode False seg++    mkParams = reverse . foldr go []+      where+        go (seg, val) params+            | C.head seg == ':' = (C.tail seg, val) : params+            | otherwise         = params+

@@ -1,11 +1,11 @@ name:                wai-route-version:             0.3.1.2-synopsis:            Minimalistic, efficient routing for WAI+version:             0.4.0+synopsis:            Minimalistic, efficient routing for WAI. description:     .     Simple routing for applications using the WAI, based on an     efficient tree structure. Routes are defined as string literals-    and path segments prefixed with a ':' indicate captures.+    whereby path segments beginning with a ':' indicate captures.     .     A sample is available at: <https://github.com/romanb/wai-route/blob/master/sample/Main.hs>. @@ -19,6 +19,8 @@ extra-source-files:  README.md, sample/*.hs, CHANGELOG.md cabal-version:       >=1.10 +tested-with: GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3+ source-repository head     type:     git     location: git@github.com:romanb/wai-route.git@@ -62,3 +64,15 @@       , tasty-quickcheck >= 0.9       , wai       , wai-route++-- executable wai-route-sample+--     hs-source-dirs: sample+--     main-is: Main.hs+--     build-depends:+--           base+--         , bytestring+--         , http-types+--         , wai+--         , wai-route+--         , warp+