{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the path traits.
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 ()
        )