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, Prerequisite, 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 = ()
type instance Prerequisite Path ts Request = ()
data PathVar (tag :: Symbol) (val :: Data.Kind.Type) = PathVar
data PathVarError = PathVarNotFound | PathVarParseError Text
deriving stock (PathVarError -> PathVarError -> Bool
(PathVarError -> PathVarError -> Bool)
-> (PathVarError -> PathVarError -> Bool) -> Eq PathVarError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PathVarError -> PathVarError -> Bool
== :: PathVarError -> PathVarError -> Bool
$c/= :: PathVarError -> PathVarError -> Bool
/= :: PathVarError -> PathVarError -> Bool
Eq, Int -> PathVarError -> ShowS
[PathVarError] -> ShowS
PathVarError -> String
(Int -> PathVarError -> ShowS)
-> (PathVarError -> String)
-> ([PathVarError] -> ShowS)
-> Show PathVarError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PathVarError -> ShowS
showsPrec :: Int -> PathVarError -> ShowS
$cshow :: PathVarError -> String
show :: PathVarError -> String
$cshowList :: [PathVarError] -> ShowS
showList :: [PathVarError] -> ShowS
Show, ReadPrec [PathVarError]
ReadPrec PathVarError
Int -> ReadS PathVarError
ReadS [PathVarError]
(Int -> ReadS PathVarError)
-> ReadS [PathVarError]
-> ReadPrec PathVarError
-> ReadPrec [PathVarError]
-> Read PathVarError
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS PathVarError
readsPrec :: Int -> ReadS PathVarError
$creadList :: ReadS [PathVarError]
readList :: ReadS [PathVarError]
$creadPrec :: ReadPrec PathVarError
readPrec :: ReadPrec PathVarError
$creadListPrec :: ReadPrec [PathVarError]
readListPrec :: ReadPrec [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
type instance Prerequisite (PathVar tag val) ts Request = ()
data PathEnd = PathEnd
instance Trait PathEnd Request where
type Attribute PathEnd Request = ()
instance TraitAbsence PathEnd Request where
type Absence PathEnd Request = ()
type instance Prerequisite PathEnd ts Request = ()
path ::
(Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Text ->
Middleware h ts (Path : ts)
path :: forall (h :: * -> * -> *) (ts :: [*]).
(Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Text -> Middleware h ts (Path : ts)
path Text
s RequestHandler h (Path : ts)
nextHandler = Path
-> h (With Request ts)
(Either (Absence Path Request) (With Request (Path : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe (Text -> Path
Path Text
s) h (With Request ts) (Either () (With Request (Path : ts)))
-> h (Either () (With Request (Path : ts))) Response
-> h (With Request ts) Response
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> h () Response
forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch h () Response
-> RequestHandler h (Path : ts)
-> h (Either () (With Request (Path : ts))) Response
forall b d c. h b d -> h c d -> h (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (Path : ts)
nextHandler
{-# INLINE path #-}
pathVar ::
forall tag val h ts.
(Get h (PathVar tag val) Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Middleware h ts (PathVar tag val : ts)
pathVar :: forall (tag :: Symbol) val (h :: * -> * -> *) (ts :: [*]).
(Get h (PathVar tag val) Request, ArrowChoice h,
ArrowError RouteMismatch h) =>
Middleware h ts (PathVar tag val : ts)
pathVar RequestHandler h (PathVar tag val : ts)
nextHandler = PathVar tag val
-> h (With Request ts)
(Either
(Absence (PathVar tag val) Request)
(With Request (PathVar tag val : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe PathVar tag val
forall (tag :: Symbol) val. PathVar tag val
PathVar h (With Request ts)
(Either PathVarError (With Request (PathVar tag val : ts)))
-> h (Either PathVarError (With Request (PathVar tag val : ts)))
Response
-> h (With Request ts) Response
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> h PathVarError Response
forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch h PathVarError Response
-> RequestHandler h (PathVar tag val : ts)
-> h (Either PathVarError (With Request (PathVar tag val : ts)))
Response
forall b d c. h b d -> h c d -> h (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (PathVar tag val : ts)
nextHandler
{-# INLINE pathVar #-}
pathEnd ::
(Get h PathEnd Request, ArrowChoice h, ArrowError RouteMismatch h) =>
Middleware h ts (PathEnd : ts)
pathEnd :: forall (h :: * -> * -> *) (ts :: [*]).
(Get h PathEnd Request, ArrowChoice h,
ArrowError RouteMismatch h) =>
Middleware h ts (PathEnd : ts)
pathEnd RequestHandler h (PathEnd : ts)
nextHandler = PathEnd
-> h (With Request ts)
(Either (Absence PathEnd Request) (With Request (PathEnd : ts)))
forall t (ts :: [*]) (h :: * -> * -> *) a.
(Get h t a, Prerequisite t ts a) =>
t -> h (With a ts) (Either (Absence t a) (With a (t : ts)))
probe PathEnd
PathEnd h (With Request ts) (Either () (With Request (PathEnd : ts)))
-> h (Either () (With Request (PathEnd : ts))) Response
-> h (With Request ts) Response
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> h () Response
forall (h :: * -> * -> *) a b. ArrowError RouteMismatch h => h a b
routeMismatch h () Response
-> RequestHandler h (PathEnd : ts)
-> h (Either () (With Request (PathEnd : ts))) Response
forall b d c. h b d -> h c d -> h (Either b c) d
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (PathEnd : ts)
nextHandler
{-# INLINE pathEnd #-}
match :: QuasiQuoter
match :: QuasiQuoter
match =
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
toMatchExp
, quotePat :: String -> Q Pat
quotePat = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a pattern"
, quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a type"
, quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. String -> Q a
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 = Q Pat -> String -> Q Pat
forall a b. a -> b -> a
const (Q Pat -> String -> Q Pat) -> Q Pat -> String -> Q Pat
forall a b. (a -> b) -> a -> b
$ String -> Q Pat
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a pattern"
, quoteType :: String -> Q Type
quoteType = Q Type -> String -> Q Type
forall a b. a -> b -> a
const (Q Type -> String -> Q Type) -> Q Type -> String -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Q Type
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"route cannot be used in a type"
, quoteDec :: String -> Q [Dec]
quoteDec = Q [Dec] -> String -> Q [Dec]
forall a b. a -> b -> a
const (Q [Dec] -> String -> Q [Dec]) -> Q [Dec] -> String -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ String -> Q [Dec]
forall a. String -> Q a
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
Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
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 String
Item [String]
m String
Item [String]
p
[Item [String]
p] -> do
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
Item [String]
p
Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose [Exp]
pathExps
[String]
_ -> String -> Q Exp
forall a. String -> Q a
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|] Q Exp -> Q Exp -> Q Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (String -> Name
mkName String
m)
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
p
Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Exp -> Exp) -> NonEmpty Exp -> Exp
forall a. (a -> a -> a) -> NonEmpty a -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose (NonEmpty Exp -> Exp) -> NonEmpty Exp -> Exp
forall a b. (a -> b) -> a -> b
$ Exp
methodExp Exp -> [Exp] -> NonEmpty Exp
forall a. a -> [a] -> NonEmpty a
:| [Exp]
pathExps
toPathExps :: String -> Q [Exp]
toPathExps :: String -> Q [Exp]
toPathExps String
p =
Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
'/' String
p
NonEmpty String -> (NonEmpty String -> [String]) -> [String]
forall a b. a -> (a -> b) -> b
& (String -> Bool) -> NonEmpty String -> [String]
forall a. (a -> Bool) -> NonEmpty a -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"")
[String] -> ([String] -> [NonEmpty String]) -> [NonEmpty String]
forall a b. a -> (a -> b) -> b
& (String -> NonEmpty String) -> [String] -> [NonEmpty String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
':')
[NonEmpty String]
-> ([NonEmpty String] -> [NonEmpty String]) -> [NonEmpty String]
forall a b. a -> (a -> b) -> b
& (NonEmpty String -> [NonEmpty String] -> [NonEmpty String])
-> [NonEmpty String] -> [NonEmpty String] -> [NonEmpty String]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
List.foldr NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath []
[NonEmpty String] -> ([NonEmpty String] -> Q [Exp]) -> Q [Exp]
forall a b. a -> (a -> b) -> b
& (NonEmpty String -> Q Exp) -> [NonEmpty String] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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
Item [NonEmpty String]
p]
joinPath (String
p :| []) ((String
p' :| []) : [NonEmpty String]
xs) = ((String
p String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"/" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
p') String -> [String] -> NonEmpty String
forall a. a -> [a] -> NonEmpty a
:| []) NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
: [NonEmpty String]
xs
joinPath NonEmpty String
y (NonEmpty String
x : [NonEmpty String]
xs) = NonEmpty String
y NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
: NonEmpty String
x NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
: [NonEmpty String]
xs
toPathExp :: NonEmpty String -> Q Exp
toPathExp :: NonEmpty String -> Q Exp
toPathExp (String
p :| []) = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Exp -> Exp
AppE (Name -> Exp
VarE 'path) (Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
p)
toPathExp (String
v :| [Item [String]
t]) = Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> Type -> Exp
AppTypeE (Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'pathVar) (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit String
v)) (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
Item [String]
t)
toPathExp NonEmpty String
xs = String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Invalid path component: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
":" (NonEmpty String -> [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 (Name -> Exp) -> Name -> Exp
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 = (a -> NonEmpty [a] -> NonEmpty [a])
-> NonEmpty [a] -> [a] -> NonEmpty [a]
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr a -> NonEmpty [a] -> NonEmpty [a]
f ([] [a] -> [[a]] -> NonEmpty [a]
forall a. a -> [a] -> NonEmpty a
:| [])
where
f :: a -> NonEmpty [a] -> NonEmpty [a]
f a
x NonEmpty [a]
acc | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
sep = [] [a] -> [[a]] -> NonEmpty [a]
forall a. a -> [a] -> NonEmpty a
:| NonEmpty [a] -> [[a]]
forall a. NonEmpty a -> [a]
toList NonEmpty [a]
acc
f a
x ([a]
y :| [[a]]
ys) = (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
y) [a] -> [[a]] -> NonEmpty [a]
forall a. a -> [a] -> NonEmpty a
:| [[a]]
ys