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


-- | A path component which is literally matched against the request
-- but discarded after that.
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 :: Request -> m (Result (Path s) Request)
toAttribute Request
_ = do
    PathInfo [Text]
actualPath <- m PathInfo
forall s (m :: * -> *). MonadState s m => m s
get
    case [Text] -> [Text] -> Maybe [Text]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
expectedPath [Text]
actualPath of
      Maybe [Text]
Nothing   -> Result (Path s) Request -> m (Result (Path s) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Path s) Request -> m (Result (Path s) Request))
-> Result (Path s) Request -> m (Result (Path s) Request)
forall a b. (a -> b) -> a -> b
$ Absence (Path s) Request -> Result (Path s) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound ()
      Just [Text]
rest -> do
        PathInfo -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PathInfo -> m ()) -> PathInfo -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> PathInfo
PathInfo [Text]
rest
        Result (Path s) Request -> m (Result (Path s) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (Path s) Request -> m (Result (Path s) Request))
-> Result (Path s) Request -> m (Result (Path s) Request)
forall a b. (a -> b) -> a -> b
$ Attribute (Path s) Request -> Result (Path s) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found ()

    where
      expectedPath :: [Text]
expectedPath = Proxy s
forall k (t :: k). Proxy t
Proxy @s
                     Proxy s -> (Proxy s -> String) -> String
forall a b. a -> (a -> b) -> b
& Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal
                     String -> (String -> NonEmpty String) -> NonEmpty String
forall a b. a -> (a -> b) -> b
& Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn Char
'/'
                     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] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
pack


-- | 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 val

-- | Failure to extract a 'PathVar'
data PathVarError = PathVarNotFound | PathVarParseError Text
  deriving (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 (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 :: Request -> m (Result (PathVar tag val) Request)
toAttribute Request
_ = do
    PathInfo [Text]
actualPath <- m PathInfo
forall s (m :: * -> *). MonadState s m => m s
get
    case [Text]
actualPath of
      []     -> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (PathVar tag val) Request
 -> m (Result (PathVar tag val) Request))
-> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$ Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound Absence (PathVar tag val) Request
PathVarError
PathVarNotFound
      (Text
x:[Text]
xs) -> case Text -> Either Text val
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece @val Text
x of
        Left Text
e  -> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (PathVar tag val) Request
 -> m (Result (PathVar tag val) Request))
-> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$ Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound (Absence (PathVar tag val) Request
 -> Result (PathVar tag val) Request)
-> Absence (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall a b. (a -> b) -> a -> b
$ Text -> PathVarError
PathVarParseError Text
e
        Right val
v -> do
          PathInfo -> m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (PathInfo -> m ()) -> PathInfo -> m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> PathInfo
PathInfo [Text]
xs
          Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result (PathVar tag val) Request
 -> m (Result (PathVar tag val) Request))
