module Web.Routing.SafeRouting where
import Web.Routing.AbstractRouter
import Data.HList
import Data.Maybe
import Data.Monoid
import Data.String
import Web.PathPieces
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
data RouteHandle m a
= forall as. RouteHandle (Path as) (HListElim as (m a))
newtype HListElim' x ts = HListElim' { flipHListElim :: HListElim ts x }
data SafeRouter (m :: * -> *) a = SafeRouter
instance AbstractRouter (SafeRouter m a) where
newtype Registry (SafeRouter m a) = SafeRouterReg (PathMap (m a))
newtype RoutePath (SafeRouter m a) xs = SafeRouterPath (Path xs)
type RouteAction (SafeRouter m a) = HListElim' (m a)
type RouteAppliedAction (SafeRouter m a) = m a
subcompCombine (SafeRouterPath p1) (SafeRouterPath p2) =
SafeRouterPath $
p1 </> p2
emptyRegistry = SafeRouterReg emptyPathMap
rootPath = SafeRouterPath Empty
defRoute (SafeRouterPath path) action (SafeRouterReg m) =
SafeRouterReg $
insertPathMap (RouteHandle path (flipHListElim action)) m
matchRoute (SafeRouterReg m) pathPieces =
let matches = match m pathPieces
in zip (replicate (length matches) HM.empty) matches
type family HListElim (ts :: [*]) (a :: *) :: *
type instance HListElim '[] a = a
type instance HListElim (t ': ts) a = t -> HListElim ts a
hListUncurry :: HListElim ts a -> HList ts -> a
hListUncurry f HNil = f
hListUncurry f (HCons x xs) = hListUncurry (f x) xs
data Path (as :: [*]) where
Empty :: Path '[]
StaticCons :: T.Text -> Path as -> Path as
VarCons :: (PathPiece a, Typeable a) => Path as -> Path (a ': as)
data PolyMap x where
PMNil :: PolyMap x
PMCons :: (Typeable a, PathPiece a) => PathMap (a -> x) -> PolyMap x -> PolyMap x
data Id a = Id { getId :: a }
castDefType :: (Typeable a, Typeable b) => (a -> c) -> Maybe (b -> c)
castDefType x = fmap getId (gcast1 (Id x))
insertPolyMap ::
(Typeable a, PathPiece a)
=> Path ts
-> (a -> HList ts -> x)
-> PolyMap x
-> PolyMap x
insertPolyMap path (action :: a -> HList ts -> x) polyMap =
case polyMap of
PMNil -> PMCons (insertPathMap' path (flip action) emptyPathMap) PMNil
PMCons (pathMap :: PathMap (b -> x)) polyMap' ->
case castDefType action of
Just action' ->
PMCons (insertPathMap' path (flip action') pathMap) polyMap'
Nothing ->
PMCons pathMap (insertPolyMap path action polyMap')
lookupPolyMap :: T.Text -> [T.Text] -> PolyMap x -> [x]
lookupPolyMap _ _ PMNil = []
lookupPolyMap pp pps (PMCons pathMap polyMap') =
(maybeToList (fromPathPiece pp) >>= \val -> fmap ($ val) (match pathMap pps))
++ lookupPolyMap pp pps polyMap'
emptyPolyMap :: PolyMap x
emptyPolyMap = PMNil
data PathMap x = PathMap [x] (HM.HashMap T.Text (PathMap x)) (PolyMap x)
emptyPathMap :: PathMap x
emptyPathMap = PathMap mempty mempty emptyPolyMap
insertPathMap' :: Path ts -> (HList ts -> x) -> PathMap x -> PathMap x
insertPathMap' path action (PathMap as m pm) =
case path of
Empty -> PathMap (action HNil : as) m pm
StaticCons pathPiece xs ->
let subPathMap = fromMaybe emptyPathMap (HM.lookup pathPiece m)
in PathMap as (HM.insert pathPiece (insertPathMap' xs action subPathMap) m) pm
VarCons xs -> PathMap as m (insertPolyMap xs (\v vs -> action (HCons v vs)) pm)
insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a)
insertPathMap (RouteHandle path action) = insertPathMap' path (hListUncurry action)
match :: PathMap x -> [T.Text] -> [x]
match (PathMap as _ _) [] = as
match (PathMap _ m pm) (pp:pps) =
let staticMatches = maybeToList (HM.lookup pp m) >>= flip match pps
varMatches = lookupPolyMap pp pps pm
in staticMatches ++ varMatches
var :: (Typeable a, PathPiece a) => Path (a ': '[])
var = VarCons Empty
type Var a = Path (a ': '[])
static :: String -> Path '[]
static s = StaticCons (T.pack s) Empty
instance (a ~ '[]) => IsString (Path a) where
fromString = static
root :: Path '[]
root = Empty
(</>) :: Path as -> Path bs -> Path (HAppendList as bs)
(</>) Empty xs = xs
(</>) (StaticCons pathPiece xs) ys = (StaticCons pathPiece (xs </> ys))
(</>) (VarCons xs) ys = (VarCons (xs </> ys))
renderRoute :: Path as -> HList as -> T.Text
renderRoute p h =
T.intercalate "/" $ renderRoute' p h
renderRoute' :: Path as -> HList as -> [T.Text]
renderRoute' Empty _ = []
renderRoute' (StaticCons pathPiece pathXs) paramXs =
( pathPiece : renderRoute' pathXs paramXs )
renderRoute' (VarCons pathXs) (HCons val paramXs) =
( toPathPiece val : renderRoute' pathXs paramXs)
renderRoute' _ _ =
error "This will never happen."
parse :: Path as -> [T.Text] -> Maybe (HList as)
parse Empty [] = Just HNil
parse _ [] = Nothing
parse path (pathComp : xs) =
case path of
Empty -> Nothing
StaticCons pathPiece pathXs ->
if pathPiece == pathComp
then parse pathXs xs
else Nothing
VarCons pathXs ->
case fromPathPiece pathComp of
Nothing -> Nothing
Just val ->
let finish = parse pathXs xs
in fmap (\parsedXs -> HCons val parsedXs) finish