module Network.Routing
( Method
, Path
, root
, exact
, action
, Raw
, raw
, fetch
, any
, rest
, Router
, empty
, insert, (+|)
, execute
, module Network.Routing.Dict
) where
import Prelude hiding(any)
import Control.Monad(MonadPlus(..))
import Network.Routing.Compat(KnownSymbol, symbolVal)
import qualified Network.Routing.Dict.Internal as D
import qualified Data.Text as T
import qualified Data.HashMap.Strict as H
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as SC
import Network.Routing.Dict
( Store
, type (</)
, add
, Dict
, Member
, get
, KV(..)
, Members
)
type Method = S.ByteString
data Params d m a where
PCons :: (D.Store d -> [T.Text] -> m (D.Store d', [T.Text]))
-> Router d' m a
-> Params d m a -> Params d m a
PNil :: Params d m a
data Path d m a where
Exact :: T.Text -> Path d m a -> Path d m a
Param :: String -> (D.Store d -> [T.Text] -> m (D.Store d', [T.Text]))
-> Path d' m a -> Path d m a
Action :: Maybe Method
-> (D.Dict d -> m a) -> Path d m a
root :: Path '[] m a -> Path '[] m a
root = id
exact :: T.Text -> Path d m a -> Path d m a
exact = Exact
type Raw m d d'
= D.Store d
-> [T.Text]
-> m (D.Store d', [T.Text])
raw :: String
-> Raw m d d'
-> Path d' m a -> Path d m a
raw = Param
fetch :: (MonadPlus m, KnownSymbol k, k D.</ d)
=> proxy k
-> (T.Text -> Maybe v)
-> Path (k D.:= v ': d) m a -> Path d m a
fetch p f = Param (':' : symbolVal p) go
where
go _ [] = mzero
go d (t:ts) = case f t of
Nothing -> mzero
Just v -> return (D.add p v d, ts)
any :: Monad m => Path d m a -> Path d m a
any = Param "**" go
where
go d _ = return (d, [])
rest :: (KnownSymbol k, Monad m, k D.</ d) => proxy k
-> Path (k D.:= [T.Text] ': d) m a -> Path d m a
rest k = Param (':': symbolVal k ++ "**") go
where
go d r = return (D.add k r d, [])
action :: Maybe Method
-> (D.Dict d -> m a)
-> Path d m a
action = Action
instance Show (Path d m a) where
show = go id
where
go :: (String -> String) -> Path d m a -> String
go s (Exact t ps) = go (s . (++) ('/' : T.unpack t)) ps
go s (Param l _ ps) = go (s . (++) ('/': l)) ps
go s (Action m _) = maybe "*" SC.unpack m ++ ' ': s []
data Router d m a where
Router ::
{ params :: Params d m a
, children :: H.HashMap T.Text (Router d m a)
, methods :: H.HashMap Method (D.Dict d -> m a)
, anyMethod :: D.Dict d -> m a
} -> Router d m a
emptyRouter :: MonadPlus m => Router d m a
emptyRouter = Router { params = PNil
, children = H.empty
, methods = H.empty
, anyMethod = const mzero
}
empty :: MonadPlus m => Router '[] m a
empty = emptyRouter
add' :: MonadPlus m => Path d m a -> Router d m a -> Router d m a
add' (Exact p n) r =
let c = H.lookupDefault emptyRouter p (children r)
in r { children = H.insert p (add' n c) (children r) }
add' (Param _ f n) Router{..} = Router
{ params = PCons f (add' n emptyRouter) params
, children = children
, methods = methods
, anyMethod = anyMethod
}
add' (Action (Just m) n) r =
let c = case H.lookup m (methods r) of
Nothing -> \d -> n d
Just p -> \d -> p d `mplus` n d
in r { methods = H.insert m c (methods r) }
add' (Action Nothing n) r =
r { anyMethod = \d -> anyMethod r d `mplus` n d }
insert :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a
insert = add'
(+|) :: MonadPlus m => Path '[] m a -> Router '[] m a -> Router '[] m a
(+|) = insert
infixr `insert`
infixr +|
execute :: MonadPlus m => Router '[] m a -> Method -> [T.Text] -> m a
execute = execute' D.emptyStore
execute' :: MonadPlus m => D.Store d -> Router d m a -> Method -> [T.Text] -> m a
execute' d Router{params, methods, anyMethod} m [] = fetching d m [] params `mplus`
case H.lookup m methods of
Nothing -> anyMethod (D.mkDict d)
Just f -> f (D.mkDict d)
execute' d Router{params, children} m pps@(p:ps) = child `mplus` fetching d m pps params
where
child = case H.lookup p children of
Nothing -> mzero
Just c -> execute' d c m ps
fetching :: MonadPlus m => D.Store d -> Method -> [T.Text] -> Params d m a -> m a
fetching d m pps = loop
where
loop PNil = mzero
loop (PCons f r o) =
do (d', pps') <- f d pps
execute' d' r m pps'
`mplus` loop o