SafeRouting.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Web.Routing.SafeRouting where

#if MIN_VERSION_base(4,11,0)
#elif MIN_VERSION_base(4,9,0)
import Data.Semigroup
#elif MIN_VERSION_base(4,8,0)
import Data.Monoid ((<>))
#else
import Control.Applicative ((<$>))
import Data.Monoid (Monoid (..), (<>))
#endif
import Control.DeepSeq (NFData (..))
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))

newtype HVectElim' x ts = HVectElim' {flipHVectElim :: HVectElim ts x}

type Registry m a = (PathMap (m a), [[T.Text] -> m a])

emptyRegistry :: Registry m a
emptyRegistry = (emptyPathMap, [])

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
  )

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'

data PathInternal (as :: [*]) where
  PI_Empty :: PathInternal '[] -- the empty path
  PI_StaticCons :: T.Text -> PathInternal as -> PathInternal as -- append a static path piece to path
  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]
  }

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)

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

emptyPathMap :: PathMap x
emptyPathMap = PathMap mempty mempty mempty PM.empty mempty

instance Semigroup (PathMap x) where
  (PathMap c1 h1 s1 p1 w1) <> (PathMap c2 h2 s2 p2 w2) =
    PathMap (c1 <> c2) (h1 <> h2) (HM.unionWith (<>) s1 s2) (PM.unionWith (<>) p1 p2) (w1 <> w2)

instance Monoid (PathMap x) where
  mempty = emptyPathMap
  mappend = (<>)

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
    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
    PI_Wildcard PI_Empty ->
      let (PathMap _ (action' : _) _ _ _) = updateFn (\ctx rest -> action (rest :&: HNil) ctx) emptyPathMap
       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)

singleton :: PathInternal ts -> HVectElim ts x -> PathMap x
singleton path action = insertPathMap' path (HV.uncurry action) mempty

insertPathMap :: RouteHandle m a -> PathMap (m a) -> PathMap (m a)
insertPathMap (RouteHandle path action) = insertPathMap' path (HV.uncurry action)

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

insertSubComponent :: Functor m => RouteHandle m ([T.Text] -> a) -> PathMap (m a) -> PathMap (m a)
insertSubComponent (RouteHandle path comp) =
  insertSubComponent' path (fmap (\m ps -> fmap ($ ps) m) (HV.uncurry comp))

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

(</!>) :: PathInternal as -> PathInternal bs -> PathInternal (Append as bs)
(</!>) PI_Empty xs = xs
(</!>) (PI_StaticCons pathPiece xs) ys = PI_StaticCons pathPiece (xs </!> ys)
(</!>) (PI_VarCons xs) ys = PI_VarCons (xs </!> ys)
(</!>) (PI_Wildcard _) _ = error "Shouldn't happen"

combineRoutePieces :: [T.Text] -> T.Text
combineRoutePieces = T.intercalate "/"

parse :: PathInternal as -> [T.Text] -> Maybe (HVect as)
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"