diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/src/Network/Wai/Route/Tree.hs b/src/Network/Wai/Route/Tree.hs --- a/src/Network/Wai/Route/Tree.hs +++ b/src/Network/Wai/Route/Tree.hs @@ -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 #-} + diff --git a/test/Test/Network/Wai/Route.hs b/test/Test/Network/Wai/Route.hs --- a/test/Test/Network/Wai/Route.hs +++ b/test/Test/Network/Wai/Route.hs @@ -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 _ = "" + show 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 + diff --git a/wai-route.cabal b/wai-route.cabal --- a/wai-route.cabal +++ b/wai-route.cabal @@ -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: . @@ -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 +