module WebGear.Middlewares.Path
( path
, pathVar
, match
) where
import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Data.Function ((&))
import Data.List.NonEmpty (NonEmpty (..), toList)
import GHC.TypeLits (KnownSymbol)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Exp (..), Q, TyLit (..), Type (..), mkName)
import Web.HttpApiData (FromHttpApiData)
import WebGear.Middlewares.Method (method)
import WebGear.Route (MonadRouter (..))
import WebGear.Trait (linkplus)
import WebGear.Trait.Path (Path, PathVar)
import WebGear.Types (RequestMiddleware)
import WebGear.Util (splitOn)
import qualified Data.List as List
path :: forall s ts res m a. (KnownSymbol s, MonadRouter m)
=> RequestMiddleware m ts (Path s:ts) res a
path :: RequestMiddleware m ts (Path s : ts) res a
path handler :: Handler m (Path s : ts) res a
handler = (Linked ts Request -> m (Linked res (Response a)))
-> Kleisli m (Linked ts Request) (Linked res (Response a))
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Linked res (Response a)))
-> Kleisli m (Linked ts Request) (Linked res (Response a)))
-> (Linked ts Request -> m (Linked res (Response a)))
-> Kleisli m (Linked ts Request) (Linked res (Response a))
forall a b. (a -> b) -> a -> b
$
forall t a (m :: * -> *) (ts :: [*]).
Trait t a m =>
Linked ts a -> m (Either (Fail t a) (Linked (t : ts) a))
forall a (m :: * -> *) (ts :: [*]).
Trait (Path s) a m =>
Linked ts a
-> m (Either (Fail (Path s) a) (Linked (Path s : ts) a))
linkplus @(Path s) (Linked ts Request -> m (Either () (Linked (Path s : ts) Request)))
-> (Either () (Linked (Path s : ts) Request)
-> m (Linked res (Response a)))
-> Linked ts Request
-> m (Linked res (Response a))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (() -> m (Linked res (Response a)))
-> (Linked (Path s : ts) Request -> m (Linked res (Response a)))
-> Either () (Linked (Path s : ts) Request)
-> m (Linked res (Response a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Linked res (Response a)) -> () -> m (Linked res (Response a))
forall a b. a -> b -> a
const m (Linked res (Response a))
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler m (Path s : ts) res a
-> Linked (Path s : ts) Request -> m (Linked res (Response a))
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler m (Path s : ts) res a
handler)
pathVar :: forall tag val ts res m a. (FromHttpApiData val, MonadRouter m)
=> RequestMiddleware m ts (PathVar tag val:ts) res a
pathVar :: RequestMiddleware m ts (PathVar tag val : ts) res a
pathVar handler :: Handler m (PathVar tag val : ts) res a
handler = (Linked ts Request -> m (Linked res (Response a)))
-> Kleisli m (Linked ts Request) (Linked res (Response a))
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Linked res (Response a)))
-> Kleisli m (Linked ts Request) (Linked res (Response a)))
-> (Linked ts Request -> m (Linked res (Response a)))
-> Kleisli m (Linked ts Request) (Linked res (Response a))
forall a b. (a -> b) -> a -> b
$
forall t a (m :: * -> *) (ts :: [*]).
Trait t a m =>
Linked ts a -> m (Either (Fail t a) (Linked (t : ts) a))
forall a (m :: * -> *) (ts :: [*]).
Trait (PathVar tag val) a m =>
Linked ts a
-> m (Either
(Fail (PathVar tag val) a) (Linked (PathVar tag val : ts) a))
linkplus @(PathVar tag val) (Linked ts Request
-> m (Either PathVarFail (Linked (PathVar tag val : ts) Request)))
-> (Either PathVarFail (Linked (PathVar tag val : ts) Request)
-> m (Linked res (Response a)))
-> Linked ts Request
-> m (Linked res (Response a))
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (PathVarFail -> m (Linked res (Response a)))
-> (Linked (PathVar tag val : ts) Request
-> m (Linked res (Response a)))
-> Either PathVarFail (Linked (PathVar tag val : ts) Request)
-> m (Linked res (Response a))
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Linked res (Response a))
-> PathVarFail -> m (Linked res (Response a))
forall a b. a -> b -> a
const m (Linked res (Response a))
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler m (PathVar tag val : ts) res a
-> Linked (PathVar tag val : ts) Request
-> m (Linked res (Response a))
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler m (PathVar tag val : ts) res a
handler)
match :: QuasiQuoter
match :: QuasiQuoter
match = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter
{ quoteExp :: String -> Q Exp
quoteExp = String -> Q Exp
toExp
, 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 (m :: * -> *) a. MonadFail m => String -> m a
fail "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 (m :: * -> *) a. MonadFail m => String -> m a
fail "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 (m :: * -> *) a. MonadFail m => String -> m a
fail "match cannot be used in a declaration"
}
where
toExp :: String -> Q Exp
toExp :: String -> Q Exp
toExp s :: String
s = case String -> [String]
List.words String
s of
[m :: String
m, p :: String
p] -> do
let methodExp :: Exp
methodExp = Exp -> Type -> Exp
AppTypeE (Name -> Exp
VarE 'method) (Name -> Type
ConT (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
m)
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
p
pure $ (Exp -> Exp -> Exp) -> NonEmpty Exp -> Exp
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
[p :: String
p] -> do
[Exp]
pathExps <- String -> Q [Exp]
toPathExps String
p
pure $ (Exp -> Exp -> Exp) -> [Exp] -> Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose [Exp]
pathExps
_ -> String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "match expects an HTTP method and a path or just a path"
toPathExps :: String -> Q [Exp]
toPathExps :: String -> Q [Exp]
toPathExps p :: String
p = Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn '/' String
p
NonEmpty String
-> (NonEmpty String -> NonEmpty (NonEmpty String))
-> NonEmpty (NonEmpty String)
forall a b. a -> (a -> b) -> b
& (String -> NonEmpty String)
-> NonEmpty String -> NonEmpty (NonEmpty String)
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 ':')
NonEmpty (NonEmpty String)
-> (NonEmpty (NonEmpty String) -> [NonEmpty String])
-> [NonEmpty String]
forall a b. a -> (a -> b) -> b
& (NonEmpty String -> [NonEmpty String] -> [NonEmpty String])
-> [NonEmpty String]
-> NonEmpty (NonEmpty String)
-> [NonEmpty String]
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty String -> Q Exp
toPathExp
[Q Exp] -> ([Q Exp] -> Q [Exp]) -> Q [Exp]
forall a b. a -> (a -> b) -> b
& [Q Exp] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath s :: NonEmpty String
s [] = [NonEmpty String
s]
joinPath (s :: String
s:|[]) ((s' :: String
s':|[]) : xs :: [NonEmpty String]
xs) = ((String
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "/" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s') 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 y :: NonEmpty String
y (x :: NonEmpty String
x:xs :: [NonEmpty String]
xs) = NonEmpty String
yNonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
:NonEmpty String
xNonEmpty String -> [NonEmpty String] -> [NonEmpty String]
forall a. a -> [a] -> [a]
:[NonEmpty String]
xs
toPathExp :: NonEmpty String -> Q Exp
toPathExp :: NonEmpty String -> Q Exp
toPathExp (p :: String
p :| []) = Exp -> Q Exp
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 (Name -> Exp
VarE 'path) (TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit String
p)
toPathExp (v :: String
v :| [t :: String
t]) = Exp -> Q Exp
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
t)
toPathExp xs :: NonEmpty String
xs = String -> Q Exp
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ "Invalid path component: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate ":" (NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
toList NonEmpty String
xs)
compose :: Exp -> Exp -> Exp
compose :: Exp -> Exp -> Exp
compose l :: 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 ".")