-- |
-- Copyright        : (c) Raghu Kaippully, 2020
-- License          : MPL-2.0
-- Maintainer       : rkaippully@gmail.com
--
-- Traits related to the route path of a request.
module WebGear.Trait.Path
  ( Path
  , PathVar
  , PathVarFail (..)
  ) where

import Data.Kind (Type)
import Data.List (stripPrefix)
import Data.List.NonEmpty (toList)
import Data.Proxy (Proxy (..))
import Data.Text (Text, pack)
import GHC.TypeLits (KnownSymbol, Symbol, symbolVal)
import Web.HttpApiData (FromHttpApiData (..))

import WebGear.Trait (CheckResult (..), Trait (..))
import WebGear.Types (Request, pathInfo, setPathInfo)
import WebGear.Util (splitOn)


-- | A path component which is literally matched against the request
-- but discarded after that.
data Path (s :: Symbol)

instance (KnownSymbol s, Monad m) => Trait (Path s) Request m where
  type Val (Path s) Request = ()

  -- | The path that could not be matched
  type Fail (Path s) Request = ()

  check :: Request -> m (CheckResult (Path s) Request)
  check :: Request -> m (CheckResult (Path s) Request)
check r :: Request
r = CheckResult (Path s) Request -> m (CheckResult (Path s) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckResult (Path s) Request -> m (CheckResult (Path s) Request))
-> CheckResult (Path s) Request -> m (CheckResult (Path s) Request)
forall a b. (a -> b) -> a -> b
$
    let expected :: [Text]
expected = (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
pack ([String] -> [Text]) -> [String] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
toList (NonEmpty String -> [String]) -> NonEmpty String -> [String]
forall a b. (a -> b) -> a -> b
$ Char -> String -> NonEmpty String
forall a. Eq a => a -> [a] -> NonEmpty [a]
splitOn '/' (String -> NonEmpty String) -> String -> NonEmpty String
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s -> String) -> Proxy s -> String
forall a b. (a -> b) -> a -> b
$ Proxy s
forall k (t :: k). Proxy t
Proxy @s
        actual :: [Text]
actual = Request -> [Text]
pathInfo Request
r
    in
      case [Text] -> [Text] -> Maybe [Text]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [Text]
expected [Text]
actual of
        Nothing   -> Fail (Path s) Request -> CheckResult (Path s) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail ()
        Just rest :: [Text]
rest -> Request -> Val (Path s) Request -> CheckResult (Path s) Request
forall k (t :: k) a. a -> Val t a -> CheckResult t a
CheckSuccess ([Text] -> Request -> Request
setPathInfo [Text]
rest Request
r) ()


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

-- | Failure to extract a 'PathVar'
data PathVarFail = PathVarNotFound | PathVarParseError Text
  deriving (PathVarFail -> PathVarFail -> Bool
(PathVarFail -> PathVarFail -> Bool)
-> (PathVarFail -> PathVarFail -> Bool) -> Eq PathVarFail
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathVarFail -> PathVarFail -> Bool
$c/= :: PathVarFail -> PathVarFail -> Bool
== :: PathVarFail -> PathVarFail -> Bool
$c== :: PathVarFail -> PathVarFail -> Bool
Eq, Int -> PathVarFail -> ShowS
[PathVarFail] -> ShowS
PathVarFail -> String
(Int -> PathVarFail -> ShowS)
-> (PathVarFail -> String)
-> ([PathVarFail] -> ShowS)
-> Show PathVarFail
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PathVarFail] -> ShowS
$cshowList :: [PathVarFail] -> ShowS
show :: PathVarFail -> String
$cshow :: PathVarFail -> String
showsPrec :: Int -> PathVarFail -> ShowS
$cshowsPrec :: Int -> PathVarFail -> ShowS
Show, ReadPrec [PathVarFail]
ReadPrec PathVarFail
Int -> ReadS PathVarFail
ReadS [PathVarFail]
(Int -> ReadS PathVarFail)
-> ReadS [PathVarFail]
-> ReadPrec PathVarFail
-> ReadPrec [PathVarFail]
-> Read PathVarFail
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PathVarFail]
$creadListPrec :: ReadPrec [PathVarFail]
readPrec :: ReadPrec PathVarFail
$creadPrec :: ReadPrec PathVarFail
readList :: ReadS [PathVarFail]
$creadList :: ReadS [PathVarFail]
readsPrec :: Int -> ReadS PathVarFail
$creadsPrec :: Int -> ReadS PathVarFail
Read)

instance (FromHttpApiData val, Monad m) => Trait (PathVar tag val) Request m where
  type Val (PathVar tag val) Request = val
  type Fail (PathVar tag val) Request = PathVarFail

  check :: Request -> m (CheckResult (PathVar tag val) Request)
  check :: Request -> m (CheckResult (PathVar tag val) Request)
check r :: Request
r = CheckResult (PathVar tag val) Request
-> m (CheckResult (PathVar tag val) Request)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CheckResult (PathVar tag val) Request
 -> m (CheckResult (PathVar tag val) Request))
-> CheckResult (PathVar tag val) Request
-> m (CheckResult (PathVar tag val) Request)
forall a b. (a -> b) -> a -> b
$
    case Request -> [Text]
pathInfo Request
r of
      []     -> Fail (PathVar tag val) Request
-> CheckResult (PathVar tag val) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail Fail (PathVar tag val) Request
PathVarFail
PathVarNotFound
      (x :: Text
x:xs :: [Text]
xs) ->
        case Text -> Either Text val
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece @val Text
x of
          Left e :: Text
e  -> Fail (PathVar tag val) Request
-> CheckResult (PathVar tag val) Request
forall k (t :: k) a. Fail t a -> CheckResult t a
CheckFail (Fail (PathVar tag val) Request
 -> CheckResult (PathVar tag val) Request)
-> Fail (PathVar tag val) Request
-> CheckResult (PathVar tag val) Request
forall a b. (a -> b) -> a -> b
$ Text -> PathVarFail
PathVarParseError Text
e
          Right h :: val
h -> Request
-> Val (PathVar tag val) Request
-> CheckResult (PathVar tag val) Request
forall k (t :: k) a. a -> Val t a -> CheckResult t a
CheckSuccess ([Text] -> Request -> Request
setPathInfo [Text]
xs Request
r) val
Val (PathVar tag val) Request
h