module WebGear.Middlewares.Path
( Path
, PathVar
, PathVarError (..)
, PathEnd
, path
, pathVar
, pathEnd
, match
, route
) where
import Control.Arrow (Kleisli (..))
import Control.Monad ((>=>))
import Control.Monad.State.Strict (MonadState (..))
import Data.Foldable (toList)
import Data.Function ((&))
import Data.List.NonEmpty (NonEmpty (..), filter)
import Data.Proxy (Proxy (..))
import Data.Text (Text, pack)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax (Exp (..), Q, TyLit (..), Type (..), mkName)
import Prelude hiding (drop, filter, take)
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Middlewares.Method (method)
import WebGear.Trait (Result (..), Trait (..), probe)
import WebGear.Types (MonadRouter (..), PathInfo (..), Request, RequestMiddleware')
import WebGear.Util (splitOn)
import qualified Data.List as List
data Path (s :: Symbol)
instance (KnownSymbol s, MonadState PathInfo m) => Trait (Path s) Request m where
type Attribute (Path s) Request = ()
type Absence (Path s) Request = ()
toAttribute :: Request -> m (Result (Path s) Request)
toAttribute _ = do
PathInfo actualPath <- get
case List.stripPrefix expectedPath actualPath of
Nothing -> pure $ NotFound ()
Just rest -> do
put $ PathInfo rest
pure $ Found ()
where
expectedPath = Proxy @s
& symbolVal
& splitOn '/'
& filter (/= "")
& map pack
data PathVar tag val
data PathVarError = PathVarNotFound | PathVarParseError Text
deriving (Eq, Show, Read)
instance (FromHttpApiData val, MonadState PathInfo m) => Trait (PathVar tag val) Request m where
type Attribute (PathVar tag val) Request = val
type Absence (PathVar tag val) Request = PathVarError
toAttribute :: Request -> m (Result (PathVar tag val) Request)
toAttribute _ = do
PathInfo actualPath <- get
case actualPath of
[] -> pure $ NotFound PathVarNotFound
(x:xs) -> case parseUrlPiece @val x of
Left e -> pure $ NotFound $ PathVarParseError e
Right v -> do
put $ PathInfo xs
pure $ Found v
data PathEnd
instance MonadState PathInfo m => Trait PathEnd Request m where
type Attribute PathEnd Request = ()
type Absence PathEnd Request = ()
toAttribute :: Request -> m (Result PathEnd Request)
toAttribute _ = do
PathInfo actualPath <- get
pure $ if null actualPath
then Found ()
else NotFound ()
path :: forall s ts m a. (KnownSymbol s, MonadRouter m)
=> RequestMiddleware' m ts (Path s:ts) a
path handler = Kleisli $
probe @(Path s) >=> either (const rejectRoute) (runKleisli handler)
pathVar :: forall tag val ts m a. (FromHttpApiData val, MonadRouter m)
=> RequestMiddleware' m ts (PathVar tag val:ts) a
pathVar handler = Kleisli $
probe @(PathVar tag val) >=> either (const rejectRoute) (runKleisli handler)
pathEnd :: MonadRouter m => RequestMiddleware' m ts (PathEnd:ts) a
pathEnd handler = Kleisli $
probe @PathEnd >=> either (const rejectRoute) (runKleisli handler)
match :: QuasiQuoter
match = QuasiQuoter
{ quoteExp = toMatchExp
, quotePat = const $ fail "match cannot be used in a pattern"
, quoteType = const $ fail "match cannot be used in a type"
, quoteDec = const $ fail "match cannot be used in a declaration"
}
route :: QuasiQuoter
route = QuasiQuoter
{ quoteExp = toRouteExp
, quotePat = const $ fail "route cannot be used in a pattern"
, quoteType = const $ fail "route cannot be used in a type"
, quoteDec = const $ fail "route cannot be used in a declaration"
}
toRouteExp :: String -> Q Exp
toRouteExp s = do
e <- toMatchExp s
pure $ compose e (VarE 'pathEnd)
toMatchExp :: String -> Q Exp
toMatchExp s = case List.words s of
[m, p] -> do
let methodExp = AppTypeE (VarE 'method) (ConT $ mkName m)
pathExps <- toPathExps p
pure $ List.foldr1 compose $ methodExp :| pathExps
[p] -> do
pathExps <- toPathExps p
pure $ List.foldr1 compose pathExps
_ -> fail "Expected an HTTP method and a path or just a path"
where
toPathExps :: String -> Q [Exp]
toPathExps p = splitOn '/' p
& filter (/= "")
& fmap (splitOn ':')
& List.foldr joinPath []
& fmap toPathExp
& sequence
joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath p [] = [p]
joinPath (p:|[]) ((p':|[]) : xs) = ((p <> "/" <> p') :| []) : xs
joinPath y (x:xs) = y:x:xs
toPathExp :: NonEmpty String -> Q Exp
toPathExp (p :| []) = pure $ AppTypeE (VarE 'path) (LitT $ StrTyLit p)
toPathExp (v :| [t]) = pure $ AppTypeE (AppTypeE (VarE 'pathVar) (LitT $ StrTyLit v)) (ConT $ mkName t)
toPathExp xs = fail $ "Invalid path component: " <> List.intercalate ":" (toList xs)
compose :: Exp -> Exp -> Exp
compose l = UInfixE l (VarE $ mkName ".")