{-# 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) = (With Request ts
 -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
-> ServerHandler m (With Request ts) (Either () ())
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((With Request ts
  -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
 -> ServerHandler m (With Request ts) (Either () ()))
-> (With Request ts
    -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
-> ServerHandler m (With Request ts) (Either () ())
forall a b. (a -> b) -> a -> b
$ StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
-> With Request ts
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a b. a -> b -> a
const (StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
 -> With Request ts
 -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
-> With Request ts
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a b. (a -> b) -> a -> b
$ do
    RoutePath [Text]
remaining <- StateT RoutePath (ExceptT RouteMismatch m) RoutePath
forall s (m :: * -> *). MonadState s m => m s
get
    let expected :: [Text]
expected = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"") ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"/" Text
p
    case [Text] -> [Text] -> Maybe [Text]
forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
expected [Text]
remaining of
      Just [Text]
ps -> RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Text] -> RoutePath
RoutePath [Text]
ps) StateT RoutePath (ExceptT RouteMismatch m) ()
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a b.
StateT RoutePath (ExceptT RouteMismatch m) a
-> StateT RoutePath (ExceptT RouteMismatch m) b
-> StateT RoutePath (ExceptT RouteMismatch m) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either () ()
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either () ()
forall a b. b -> Either a b
Right ())
      Maybe [Text]
Nothing -> Either () ()
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either () ()
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 = (With Request ts
 -> StateT
      RoutePath (ExceptT RouteMismatch m) (Either PathVarError val))
-> ServerHandler m (With Request ts) (Either PathVarError val)
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler ((With Request ts
  -> StateT
       RoutePath (ExceptT RouteMismatch m) (Either PathVarError val))
 -> ServerHandler m (With Request ts) (Either PathVarError val))
-> (With Request ts
    -> StateT
         RoutePath (ExceptT RouteMismatch m) (Either PathVarError val))
-> ServerHandler m (With Request ts) (Either PathVarError val)
forall a b. (a -> b) -> a -> b
$ StateT
  RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
-> With Request ts
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
forall a b. a -> b -> a
const (StateT
   RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
 -> With Request ts
 -> StateT
      RoutePath (ExceptT RouteMismatch m) (Either PathVarError val))
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
-> With Request ts
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
forall a b. (a -> b) -> a -> b
$ do
    RoutePath [Text]
remaining <- StateT RoutePath (ExceptT RouteMismatch m) RoutePath
forall s (m :: * -> *). MonadState s m => m s
get
    case [Text]
remaining of
      [] -> Either PathVarError val
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathVarError -> Either PathVarError val
forall a b. a -> Either a b
Left PathVarError
PathVarNotFound)
      (Text
p : [Text]
ps) ->
        case Text -> Either Text val
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
p of
          Left Text
e -> Either PathVarError val
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PathVarError -> Either PathVarError val
forall a b. a -> Either a b
Left (PathVarError -> Either PathVarError val)
-> PathVarError -> Either PathVarError val
forall a b. (a -> b) -> a -> b
$ Text -> PathVarError
PathVarParseError Text
e)
          Right val
val -> RoutePath -> StateT RoutePath (ExceptT RouteMismatch m) ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([Text] -> RoutePath
RoutePath [Text]
ps) StateT RoutePath (ExceptT RouteMismatch m) ()
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
forall a b.
StateT RoutePath (ExceptT RouteMismatch m) a
-> StateT RoutePath (ExceptT RouteMismatch m) b
-> StateT RoutePath (ExceptT RouteMismatch m) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Either PathVarError val
-> StateT
     RoutePath (ExceptT RouteMismatch m) (Either PathVarError val)
forall a. a -> StateT RoutePath (ExceptT RouteMismatch m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (val -> Either PathVarError val
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 =
    (With Request ts
 -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
-> ServerHandler m (With Request ts) (Either () ())
forall (m :: * -> *) a b.
(a -> StateT RoutePath (ExceptT RouteMismatch m) b)
-> ServerHandler m a b
ServerHandler
      ((With Request ts
  -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
 -> ServerHandler m (With Request ts) (Either () ()))
-> (With Request ts
    -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
-> ServerHandler m (With Request ts) (Either () ())
forall a b. (a -> b) -> a -> b
$ StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
-> With Request ts
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a b. a -> b -> a
const
      (StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
 -> With Request ts
 -> StateT RoutePath (ExceptT RouteMismatch m) (Either () ()))
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
-> With Request ts
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall a b. (a -> b) -> a -> b
$ (RoutePath -> Either () ())
-> StateT RoutePath (ExceptT RouteMismatch m) (Either () ())
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets
        ( \case
            RoutePath [] -> () -> Either () ()
forall a b. b -> Either a b
Right ()
            RoutePath
_ -> () -> Either () ()
forall a b. a -> Either a b
Left ()
        )