module WebGear.Core.Trait.Path (
Path (..),
PathVar (..),
PathVarError (..),
PathEnd (..),
path,
pathVar,
pathEnd,
match,
route,
) where
import Control.Arrow (ArrowChoice (..), (>>>))
import Control.Arrow.Operations (ArrowError)
import Data.Function ((&))
import Data.Kind (Type)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty (..), filter, toList)
import Data.Text (Text)
import GHC.TypeLits (Symbol)
import Language.Haskell.TH (appE, conE)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Exp (..), Lit (..), Q, TyLit (StrTyLit), Type (..), mkName)
import WebGear.Core.Handler (Middleware, RouteMismatch, routeMismatch)
import WebGear.Core.Request (Request)
import WebGear.Core.Trait (Get, Trait (..), TraitAbsence (..), probe)
import WebGear.Core.Trait.Method (method)
import Prelude hiding (drop, filter, take)
newtype Path = Path Text
instance Trait Path Request where
type Attribute Path Request = ()
instance TraitAbsence Path Request where
type Absence Path Request = ()
data PathVar (tag :: Symbol) (val :: Data.Kind.Type) = PathVar
data PathVarError = PathVarNotFound | PathVarParseError Text
deriving stock (PathVarError -> PathVarError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathVarError -> PathVarError -> Bool
$c/= :: PathVarError -> PathVarError -> Bool
== :: PathVarError -> PathVarError -> Bool
$c== :: PathVarError -> PathVarError -> Bool
Eq, Int -> PathVarError -> ShowS
[PathVarError] -> ShowS
PathVarError -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathVarError] -> ShowS
$cshowList :: [PathVarError] -> ShowS
show :: PathVarError -> String
$cshow :: PathVarError -> String
showsPrec :: Int -> PathVarError -> ShowS
$cshowsPrec :: Int -> PathVarError -> ShowS
Show, ReadPrec [PathVarError]
ReadPrec PathVarError
Int -> ReadS PathVarError
ReadS [PathVarError]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PathVarError]
$creadListPrec :: ReadPrec [PathVarError]
readPrec :: ReadPrec PathVarError
$creadPrec :: ReadPrec PathVarError
readList :: ReadS [PathVarError]
$creadList :: ReadS [PathVarError]
readsPrec :: Int -> ReadS PathVarError
$creadsPrec :: Int -> ReadS PathVarError
Read)
instance Trait (PathVar tag val) Request where
type Attribute (PathVar tag val) Request = val
instance TraitAbsence (PathVar tag val) Request where
type Absence (PathVar tag val) Request = PathVarError
data PathEnd = PathEnd
instance Trait PathEnd Request where
type Attribute PathEnd Request = ()
instance TraitAbsence PathEnd Request where
type Absence PathEnd Request = ()
path ::
(Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Text ->
Middleware h req (Path : req)
path :: forall (h :: * -> * -> *) (req :: [*]).
(Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Text -> Middleware h req (Path : req)
path Text
s RequestHandler h (Path : req)
nextHandler = forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe (Text -> Path
Path Text
s) forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (Path : req)
nextHandler
pathVar ::
forall tag val h req.
(Get h (PathVar tag val) Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Middleware h req (PathVar tag val : req)
pathVar :: forall (tag :: Symbol) val (h :: * -> * -> *) (req :: [*]).
(Get h (PathVar tag val) Request, ArrowChoice h,
ArrowError RouteMismatch h) =>
Middleware h req (PathVar tag val : req)
pathVar RequestHandler h (PathVar tag val : req)
nextHandler = forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe forall (tag :: Symbol) val. PathVar tag val
PathVar forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (PathVar tag val : req)
nextHandler
pathEnd ::
(Get h PathEnd Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Middleware h req (PathEnd : req)
pathEnd :: forall (h :: * -> * -> *) (req :: [*]).
(Get h PathEnd Request, ArrowChoice h,
ArrowError RouteMismatch h) =>
Middleware h req (PathEnd : req)
pathEnd RequestHandler h (PathEnd : req)
nextHandler = forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe PathEnd
PathEnd forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (PathEnd : req)
nextHandler
match :: QuasiQuoter
match :: QuasiQuoter
match =
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
toMatchExp
, quotePat :: String -> Q Pat
quotePat = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a pattern"
, quoteType :: String -> Q Type
quoteType = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a type"
, quoteDec :: String -> Q [Dec]
quoteDec = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a declaration"
}
route :: QuasiQuoter
route :: QuasiQuoter
route =
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
toRouteExp
, quotePat :: String -> Q Pat
quotePat = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a pattern"
, quoteType :: String -> Q Type
quoteType = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a type"
, quoteDec :: String -> Q [Dec]
quoteDec = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a declaration"
}
toRouteExp :: String -> Q Exp
toRouteExp :: String -> Q Exp
toRouteExp String
s = do
Exp
e <- String -> Q Exp
toMatchExp String
s
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
compose Exp
e (Name -> Exp
VarE 'pathEnd)
toMatchExp :: String -> Q Exp
toMatchExp :: String -> Q Exp
toMatchExp String
s = case String -> [String]
List.words String
s of
[Item [String]
m, Item [String]
p] -> String -> String -> Q Exp
toMethodAndPathExps Item [String]
m Item [String]
p
[Item [String]
p] -> do
[Exp]
pathExps <- String -> Q [Exp]
toPathExps Item [String]
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose [Exp]
pathExps
[String]
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected an HTTP method and a path or just a path"
where
toMethodAndPathExps :: String -> String -> Q Exp
toMethodAndPathExps :: String -> String -> Q Exp
toMethodAndPathExps String
m String
p = do
Exp
methodExp <- [|method|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
m)
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
p
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose forall a b. (a -> b) -> a -> b
$ Exp
methodExp forall a. a -> [a] -> NonEmpty a
:| [Exp]
pathExps
toPathExps :: String -> Q [Exp]
toPathExps :: String -> Q [Exp]
toPathExps String
p =
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
'/' String
p
forall a b. a -> (a -> b) -> b
& forall a. (a -> Bool) -> NonEmpty a -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
"")
forall a b. a -> (a -> b) -> b
& forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
':')
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath []
forall a b. a -> (a -> b) -> b
& forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM NonEmpty String -> Q Exp
toPathExp
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath NonEmpty String
p [] = [NonEmpty String
p]
joinPath (String
p :| []) ((String
p' :| []) : [NonEmpty String]
xs) = ((String
p forall a. Semigroup a => a -> a -> a
<> String
"/" forall a. Semigroup a => a -> a -> a
<> String
p') forall a. a -> [a] -> NonEmpty a
:| []) forall a. a -> [a] -> [a]
: [NonEmpty String]
xs
joinPath NonEmpty String
y (NonEmpty String
x : [NonEmpty String]
xs) = NonEmpty String
y forall a. a -> [a] -> [a]
: NonEmpty String
x forall a. a -> [a] -> [a]
: [NonEmpty String]
xs
toPathExp :: NonEmpty String -> Q Exp
toPathExp :: NonEmpty String -> Q Exp
toPathExp (String
p :| []) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'path) (Lit -> Exp
LitE forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
p)
toPathExp (String
v :| [Item [String]
t]) = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
AppTypeE (Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'pathVar) (TyLit -> Type
LitT forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit String
v)) (Name -> Type
ConT forall a b. (a -> b) -> a -> b
$ String -> Name
mkName Item [String]
t)
toPathExp NonEmpty String
xs = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Invalid path component: " forall a. Semigroup a => a -> a -> a
<> forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" (forall a. NonEmpty a -> [a]
toList NonEmpty String
xs)
compose :: Exp -> Exp -> Exp
compose :: Exp -> Exp -> Exp
compose Exp
l = Exp -> Exp -> Exp -> Exp
UInfixE Exp
l (Name -> Exp
VarE forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
".")
splitOn :: Eq a => a -> [a] -> NonEmpty [a]
splitOn :: forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn a
sep = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> NonEmpty [a] -> NonEmpty [a]
f ([] forall a. a -> [a] -> NonEmpty a
:| [])
where
f :: a -> NonEmpty [a] -> NonEmpty [a]
f a
x NonEmpty [a]
acc | a
x forall a. Eq a => a -> a -> Bool
== a
sep = [] forall a. a -> [a] -> NonEmpty a
:| forall a. NonEmpty a -> [a]
toList NonEmpty [a]
acc
f a
x ([a]
y :| [[a]]
ys) = (a
x forall a. a -> [a] -> [a]
: [a]
y) forall a. a -> [a] -> NonEmpty a
:| [[a]]
ys