packages feed

reroute 0.6.0.0 → 0.7.0.0

raw patch · 10 files changed

+426/−362 lines, 10 filessetup-changednew-uploader

Files

LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2014 - 2015 Alexander Thiemann <mail@athiemann.net>+Copyright (c) 2014 - 2021 Alexander Thiemann <mail@athiemann.net> Copyright (c) 2014 - 2015 Tim Baumann <tim@timbaumann.info>  Permission is hereby granted, free of charge, to any person obtaining
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
benchmarks/Benchmarks.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE OverloadedStrings, DataKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}  module Main where -import Web.Routing.Combinators-import Web.Routing.SafeRouting- import Criterion.Main+import Data.List (foldl', permutations)+import Data.Maybe (fromMaybe, listToMaybe) import qualified Data.Text as T-import Data.List (permutations, foldl') import System.Random (mkStdGen, randomRs)-import Data.Maybe (listToMaybe, fromMaybe)+import Web.Routing.Combinators+import Web.Routing.SafeRouting  buildPath :: [T.Text] -> PathInternal '[] buildPath = toInternalPath . static . T.unpack . T.intercalate "/"@@ -25,16 +25,17 @@ benchmarks :: [Benchmark] benchmarks =   [ env setupSafeMap $ \ ~(safeMap, routes') ->-    bgroup "SafeRouting"-    [ bench "static-lookup" $ whnf (lookupPathMapM routes') safeMap-    ]+      bgroup+        "SafeRouting"+        [ bench "static-lookup" $ whnf (lookupPathMapM routes') safeMap+        ]   ]   where     strlen = 10     seglen = 5     num = 10     routes = rndRoutes strlen seglen num-    routesList = zip routes [1..]+    routesList = zip routes [1 ..]     setupSafeMap = return (buildPathMap routesList, routes)  main :: IO ()@@ -43,16 +44,22 @@ chunks :: Int -> [a] -> [[a]] chunks n xs =   let (ys, xs') = splitAt n xs-  in ys : chunks n xs'+   in ys : chunks n xs'  -- | Generate a number of paths consisting of a fixed number of fixed length -- strings ("path segments") where the content of the segments are letters in -- random order. Contains all permutations with the path. rndRoutes ::-     Int -- ^ Length of each string-  -> Int -- ^ Number of segments-  -> Int -- ^ Number of routes-  -> [[T.Text]]+  -- | Length of each string+  Int ->+  -- | Number of segments+  Int ->+  -- | Number of routes+  Int ->+  [[T.Text]] rndRoutes strlen seglen num =-  take num $ concatMap permutations $ chunks seglen $ map T.pack $-    chunks strlen $ randomRs ('a', 'z') $ mkStdGen 1234+  take num $+    concatMap permutations $+      chunks seglen $+        map T.pack $+          chunks strlen $ randomRs ('a', 'z') $ mkStdGen 1234
reroute.cabal view
@@ -1,5 +1,5 @@ name:                reroute-version:             0.6.0.0+version:             0.7.0.0 synopsis:            abstract implementation of typed and untyped web routing description:         abstraction over how urls with/without parameters are mapped to their corresponding handlers homepage:            http://github.com/agrafix/Spock@@ -7,11 +7,11 @@ license-file:        LICENSE author:              Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info> maintainer:          Alexander Thiemann <mail@athiemann.net>-copyright:           (c) 2014 - 2020 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info>+copyright:           (c) 2014 - 2021 Alexander Thiemann <mail@athiemann.net>, Tim Baumann <tim@timbaumann.info> category:            Web build-type:          Simple-cabal-version:       >=2.0-tested-with:         GHC==8.8.4+cabal-version:       2.0+tested-with:         GHC==8.8.4, GHC==9.2.2  extra-source-files:     README.md
src/Data/PolyMap.hs view
@@ -1,19 +1,31 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module Data.PolyMap-  ( PolyMap, empty, rnfHelper-  , lookup, lookupApply, lookupApplyAll, lookupConcat-  , alter,  updateAll, insertWith-  , unionWith, union-  , zipWith', zipWith, zip, ap-  ) where+  ( PolyMap,+    empty,+    rnfHelper,+    lookup,+    lookupApply,+    lookupApplyAll,+    lookupConcat,+    alter,+    updateAll,+    insertWith,+    unionWith,+    union,+    zipWith',+    zipWith,+    zip,+    ap,+  )+where  import Data.Typeable-import Prelude hiding (lookup, zipWith, zip) #if MIN_VERSION_base(4,11,0) import Control.Applicative (Alternative ((<|>)), liftA2) #elif MIN_VERSION_base(4,9,0)@@ -26,6 +38,7 @@ import Data.Monoid (Monoid (..)) #endif import GHC.Exts (Constraint)+import Prelude hiding (lookup, zip, zipWith)  data PolyMap (c :: * -> Constraint) (f :: * -> *) (a :: *) where   PMNil :: PolyMap c f a@@ -50,9 +63,9 @@ rnfHelper h (PMCons v pm) = h v `seq` rnfHelper h pm  lookup ::-  Typeable p-  => PolyMap c f a-  -> Maybe (f (p -> a))+  Typeable p =>+  PolyMap c f a ->+  Maybe (f (p -> a)) lookup PMNil = Nothing lookup (PMCons w polyMap') =   case gcast1 w of@@ -60,10 +73,10 @@     Nothing -> lookup polyMap'  lookupApply ::-  (Typeable p, Functor f)-  => p-  -> PolyMap c f a-  -> Maybe (f a)+  (Typeable p, Functor f) =>+  p ->+  PolyMap c f a ->+  Maybe (f a) lookupApply _ PMNil = Nothing lookupApply p (PMCons w polyMap') =   case gcast1 w of@@ -71,47 +84,46 @@     Nothing -> lookupApply p polyMap'  lookupApplyAll ::-  Functor f-  => (forall p. c p => Maybe p)-  -> PolyMap c f a-  -> [f a]+  Functor f =>+  (forall p. c p => Maybe p) ->+  PolyMap c f a ->+  [f a] lookupApplyAll maybeGet polyMap =   case polyMap of     PMNil -> []     PMCons w polyMap' ->       let rest = lookupApplyAll maybeGet polyMap'-      in case maybeGet of-           Nothing -> rest-           Just p  -> (fmap ($ p) w) : rest+       in case maybeGet of+            Nothing -> rest+            Just p -> (fmap ($ p) w) : rest  lookupConcat ::-  (Monoid m, Functor f)-  => (forall p. c p => Maybe p)-  -> (forall p. c p => p -> f (p -> a) -> m)-  -> PolyMap c f a-  -> m+  (Monoid m, Functor f) =>+  (forall p. c p => Maybe p) ->+  (forall p. c p => p -> f (p -> a) -> m) ->+  PolyMap c f a ->+  m lookupConcat maybeGet comp polyMap =   case polyMap of     PMNil -> mempty     PMCons w polyMap' ->       let rest = lookupConcat maybeGet comp polyMap'-      in case maybeGet of-           Nothing -> rest-           Just p  -> comp p w `mappend` rest-+       in case maybeGet of+            Nothing -> rest+            Just p -> comp p w `mappend` rest  maybeInsertHere ::-  (c p, Typeable p)-  => Maybe (f (p -> a))-  -> PolyMap c f a-  -> PolyMap c f a+  (c p, Typeable p) =>+  Maybe (f (p -> a)) ->+  PolyMap c f a ->+  PolyMap c f a maybeInsertHere = maybe id PMCons  alter ::-  (Typeable p, c p)-  => (Maybe (f (p -> a)) -> Maybe (f (p -> a)))-  -> PolyMap c f a-  -> PolyMap c f a+  (Typeable p, c p) =>+  (Maybe (f (p -> a)) -> Maybe (f (p -> a))) ->+  PolyMap c f a ->+  PolyMap c f a alter (g :: Maybe (f (p -> a)) -> Maybe (f (p -> a))) polyMap =   case polyMap of     PMNil -> insertHere PMNil@@ -123,53 +135,56 @@             Nothing -> polyMap'         Nothing ->           if typeOf (undefined :: p) < typeOf (undefined :: q)-          then insertHere polyMap-          else PMCons w (alter g polyMap')-  where insertHere = maybe id PMCons (g Nothing)+            then insertHere polyMap+            else PMCons w (alter g polyMap')+  where+    insertHere = maybe id PMCons (g Nothing)  updateAll ::-     (forall p. c p => f (p -> a) -> g (p -> b))-  -> PolyMap c f a-  -> PolyMap c g b+  (forall p. c p => f (p -> a) -> g (p -> b)) ->+  PolyMap c f a ->+  PolyMap c g b updateAll _ PMNil = PMNil updateAll f (PMCons v pm) = PMCons (f v) (updateAll f pm)  insertWith ::-  (Typeable p, c p)-  => (f (p -> a) -> f (p -> a) -> f (p -> a))-  -> f (p -> a)-  -> PolyMap c f a-  -> PolyMap c f a+  (Typeable p, c p) =>+  (f (p -> a) -> f (p -> a) -> f (p -> a)) ->+  f (p -> a) ->+  PolyMap c f a ->+  PolyMap c f a insertWith combine val = alter (Just . maybe val (combine val))  unionWith ::-     (forall p. c p => f (p -> a) -> f (p -> a) -> f (p -> a))-  -> PolyMap c f a-  -> PolyMap c f a-  -> PolyMap c f a+  (forall p. c p => f (p -> a) -> f (p -> a) -> f (p -> a)) ->+  PolyMap c f a ->+  PolyMap c f a ->+  PolyMap c f a unionWith _ PMNil pm2 = pm2 unionWith _ pm1 PMNil = pm1-unionWith combine pm1@(PMCons (v :: f (p -> a)) pm1')-                  pm2@(PMCons (w :: f (q -> a)) pm2') =-  case gcast1 v of-    Just v' -> PMCons (combine v' w) (unionWith combine pm1' pm2')-    Nothing ->+unionWith+  combine+  pm1@(PMCons (v :: f (p -> a)) pm1')+  pm2@(PMCons (w :: f (q -> a)) pm2') =+    case gcast1 v of+      Just v' -> PMCons (combine v' w) (unionWith combine pm1' pm2')+      Nothing ->         if typeOf (undefined :: p) < typeOf (undefined :: q)-        then PMCons v (unionWith combine pm1' pm2)-        else PMCons w (unionWith combine pm1 pm2')+          then PMCons v (unionWith combine pm1' pm2)+          else PMCons w (unionWith combine pm1 pm2')  union ::-  Alternative f-  => PolyMap c f a-  -> PolyMap c f a-  -> PolyMap c f a+  Alternative f =>+  PolyMap c f a ->+  PolyMap c f a ->+  PolyMap c f a union = unionWith (<|>)  zipWith' ::-     (forall p. c p => Maybe (f (p -> a)) -> Maybe (f (p -> b)) -> Maybe (f (p -> d)))-  -> PolyMap c f a-  -> PolyMap c f b-  -> PolyMap c f d+  (forall p. c p => Maybe (f (p -> a)) -> Maybe (f (p -> b)) -> Maybe (f (p -> d))) ->+  PolyMap c f a ->+  PolyMap c f b ->+  PolyMap c f d zipWith' f = go   where     go PMNil PMNil = PMNil@@ -180,27 +195,27 @@         Just v' -> maybeInsertHere (f (Just v') (Just w)) (go pm1 pm2)         Nothing ->           if typeOf (undefined :: p) < typeOf (undefined :: q)-          then maybeInsertHere (f (Just v) Nothing) (go pm1' pm2)-          else maybeInsertHere (f Nothing (Just w)) (go pm1 pm2')+            then maybeInsertHere (f (Just v) Nothing) (go pm1' pm2)+            else maybeInsertHere (f Nothing (Just w)) (go pm1 pm2')  zipWith ::-  Applicative f-  => (a -> b -> d)-  -> PolyMap c f a-  -> PolyMap c f b-  -> PolyMap c f d+  Applicative f =>+  (a -> b -> d) ->+  PolyMap c f a ->+  PolyMap c f b ->+  PolyMap c f d zipWith f = zipWith' $ liftA2 $ liftA2 $ \a b p -> f (a p) (b p)  zip ::-  Applicative f-  => PolyMap c f a-  -> PolyMap c f b-  -> PolyMap c f (a, b)+  Applicative f =>+  PolyMap c f a ->+  PolyMap c f b ->+  PolyMap c f (a, b) zip = zipWith (,)  ap ::-  Applicative f-  => PolyMap c f (a -> b)-  -> PolyMap c f a-  -> PolyMap c f b+  Applicative f =>+  PolyMap c f (a -> b) ->+  PolyMap c f a ->+  PolyMap c f b ap = zipWith ($)
src/Web/Routing/Combinators.hs view
@@ -5,14 +5,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}+ module Web.Routing.Combinators where  import Data.HVect import Data.String+import qualified Data.Text as T import Data.Typeable (Typeable) import Web.HttpApiData-import qualified Data.Text as T- import Web.Routing.SafeRouting  data PathState = Open | Closed@@ -31,6 +31,20 @@  type Var a = Path (a ': '[]) 'Open +-- | A variant of 'Either' with a 'FromHttpApiData' definition that tries both branches without a prefix.+-- Useful to define routes with 'var's that should work with different types.+data AltVar a b = AvLeft a | AvRight b+  deriving (Show, Eq, Read, Ord)++instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (AltVar a b) where+  parseUrlPiece val =+    case parseUrlPiece val of+      Left err ->+        case parseUrlPiece val of+          Left err2 -> Left (err <> " " <> err2)+          Right ok -> Right (AvRight ok)+      Right ok -> Right (AvLeft ok)+ -- | A route parameter var :: (Typeable a, FromHttpApiData a) => Path (a ': '[]) 'Open var = VarCons Empty@@ -39,10 +53,10 @@ static :: String -> Path '[] 'Open static s =   let pieces = filter (not . T.null) $ T.splitOn "/" $ T.pack s-  in foldr StaticCons Empty pieces+   in foldr StaticCons Empty pieces  instance (a ~ '[], pathState ~ 'Open) => IsString (Path a pathState) where-    fromString = static+  fromString = static  -- | The root of a path piece. Use to define a handler for "/" root :: Path '[] 'Open@@ -69,9 +83,10 @@ renderRoute' :: AllHave ToHttpApiData as => Path as 'Open -> HVect as -> [T.Text] renderRoute' Empty _ = [] renderRoute' (StaticCons pathPiece pathXs) paramXs =-    ( pathPiece : renderRoute' pathXs paramXs )+  (pathPiece : renderRoute' pathXs paramXs) renderRoute' (VarCons pathXs) (val :&: paramXs) =-    ( toUrlPiece val : renderRoute' pathXs paramXs)+  (toUrlPiece val : renderRoute' pathXs paramXs)+ #if __GLASGOW_HASKELL__ < 800 renderRoute' _ _ =     error "This will never happen."
src/Web/Routing/Router.hs view
@@ -1,125 +1,134 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-}-module Web.Routing.Router where+{-# LANGUAGE TypeFamilies #-} -import Web.Routing.SafeRouting+module Web.Routing.Router where  #if MIN_VERSION_base(4,8,0) #else import Control.Applicative #endif import Control.Monad.RWS.Strict+import qualified Data.HashMap.Strict as HM import Data.Hashable import Data.Maybe-import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import Web.Routing.SafeRouting -newtype RegistryT n b middleware reqTypes (m :: * -> *) a-    = RegistryT-    { runRegistryT :: RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a-    }-    deriving (Monad, Functor, Applicative, MonadIO-               , MonadReader (PathInternal '[])-               , MonadWriter [middleware]-               , MonadState (RegistryState n b reqTypes)-               , MonadTrans-               )+newtype RegistryT n b middleware reqTypes (m :: * -> *) a = RegistryT+  { runRegistryT :: RWST (PathInternal '[]) [middleware] (RegistryState n b reqTypes) m a+  }+  deriving+    ( Monad,+      Functor,+      Applicative,+      MonadIO,+      MonadReader (PathInternal '[]),+      MonadWriter [middleware],+      MonadState (RegistryState n b reqTypes),+      MonadTrans+    ) -data RegistryState n b reqTypes-   = RegistryState-   { rs_registry :: !(HM.HashMap reqTypes (Registry n b))-   , rs_anyMethod :: !(Registry n b)-   }+data RegistryState n b reqTypes = RegistryState+  { rs_registry :: !(HM.HashMap reqTypes (Registry n b)),+    rs_anyMethod :: !(Registry n b)+  }  hookAny ::-    (Monad m, Eq reqTypes, Hashable reqTypes)-    => reqTypes-    -> ([T.Text] -> n b)-    -> RegistryT n b middleware reqTypes m ()+  (Monad m, Eq reqTypes, Hashable reqTypes) =>+  reqTypes ->+  ([T.Text] -> n b) ->+  RegistryT n b middleware reqTypes m () hookAny reqType action =-    modify $ \rs ->-        rs-        { rs_registry =-                let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))-                in HM.insert reqType (fallbackRoute action reg) (rs_registry rs)-        }+  modify $ \rs ->+    rs+      { rs_registry =+          let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))+           in HM.insert reqType (fallbackRoute action reg) (rs_registry rs)+      }  hookAnyMethod ::-    (Monad m)-    => ([T.Text] -> n b)-    -> RegistryT n b middleware reqTypes m ()+  (Monad m) =>+  ([T.Text] -> n b) ->+  RegistryT n b middleware reqTypes m () hookAnyMethod action =-    modify $+  modify $     \rs ->-        rs+      rs         { rs_anyMethod = fallbackRoute action (rs_anyMethod rs)         }  hookRoute ::-    (Monad m, Eq reqTypes, Hashable reqTypes)-    => reqTypes-    -> PathInternal as-    -> HVectElim' (n b) as-    -> RegistryT n b middleware reqTypes m ()+  (Monad m, Eq reqTypes, Hashable reqTypes) =>+  reqTypes ->+  PathInternal as ->+  HVectElim' (n b) as ->+  RegistryT n b middleware reqTypes m () hookRoute reqType path action =-    do basePath <- ask-       modify $ \rs ->-           rs { rs_registry =-                    let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))-                        reg' = defRoute (basePath </!> path) action reg-                    in HM.insert reqType reg' (rs_registry rs)-              }+  do+    basePath <- ask+    modify $ \rs ->+      rs+        { rs_registry =+            let reg = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))+                reg' = defRoute (basePath </!> path) action reg+             in HM.insert reqType reg' (rs_registry rs)+        }  hookRouteAnyMethod ::-    (Monad m)-    => PathInternal as-    -> HVectElim' (n b) as-    -> RegistryT n b middleware reqTypes m ()+  (Monad m) =>+  PathInternal as ->+  HVectElim' (n b) as ->+  RegistryT n b middleware reqTypes m () hookRouteAnyMethod path action =-    do basePath <- ask-       modify $ \rs ->-           rs-           { rs_anyMethod = defRoute (basePath </!> path) action (rs_anyMethod rs)-           }+  do+    basePath <- ask+    modify $ \rs ->+      rs+        { rs_anyMethod = defRoute (basePath </!> path) action (rs_anyMethod rs)+        } -middleware :: Monad m-           => middleware-           -> RegistryT n b middleware reqTypes m ()+middleware ::+  Monad m =>+  middleware ->+  RegistryT n b middleware reqTypes m () middleware x = tell [x]  swapMonad ::-    Monad m-    => (forall b. n b -> m b)-    -> RegistryT x y middleware reqTypes n a-    -> RegistryT x y middleware reqTypes m a+  Monad m =>+  (forall b. n b -> m b) ->+  RegistryT x y middleware reqTypes n a ->+  RegistryT x y middleware reqTypes m a swapMonad liftLower (RegistryT subReg) =-    do parentSt <- get-       basePath <- ask-       (a, parentSt', middleware') <--           lift $ liftLower $ runRWST subReg basePath parentSt-       put parentSt'-       tell middleware'-       return a+  do+    parentSt <- get+    basePath <- ask+    (a, parentSt', middleware') <-+      lift $ liftLower $ runRWST subReg basePath parentSt+    put parentSt'+    tell middleware'+    return a -runRegistry :: (Monad m, Hashable reqTypes, Eq reqTypes)-            => RegistryT n b middleware reqTypes m a-            -> m (a, reqTypes -> [T.Text] -> [n b], [middleware])+runRegistry ::+  (Monad m, Hashable reqTypes, Eq reqTypes) =>+  RegistryT n b middleware reqTypes m a ->+  m (a, reqTypes -> [T.Text] -> [n b], [middleware]) runRegistry (RegistryT rwst) =-    do (val, st, w) <- runRWST rwst PI_Empty initSt-       return (val, handleF (rs_anyMethod st) (rs_registry st), w)-    where-      handleF anyReg hm ty route =-          let froute = filter (not . T.null) route-          in case HM.lookup ty hm of-               Nothing -> matchRoute anyReg froute-               Just registry ->-                   (matchRoute registry froute ++ matchRoute anyReg froute)-      initSt =-          RegistryState-          { rs_registry = HM.empty-          , rs_anyMethod = emptyRegistry-          }+  do+    (val, st, w) <- runRWST rwst PI_Empty initSt+    return (val, handleF (rs_anyMethod st) (rs_registry st), w)+  where+    handleF anyReg hm ty route =+      let froute = filter (not . T.null) route+       in case HM.lookup ty hm of+            Nothing -> matchRoute anyReg froute+            Just registry ->+              (matchRoute registry froute ++ matchRoute anyReg froute)+    initSt =+      RegistryState+        { rs_registry = HM.empty,+          rs_anyMethod = emptyRegistry+        }
src/Web/Routing/SafeRouting.hs view
@@ -1,18 +1,14 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-}-module Web.Routing.SafeRouting where -import Data.HVect hiding (null, length)-import qualified Data.HVect as HV-import qualified Data.PolyMap as PM+module Web.Routing.SafeRouting where -import Data.Maybe #if MIN_VERSION_base(4,11,0) #elif MIN_VERSION_base(4,9,0) import Data.Semigroup@@ -23,15 +19,19 @@ import Data.Monoid (Monoid (..), (<>)) #endif import Control.DeepSeq (NFData (..))-import Data.Typeable (Typeable)-import Web.HttpApiData+import Data.HVect hiding (length, null)+import qualified Data.HVect as HV import qualified Data.HashMap.Strict as HM+import Data.Maybe+import qualified Data.PolyMap as PM import qualified Data.Text as T+import Data.Typeable (Typeable)+import Web.HttpApiData  data RouteHandle m a-   = forall as. RouteHandle (PathInternal as) (HVectElim as (m a))+  = forall as. RouteHandle (PathInternal as) (HVectElim as (m a)) -newtype HVectElim' x ts = HVectElim' { flipHVectElim :: HVectElim ts x }+newtype HVectElim' x ts = HVectElim' {flipHVectElim :: HVectElim ts x}  type Registry m a = (PathMap (m a), [[T.Text] -> m a]) @@ -40,21 +40,21 @@  defRoute :: PathInternal xs -> HVectElim' (m a) xs -> Registry m a -> Registry m a defRoute path action (m, call) =-    ( insertPathMap (RouteHandle path (flipHVectElim action)) m-    , call-    )+  ( insertPathMap (RouteHandle path (flipHVectElim action)) m,+    call+  )  fallbackRoute :: ([T.Text] -> m a) -> Registry m a -> Registry m a fallbackRoute routeDef (m, call) = (m, call ++ [routeDef])  matchRoute :: Registry m a -> [T.Text] -> [m a] matchRoute (m, cAll) pathPieces =-    let matches = match m pathPieces-        matches' =-            if null matches-            then matches ++ (map (\f -> f pathPieces) cAll)-            else matches-    in matches'+  let matches = match m pathPieces+      matches' =+        if null matches+          then matches ++ (map (\f -> f pathPieces) cAll)+          else matches+   in matches'  data PathInternal (as :: [*]) where   PI_Empty :: PathInternal '[] -- the empty path@@ -62,22 +62,21 @@   PI_VarCons :: (FromHttpApiData a, Typeable a) => PathInternal as -> PathInternal (a ': as) -- append a param to path   PI_Wildcard :: PathInternal as -> PathInternal (T.Text ': as) -- append the rest of the route -data PathMap x =-  PathMap-  { pm_subComponents :: [[T.Text] -> x]-  , pm_here :: [x]-  , pm_staticMap :: HM.HashMap T.Text (PathMap x)-  , pm_polyMap :: PM.PolyMap FromHttpApiData PathMap x-  , pm_wildcards :: [T.Text -> x]+data PathMap x = PathMap+  { pm_subComponents :: [[T.Text] -> x],+    pm_here :: [x],+    pm_staticMap :: HM.HashMap T.Text (PathMap x),+    pm_polyMap :: PM.PolyMap FromHttpApiData PathMap x,+    pm_wildcards :: [T.Text -> x]   }  instance Functor PathMap where   fmap f (PathMap c h s p w) =-      PathMap (fmap f <$> c) (f <$> h) (fmap f <$> s) (f <$> p) (fmap f <$> w)+    PathMap (fmap f <$> c) (f <$> h) (fmap f <$> s) (f <$> p) (fmap f <$> w)  instance NFData x => NFData (PathMap x) where   rnf (PathMap c h s p w) =-      rnf c `seq` rnf h `seq` rnf s `seq` PM.rnfHelper rnf p `seq` rnf w+    rnf c `seq` rnf h `seq` rnf s `seq` PM.rnfHelper rnf p `seq` rnf w  emptyPathMap :: PathMap x emptyPathMap = PathMap mempty mempty mempty PM.empty mempty@@ -90,31 +89,32 @@   mempty = emptyPathMap   mappend = (<>) -updatePathMap-  :: (forall y. (ctx -> y) -> PathMap y -> PathMap y)-  -> PathInternal ts-  -> (HVect ts -> ctx -> x)-  -> PathMap x-  -> PathMap x+updatePathMap ::+  (forall y. (ctx -> y) -> PathMap y -> PathMap y) ->+  PathInternal ts ->+  (HVect ts -> ctx -> x) ->+  PathMap x ->+  PathMap x updatePathMap updateFn path action pm@(PathMap c h s p w) =   case path of     PI_Empty -> updateFn (action HNil) pm     PI_StaticCons pathPiece path' ->       let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece s)-      in PathMap c h (HM.insert pathPiece (updatePathMap updateFn path' action subPathMap) s) p w+       in PathMap c h (HM.insert pathPiece (updatePathMap updateFn path' action subPathMap) s) p w     PI_VarCons path' ->-      let alterFn = Just . updatePathMap updateFn path' (\vs ctx v -> action (v :&: vs) ctx)-                         . fromMaybe emptyPathMap-      in PathMap c h s (PM.alter alterFn p) w+      let alterFn =+            Just . updatePathMap updateFn path' (\vs ctx v -> action (v :&: vs) ctx)+              . fromMaybe emptyPathMap+       in PathMap c h s (PM.alter alterFn p) w     PI_Wildcard PI_Empty ->       let (PathMap _ (action' : _) _ _ _) = updateFn (\ctx rest -> action (rest :&: HNil) ctx) emptyPathMap-      in PathMap c h s p $ action' : w+       in PathMap c h s p $ action' : w     PI_Wildcard _ -> error "Shouldn't happen"  insertPathMap' :: PathInternal ts -> (HVect ts -> x) -> PathMap x -> PathMap x insertPathMap' path action =   let updateHeres y (PathMap c h s p w) = PathMap c (y () : h) s p w-  in updatePathMap updateHeres path (const <$> action)+   in updatePathMap updateHeres path (const <$> action)  singleton :: PathInternal ts -> HVectElim ts x -> PathMap x singleton path action = insertPathMap' path (HV.uncurry action) mempty@@ -125,7 +125,7 @@ insertSubComponent' :: PathInternal ts -> (HVect ts -> [T.Text] -> x) -> PathMap x -> PathMap x insertSubComponent' path subComponent =   let updateSubComponents y (PathMap c h s p w) = PathMap (y : c) h s p w-  in updatePathMap updateSubComponents path subComponent+   in updatePathMap updateSubComponents path subComponent  insertSubComponent :: Functor m => RouteHandle m ([T.Text] -> a) -> PathMap (m a) -> PathMap (m a) insertSubComponent (RouteHandle path comp) =@@ -133,17 +133,19 @@  match :: PathMap x -> [T.Text] -> [x] match (PathMap c h s p w) pieces =-  map ($ pieces) c ++-  case pieces of-    [] -> h ++ fmap ($ "") w-    (pp:pps) ->-      let staticMatches = maybeToList (HM.lookup pp s) >>= flip match pps-          varMatches = PM.lookupConcat (either (const Nothing) Just $ parseUrlPiece pp)-                         (\piece pathMap' -> fmap ($ piece) (match pathMap' pps)) p-          routeRest = combineRoutePieces pieces-          wildcardMatches = fmap ($ routeRest) w-      in staticMatches ++ varMatches ++ wildcardMatches-+  map ($ pieces) c+    ++ case pieces of+      [] -> h ++ fmap ($ "") w+      (pp : pps) ->+        let staticMatches = maybeToList (HM.lookup pp s) >>= flip match pps+            varMatches =+              PM.lookupConcat+                (either (const Nothing) Just $ parseUrlPiece pp)+                (\piece pathMap' -> fmap ($ piece) (match pathMap' pps))+                p+            routeRest = combineRoutePieces pieces+            wildcardMatches = fmap ($ routeRest) w+         in staticMatches ++ varMatches ++ wildcardMatches  (</!>) :: PathInternal as -> PathInternal bs -> PathInternal (Append as bs) (</!>) PI_Empty xs = xs@@ -158,19 +160,19 @@ parse PI_Empty [] = Just HNil parse _ [] = Nothing parse path pathComps@(pathComp : xs) =-    case path of-      PI_Empty -> Nothing-      PI_StaticCons pathPiece pathXs ->-          if pathPiece == pathComp-          then parse pathXs xs-          else Nothing-      PI_VarCons pathXs ->-          case parseUrlPiece pathComp of-            Left _ -> Nothing-            Right val ->-                let finish = parse pathXs xs-                in fmap (\parsedXs -> val :&: parsedXs) finish-      PI_Wildcard PI_Empty ->-        Just $ combineRoutePieces pathComps :&: HNil-      PI_Wildcard _ ->-        error "Shouldn't happen"+  case path of+    PI_Empty -> Nothing+    PI_StaticCons pathPiece pathXs ->+      if pathPiece == pathComp+        then parse pathXs xs+        else Nothing+    PI_VarCons pathXs ->+      case parseUrlPiece pathComp of+        Left _ -> Nothing+        Right val ->+          let finish = parse pathXs xs+           in fmap (\parsedXs -> val :&: parsedXs) finish+    PI_Wildcard PI_Empty ->+      Just $ combineRoutePieces pathComps :&: HNil+    PI_Wildcard _ ->+      error "Shouldn't happen"
test/Spec.hs view
@@ -1,9 +1,9 @@ module Main where -import qualified Web.Routing.SafeRoutingSpec- import Test.Hspec+import qualified Web.Routing.SafeRoutingSpec  main :: IO ()-main = hspec $+main =+  hspec $     Web.Routing.SafeRoutingSpec.spec
test/Web/Routing/SafeRoutingSpec.hs view
@@ -1,28 +1,28 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-}-module Web.Routing.SafeRoutingSpec where+{-# LANGUAGE TypeFamilies #-} -import Web.Routing.Combinators-import Web.Routing.Router-import Web.Routing.SafeRouting+module Web.Routing.SafeRoutingSpec where  import Control.Monad.Identity import Control.Monad.RWS.Strict import Data.HVect hiding (singleton)+import qualified Data.HashMap.Strict as HM import Data.List import Data.Maybe-import Test.Hspec-import qualified Data.HashMap.Strict as HM import qualified Data.Text as T+import Test.Hspec+import Web.Routing.Combinators+import Web.Routing.Router+import Web.Routing.SafeRouting  data ReturnVar-   = IntVar Int-   | StrVar T.Text-   | BoolVar Bool-   | ListVar [ReturnVar]-   deriving (Show, Eq, Read, Ord)+  = IntVar Int+  | StrVar T.Text+  | ListVar [ReturnVar]+  | EitherVar (AltVar Int T.Text)+  deriving (Show, Eq, Read, Ord)  defR :: (Monad m, m ReturnVar ~ x) => Path ts ps -> HVectElim ts x -> RegistryT m ReturnVar middleware Bool m () defR path action = hookRoute True (toInternalPath path) (HVectElim' action)@@ -32,93 +32,108 @@  -- TODO: abstract this code, move into AbstractRouter defSubComponent ::-    ( Monad m+  ( Monad m, #if __GLASGOW_HASKELL__ <= 708     , Functor m #endif-    , m ([T.Text] -> ReturnVar) ~ x-    )-    => Path ts ps-    -> HVectElim ts x-    -> RegistryT m ReturnVar middleware Bool m ()+    m ([T.Text] -> ReturnVar) ~ x+  ) =>+  Path ts ps ->+  HVectElim ts x ->+  RegistryT m ReturnVar middleware Bool m () defSubComponent path comp =-    do let reqType = True-       basePath <- ask-       modify $ \rs ->-           rs { rs_registry =-                    let (reg, fb) = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))-                        reg' = insertSubComponent (RouteHandle (basePath </!> toInternalPath path) comp) reg-                    in HM.insert reqType (reg', fb) (rs_registry rs)-              }+  do+    let reqType = True+    basePath <- ask+    modify $ \rs ->+      rs+        { rs_registry =+            let (reg, fb) = fromMaybe emptyRegistry (HM.lookup reqType (rs_registry rs))+                reg' = insertSubComponent (RouteHandle (basePath </!> toInternalPath path) comp) reg+             in HM.insert reqType (reg', fb) (rs_registry rs)+        }  spec :: Spec spec =-    describe "SafeRouting Spec" $-    do it "should match known routes" $-          do checkRoute "" [StrVar "root"]-             checkRoute "/" [StrVar "root"]-             checkRoute "/bar" [StrVar "bar"]-       it "should match any routes" $-          do checkRoute' "/any" True [StrVar "any", StrVar "any"] -- two due to hookAny-             checkRoute' "/any" False [StrVar "any"]-       it "should capture variables in routes" $-          do checkRoute "/bar/23/baz" [IntVar 23]-             checkRoute "/bar/23/baz/" [IntVar 23]-             checkRoute "/bar/23/baz/100" [ListVar [IntVar 23, IntVar 100]]-             checkRoute "/bar/23/100" [ListVar [IntVar 23, IntVar 100]]-             checkRoute "/entry/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]]-             checkRoute "/entry/bytags/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]]-             checkRoute "/entry/2/rel/3"  [ListVar [IntVar 2, IntVar 3]]-       it "should handle multiple possible matches correctly" $-          do checkRoute "/bar/5" [IntVar 5, StrVar "5"]-             checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"]-             checkRoute "/entry/1/audit" [IntVar 1,ListVar [IntVar 1,StrVar "audit"]]-       it "should have a catch all route" $-          do checkRoute "/aslkdjk/asdaskl/aslkjd" [StrVar "aslkdjk/asdaskl/aslkjd"]-             checkRoute "/zuiasf/zuiasf" [StrVar "zuiasf/zuiasf"]-       it "should hand over remaining path pieces to subcomponents" $-          do checkRoute "/subcomponent/blog/foo/bar/nanana" [StrVar "blog:foo?bar?nanana"]-       it "should handle wildcard routes" $-          do checkRoute "/wildcard/" [StrVar ""]-             checkRoute "/wildcard/some/additional/data" [StrVar "some/additional/data"]-    where-      pieces :: T.Text -> [T.Text]-      pieces = filter (not . T.null) . T.splitOn "/"+  describe "SafeRouting Spec" $+    do+      it "should match known routes" $+        do+          checkRoute "" [StrVar "root"]+          checkRoute "/" [StrVar "root"]+          checkRoute "/bar" [StrVar "bar"]+      it "should match any routes" $+        do+          checkRoute' "/any" True [StrVar "any", StrVar "any"] -- two due to hookAny+          checkRoute' "/any" False [StrVar "any"]+      it "should capture variables in routes" $+        do+          checkRoute "/bar/23/baz" [IntVar 23]+          checkRoute "/bar/23/baz/" [IntVar 23]+          checkRoute "/bar/23/baz/100" [ListVar [IntVar 23, IntVar 100]]+          checkRoute "/bar/23/100" [ListVar [IntVar 23, IntVar 100]]+          checkRoute "/entry/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]]+          checkRoute "/entry/bytags/344/2014-20-14T12:23" [ListVar [IntVar 344, StrVar "2014-20-14T12:23"]]+          checkRoute "/entry/2/rel/3" [ListVar [IntVar 2, IntVar 3]]+      it "should handle multiple possible matches correctly" $+        do+          checkRoute "/bar/5" [IntVar 5, StrVar "5"]+          checkRoute "/bar/bingo" [StrVar "bar/bingo", StrVar "bingo"]+          checkRoute "/entry/1/audit" [IntVar 1, ListVar [IntVar 1, StrVar "audit"]]+      it "should have a catch all route" $+        do+          checkRoute "/aslkdjk/asdaskl/aslkjd" [StrVar "aslkdjk/asdaskl/aslkjd"]+          checkRoute "/zuiasf/zuiasf" [StrVar "zuiasf/zuiasf"]+      it "should hand over remaining path pieces to subcomponents" $+        do checkRoute "/subcomponent/blog/foo/bar/nanana" [StrVar "blog:foo?bar?nanana"]+      it "should handle wildcard routes" $+        do+          checkRoute "/wildcard/" [StrVar ""]+          checkRoute "/wildcard/some/additional/data" [StrVar "some/additional/data"]+      it "correctly handles alternatives" $+        do+          checkRoute "/either/1" [EitherVar (AvLeft 1)]+          checkRoute "/either/aaa" [EitherVar (AvRight "aaa")]+  where+    pieces :: T.Text -> [T.Text]+    pieces = filter (not . T.null) . T.splitOn "/" -      checkRoute' :: T.Text -> Bool -> [ReturnVar] -> Expectation-      checkRoute' r b x =-          let matches = handleFun b (pieces r)-          in sort (map runIdentity matches) `shouldBe` sort x+    checkRoute' :: T.Text -> Bool -> [ReturnVar] -> Expectation+    checkRoute' r b x =+      let matches = handleFun b (pieces r)+       in sort (map runIdentity matches) `shouldBe` sort x -      checkRoute :: T.Text -> [ReturnVar] -> Expectation-      checkRoute = flip checkRoute' True+    checkRoute :: T.Text -> [ReturnVar] -> Expectation+    checkRoute = flip checkRoute' True -      handleFun :: Bool -> [T.Text] -> [Identity ReturnVar]-      handleFun = handleFun'+    handleFun :: Bool -> [T.Text] -> [Identity ReturnVar]+    handleFun = handleFun' -      (_, handleFun', _) = runIdentity (runRegistry handleDefs)+    (_, handleFun', _) = runIdentity (runRegistry handleDefs) -      handleDefs =-          do defR root $ return (StrVar "root")-             defRAny "any" $ pure (StrVar "any")-             defR "bar" $ return (StrVar "bar")-             defR ("bar" </> var) (return . IntVar)-             defR ("bar" </> var </> "baz") (return . IntVar)-             defR ("bar" </> var </> "baz" </> var) $ \i i2 ->-                 return (ListVar [IntVar i, IntVar i2])-             defR ("bar" </> var </> var) $ \i i2 ->-                 return (ListVar [IntVar i, IntVar i2])-             defR ("entry" </> var </> var) $ \i st ->-                 return (ListVar [IntVar i, StrVar st])-             defR ("entry/bytags" </> var </> var) $ \i st ->-                 return (ListVar [IntVar i, StrVar st])-             defR ("entry" </> var </> "rel" </> var) $ \i i2 ->-                 return (ListVar [IntVar i, IntVar i2])-             defR ("bar" </> "bingo") $ return (StrVar "bar/bingo")-             defR ("bar" </> var) $ (return . StrVar . T.pack)-             defR ("entry" </> var </> "audit") (return . IntVar)-             defSubComponent ("subcomponent" </> var) $ \name ->-               return $ \ps -> StrVar $ name <> ":" <> T.intercalate "?" ps-             defR ("wildcard" </> wildcard) $ \rest ->-               return $ StrVar rest-             hookAny True (return . StrVar . T.intercalate "/")+    handleDefs =+      do+        defR root $ return (StrVar "root")+        defRAny "any" $ pure (StrVar "any")+        defR "bar" $ return (StrVar "bar")+        defR ("bar" </> var) (return . IntVar)+        defR ("bar" </> var </> "baz") (return . IntVar)+        defR ("bar" </> var </> "baz" </> var) $ \i i2 ->+          return (ListVar [IntVar i, IntVar i2])+        defR ("bar" </> var </> var) $ \i i2 ->+          return (ListVar [IntVar i, IntVar i2])+        defR ("entry" </> var </> var) $ \i st ->+          return (ListVar [IntVar i, StrVar st])+        defR ("entry/bytags" </> var </> var) $ \i st ->+          return (ListVar [IntVar i, StrVar st])+        defR ("entry" </> var </> "rel" </> var) $ \i i2 ->+          return (ListVar [IntVar i, IntVar i2])+        defR ("bar" </> "bingo") $ return (StrVar "bar/bingo")+        defR ("bar" </> var) (return . StrVar)+        defR ("either" </> var) (return . EitherVar)+        defR ("entry" </> var </> "audit") (return . IntVar)+        defSubComponent ("subcomponent" </> var) $ \name ->+          return $ \ps -> StrVar $ name <> ":" <> T.intercalate "?" ps+        defR ("wildcard" </> wildcard) $ \rest ->+          return $ StrVar rest+        hookAny True (return . StrVar . T.intercalate "/")