-> Result (PathVar tag val) Request
-> m (Result (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$ Attribute (PathVar tag val) Request
-> Result (PathVar tag val) Request
forall k (t :: k) a. Attribute t a -> Result t a
Found val
Attribute (PathVar tag val) Request
v

-- | Trait to indicate that no more path components are present in the request
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 :: Request -> m (Result PathEnd Request)
toAttribute Request
_ = do
    PathInfo [Text]
actualPath <- m PathInfo
forall s (m :: * -> *). MonadState s m => m s
get
    Result PathEnd Request -> m (Result PathEnd Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result PathEnd Request -> m (Result PathEnd Request))
-> Result PathEnd Request -> m (Result PathEnd Request)
forall a b. (a -> b) -> a -> b
$ if [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
actualPath
           then Attribute PathEnd Request -> Result PathEnd Request
forall k (t :: k) a. Attribute t a -> Result t a
Found ()
           else Absence PathEnd Request -> Result PathEnd Request
forall k (t :: k) a. Absence t a -> Result t a
NotFound ()


-- | 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 m a. (KnownSymbol s, MonadRouter m)
     => RequestMiddleware' m ts (Path s:ts) a
path :: RequestMiddleware' m ts (Path s : ts) a
path Handler' m (Path s : ts) a
handler = (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Response a))
 -> Kleisli m (Linked ts Request) (Response a))
-> (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (Path s) a m =>
Linked ts a
-> m (Either (Absence (Path s) a) (Linked (Path s : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(Path s) (Linked ts Request -> m (Either () (Linked (Path s : ts) Request)))
-> (Either () (Linked (Path s : ts) Request) -> m (Response a))
-> Linked ts Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (() -> m (Response a))
-> (Linked (Path s : ts) Request -> m (Response a))
-> Either () (Linked (Path s : ts) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> () -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (Path s : ts) a
-> Linked (Path s : ts) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (Path s : ts) 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 m a. (FromHttpApiData val, MonadRouter m)
        => RequestMiddleware' m ts (PathVar tag val:ts) a
pathVar :: RequestMiddleware' m ts (PathVar tag val : ts) a
pathVar Handler' m (PathVar tag val : ts) a
handler = (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Response a))
 -> Kleisli m (Linked ts Request) (Response a))
-> (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait (PathVar tag val) a m =>
Linked ts a
-> m (Either
        (Absence (PathVar tag val) a) (Linked (PathVar tag val : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @(PathVar tag val) (Linked ts Request
 -> m (Either PathVarError (Linked (PathVar tag val : ts) Request)))
-> (Either PathVarError (Linked (PathVar tag val : ts) Request)
    -> m (Response a))
-> Linked ts Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (PathVarError -> m (Response a))
-> (Linked (PathVar tag val : ts) Request -> m (Response a))
-> Either PathVarError (Linked (PathVar tag val : ts) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> PathVarError -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (PathVar tag val : ts) a
-> Linked (PathVar tag val : ts) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (PathVar tag val : ts) a
handler)

-- | A middleware that verifies that end of path is reached.
pathEnd :: MonadRouter m => RequestMiddleware' m ts (PathEnd:ts) a
pathEnd :: RequestMiddleware' m ts (PathEnd : ts) a
pathEnd Handler' m (PathEnd : ts) a
handler = (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall (m :: * -> *) a b. (a -> m b) -> Kleisli m a b
Kleisli ((Linked ts Request -> m (Response a))
 -> Kleisli m (Linked ts Request) (Response a))
-> (Linked ts Request -> m (Response a))
-> Kleisli m (Linked ts Request) (Response a)
forall a b. (a -> b) -> a -> b
$
  forall (ts :: [*]) a (m :: * -> *).
Trait PathEnd a m =>
Linked ts a
-> m (Either (Absence PathEnd a) (Linked (PathEnd : ts) a))
forall t (ts :: [*]) a (m :: * -> *).
Trait t a m =>
Linked ts a -> m (Either (Absence t a) (Linked (t : ts) a))
probe @PathEnd (Linked ts Request
 -> m (Either () (Linked (PathEnd : ts) Request)))
-> (Either () (Linked (PathEnd : ts) Request) -> m (Response a))
-> Linked ts Request
-> m (Response a)
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (() -> m (Response a))
-> (Linked (PathEnd : ts) Request -> m (Response a))
-> Either () (Linked (PathEnd : ts) Request)
-> m (Response a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (m (Response a) -> () -> m (Response a)
forall a b. a -> b -> a
const m (Response a)
forall (m :: * -> *) a. MonadRouter m => m a
rejectRoute) (Handler' m (PathEnd : ts) a
-> Linked (PathEnd : ts) Request -> m (Response a)
forall (m :: * -> *) a b. Kleisli m a b -> a -> m b
runKleisli Handler' m (PathEnd : ts) a
handler)

-- | 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
  [String
m, 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
    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
  [String
p]    -> do
    [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) -> [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
    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 (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 NonEmpty String
p []                    = [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
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 (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 (String
v :| [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 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 (t :: * -> *) a. Foldable t => t 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
".")