{-# OPTIONS_GHC -Wno-orphans #-}
module WebGear.Server.Trait.Path where
import Control.Monad.State (get, gets, put)
import qualified Data.List as List
import qualified Data.Text as Text
import Web.HttpApiData (FromHttpApiData (..))
import WebGear.Core.Handler (RoutePath (..))
import WebGear.Core.Request (Request)
import WebGear.Core.Trait (Get (..), With)
import WebGear.Core.Trait.Path (
Path (..),
PathEnd (..),
PathVar (..),
PathVarError (..),
)
import WebGear.Server.Handler (ServerHandler (..))
instance (Monad m) => Get (ServerHandler m) Path Request where
{-# INLINE getTrait #-}
getTrait :: Path -> ServerHandler m (Request `With` ts) (Either () ())
getTrait :: forall (ts :: [*]).
Path -> ServerHandler m (With Request ts) (Either () ())
getTrait (Path Text
p) = forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
RoutePath [Text]
remaining <- forall s (m :: * -> *). MonadState s m => m s
get
let expected :: [Text]
expected = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Text
"") forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn Text
"/" Text
p
case forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
expected [Text]
remaining of
Just [Text]
ps -> forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Text] -> RoutePath
RoutePath [Text]
ps) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right ())
Maybe [Text]
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left ())
instance (Monad m, FromHttpApiData val) => Get (ServerHandler m) (PathVar tag val) Request where
{-# INLINE getTrait #-}
getTrait :: PathVar tag val -> ServerHandler m (Request `With` ts) (Either PathVarError val)
getTrait :: forall (ts :: [*]).
PathVar tag val
-> ServerHandler m (With Request ts) (Either PathVarError val)
getTrait PathVar tag val
PathVar = forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ do
RoutePath [Text]
remaining <- forall s (m :: * -> *). MonadState s m => m s
get
case [Text]
remaining of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left PathVarError
PathVarNotFound)
(Text
p : [Text]
ps) ->
case forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
p of
Left Text
e -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PathVarError
PathVarParseError Text
e)
Right val
val -> forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Text] -> RoutePath
RoutePath [Text]
ps) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right val
val)
instance (Monad m) => Get (ServerHandler m) PathEnd Request where
{-# INLINE getTrait #-}
getTrait :: PathEnd -> ServerHandler m (Request `With` ts) (Either () ())
getTrait :: forall (ts :: [*]).
PathEnd -> ServerHandler m (With Request ts) (Either () ())
getTrait PathEnd
PathEnd =
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler
forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const
forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets
( \case
RoutePath [] -> forall a b. b -> Either a b
Right ()
RoutePath
_ -> forall a b. a -> Either a b
Left ()
)