-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Middlewares related to route paths.
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


-- | 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 :: 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)

-- | A middleware that captures a path variable from a single path
-- component.
--
-- The value captured is converted to a value of type @val@ via
-- 'FromHttpApiData'. 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 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)

-- | Produces middleware(s) to match an optional HTTP method and path.
--
-- This quasiquoter can be used in several ways:
--
-- * @[match|a\/b\/c]@ is equivalent to @'path' \@\"a\/b\/c\"@
-- * @[match|a\/b\/objId:Int\/d]@ is equivalent to
--   @'path' \@\"a\/b\" . 'pathVar' \@\"objId\" \@Int . 'path' @\"d\"@
-- * @[match|GET a\/b\/c]@ is equivalent to
--   @'method' \@GET $ 'path' \@\"a\/b\/c\"@
-- * @[match|GET a\/b\/objId:Int\/d]@ is equivalent to
--   @'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
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 ".")