{- | Middlewares related to request paths.

 All the middlewares below attempt to match components of the request
 path. In case of a mismatch, they abandon the current handler and
 tries the next handler.
-}
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)

{- | A path component which is literally matched against the request
 but discarded after that.
-}
newtype Path = Path Text

instance Trait Path Request where
  type Attribute Path Request = ()

instance TraitAbsence Path Request where
  type Absence Path Request = ()

{- | A path variable that is extracted and converted to a value of
 type @val@. The @tag@ is usually a type-level symbol (string) to
 uniquely identify this variable.
-}
data PathVar (tag :: Symbol) (val :: Data.Kind.Type) = PathVar

-- | Failure to extract a '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
/= :: PathVarError -> PathVarError -> Bool
$c/= :: PathVarError -> PathVarError -> Bool
== :: PathVarError -> PathVarError -> Bool
$c== :: 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
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]
(Int -> ReadS PathVarError)
-> ReadS [PathVarError]
-> ReadPrec PathVarError
-> ReadPrec [PathVarError]
-> Read 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

-- | Trait to indicate that no more path components are present in the request
data PathEnd = PathEnd

instance Trait PathEnd Request where
  type Attribute PathEnd Request = ()

instance TraitAbsence PathEnd Request where
  type Absence PathEnd Request = ()

{- | A middleware that literally matches path @s@.

 The symbol @s@ could contain one or more parts separated by a
 forward slash character. The route will be rejected if there is no
 match.

 For example, the following code could be used to match the URL path
 \"a\/b\/c\" and then invoke @handler@:

 > path "a/b/c" handler
-}
path ::
  (Get h Path Request, ArrowChoice h, ArrowError RouteMismatch h) =>
  Text ->
  Middleware h req (Path : req)
path :: Text -> Middleware h req (Path : req)
path Text
s RequestHandler h (Path : req)
nextHandler = Path
-> h (Linked req Request)
     (Either (Absence Path Request) (Linked (Path : req) Request))
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) h (Linked req Request) (Either () (Linked (Path : req) Request))
-> h (Either () (Linked (Path : req) Request)) Response
-> h (Linked req Request) 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 : req)
-> h (Either () (Linked (Path : req) Request)) Response
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (Path : req)
nextHandler

{- | A middleware that captures a path variable from a single path
 component.

 The value captured is converted to a value of type @val@. The route
 will be rejected if the value is not found or cannot be converted.

 For example, the following code could be used to read a path
 component as 'Int' tagged with the symbol \"objId\", and then
 invoke @handler@:

 > pathVar @"objId" @Int handler
-}
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 :: Middleware h req (PathVar tag val : req)
pathVar RequestHandler h (PathVar tag val : req)
nextHandler = PathVar tag val
-> h (Linked req Request)
     (Either
        (Absence (PathVar tag val) Request)
        (Linked (PathVar tag val : req) Request))
forall t (ts :: [*]) (h :: * -> * -> *) a.
Get h t a =>
t -> h (Linked ts a) (Either (Absence t a) (Linked (t : ts) a))
probe PathVar tag val
forall (tag :: Symbol) val. PathVar tag val
PathVar h (Linked req Request)
  (Either PathVarError (Linked (PathVar tag val : req) Request))
-> h (Either PathVarError (Linked (PathVar tag val : req) Request))
     Response
-> h (Linked req Request) 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 : req)
-> h (Either PathVarError (Linked (PathVar tag val : req) Request))
     Response
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

-- | A middleware that verifies that end of path is reached.
pathEnd ::
  (Get h PathEnd Request, ArrowChoice h, ArrowError RouteMismatch h) =>
  Middleware h req (PathEnd : req)
