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)
data Path (s :: Symbol)
instance (KnownSymbol s, Monad m) => Trait (Path s) Request m where
type Val (Path s) Request = ()
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) ()
data PathVar tag (val :: Type)
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