{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the path traits.
module WebGear.Server.Trait.Path where

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 (..), Linked)
import WebGear.Core.Trait.Path (Path (..), PathEnd (..), PathVar (..), PathVarError (..))
import WebGear.Server.Handler (ServerHandler (..))

instance Monad m => Get (ServerHandler m) Path Request where
  {-# INLINEABLE getTrait #-}
  getTrait :: Path -> ServerHandler m (Linked ts Request) (Either () ())
  getTrait :: forall (ts :: [*]).
Path -> ServerHandler m (Linked ts Request) (Either () ())
getTrait (Path Text
p) = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(Linked ts Request
_, path :: RoutePath
path@(RoutePath [Text]
remaining)) -> do
    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
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case forall a. Eq a => [a] -> [a] -> Maybe [a]
List.stripPrefix [Text]
expected [Text]
remaining of
      Just [Text]
ps -> (forall a b. b -> Either a b
Right (forall a b. b -> Either a b
Right ()), [Text] -> RoutePath
RoutePath [Text]
ps)
      Maybe [Text]
Nothing -> (forall a b. b -> Either a b
Right (forall a b. a -> Either a b
Left ()), RoutePath
path)

instance (Monad m, FromHttpApiData val) => Get (ServerHandler m) (PathVar tag val) Request where
  {-# INLINEABLE getTrait #-}
  getTrait :: PathVar tag val -> ServerHandler m (Linked ts Request) (Either PathVarError val)
  getTrait :: forall (ts :: [*]).
PathVar tag val
-> ServerHandler m (Linked ts Request) (Either PathVarError val)
getTrait PathVar tag val
PathVar = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall a b. (a -> b) -> a -> b
$ \(Linked ts Request
_, path :: RoutePath
path@(RoutePath [Text]
remaining)) -> do
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case [Text]
remaining of
      [] -> (forall a b. b -> Either a b
Right (forall a b. a -> Either a b
Left PathVarError
PathVarNotFound), RoutePath
path)
      (Text
p : [Text]
ps) ->
        case forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
p of
          Left Text
e -> (forall a b. b -> Either a b
Right (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PathVarError
PathVarParseError Text
e), RoutePath
path)
          Right val
val -> (forall a b. b -> Either a b
Right (forall a b. b -> Either a b
Right val
val), [Text] -> RoutePath
RoutePath [Text]
ps)

instance Monad m => Get (ServerHandler m) PathEnd Request where
  {-# INLINEABLE getTrait #-}
  getTrait :: PathEnd -> ServerHandler m (Linked ts Request) (Either () ())
  getTrait :: forall (ts :: [*]).
PathEnd -> ServerHandler m (Linked ts Request) (Either () ())
getTrait PathEnd
PathEnd = forall (m :: * -> *) a b.
((a, RoutePath) -> m (Either RouteMismatch b, RoutePath))
-> ServerHandler m a b
ServerHandler forall {f :: * -> *} {a} {a}.
Applicative f =>
(a, RoutePath) -> f (Either a (Either () ()), RoutePath)
f
    where
      f :: (a, RoutePath) -> f (Either a (Either () ()), RoutePath)
f (a
_, p :: RoutePath
p@(RoutePath [])) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (), RoutePath
p)
      f (a
_, RoutePath
p) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (), RoutePath
p)