pathEnd :: Middleware h req (PathEnd : req)
pathEnd RequestHandler h (PathEnd : req)
nextHandler = PathEnd
-> h (Linked req Request)
     (Either (Absence PathEnd Request) (Linked (PathEnd : req) Request))
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 h (Linked req Request) (Either () (Linked (PathEnd : req) Request))
-> h (Either () (Linked (PathEnd : req) Request)) Response
-> h (Linked req Request) 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 : req)
-> h (Either () (Linked (PathEnd : req) Request)) Response
forall (a :: * -> * -> *) b d c.
ArrowChoice a =>
a b d -> a c d -> a (Either b c) d
||| RequestHandler h (PathEnd : req)
nextHandler

{- | Produces middleware(s) to match an optional HTTP method and some
 path components.

 This middleware matches a prefix of path components, the remaining
 components can be matched by subsequent uses of 'match'.

 This quasiquoter can be used in several ways:

 +---------------------------------------+---------------------------------------------------------------------------------+
 | QuasiQuoter                           | Equivalent Middleware                                                           |
 +=======================================+=================================================================================+
 | @[match| \/a\/b\/c |]@                | @'path' \"\/a\/b\/c\"@                                                          |
 +---------------------------------------+---------------------------------------------------------------------------------+
 | @[match| \/a\/b\/objId:Int\/d |]@     | @'path' \"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \"d\"@                |
 +---------------------------------------+---------------------------------------------------------------------------------+
 | @[match| GET \/a\/b\/c |]@            | @'method' GET . 'path' \"\/a\/b\/c\"@                                           |
 +---------------------------------------+---------------------------------------------------------------------------------+
 | @[match| GET \/a\/b\/objId:Int\/d |]@ | @'method' GET . 'path' \"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \"d\"@ |
 +---------------------------------------+---------------------------------------------------------------------------------+
-}
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
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 (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 (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 (m :: * -> *) a. MonadFail m => String -> m a
fail String
"match cannot be used in a declaration"
    }

{- | Produces middleware(s) to match an optional HTTP method and the
 entire request path.

 This middleware is intended to be used in cases where the entire
 path needs to be matched. Use 'match' middleware to match only an
 initial portion of the path.

 This quasiquoter can be used in several ways:

 +---------------------------------------+----------------------------------------------------------------------------------------------+
 | QuasiQuoter                           | Equivalent Middleware                                                                        |
 +=======================================+==============================================================================================+
 | @[route| \/a\/b\/c |]@                | @'path' \"\/a\/b\/c\" . 'pathEnd'@                                                           |
 +---------------------------------------+----------------------------------------------------------------------------------------------+
 | @[route| \/a\/b\/objId:Int\/d |]@     | @'path' \"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \"d\" . 'pathEnd'@                 |
 +---------------------------------------+----------------------------------------------------------------------------------------------+
 | @[route| GET \/a\/b\/c |]@            | @'method' GET . 'path' \"\/a\/b\/c\" . 'pathEnd'@                                            |
 +---------------------------------------+----------------------------------------------------------------------------------------------+
 | @[route| GET \/a\/b\/objId:Int\/d |]@ | @'method' GET . 'path' \"\/a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' \"d\" . 'pathEnd')@ |
 +---------------------------------------+----------------------------------------------------------------------------------------------+
-}
route :: QuasiQuoter
route :: QuasiQuoter
route =
  QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
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 (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 (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 (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 (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 (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 (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
List.foldr1 Exp -> Exp -> Exp
compose [Exp]
pathExps
  [String]
_ -> String -> Q Exp
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
`appE` Name -> Q Exp
conE (String -> Name
mkName String
m)
      [Exp]
pathExps <- String -> Q [Exp]
toPathExps 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 -> 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

    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 (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 (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)
mapM NonEmpty String -> Q Exp
toPathExp

    joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
    joinPath :: NonEmpty String -> [NonEmpty String] -> [NonEmpty String]
joinPath NonEmpty String
p [] = [Item [NonEmpty String]
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 (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 (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 (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 :: a -> [a] -> NonEmpty [a]
splitOn a
sep = (a -> NonEmpty [a] -> NonEmpty [a])
-> NonEmpty [a] -> [a] -> NonEmpty [a]
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