{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
module Servant.Server.Internal.RouteResult where

import           Control.Monad
                 (ap, liftM)
import           Control.Monad.Base
                 (MonadBase (..))
import           Control.Monad.Catch
                 (MonadThrow (..))
import           Control.Monad.Trans
                 (MonadIO (..), MonadTrans (..))
import           Control.Monad.Trans.Control
                 (ComposeSt, MonadBaseControl (..), MonadTransControl (..),
                 defaultLiftBaseWith, defaultRestoreM)

import           Servant.Server.Internal.ServerError

-- | The result of matching against a path in the route tree.
data RouteResult a =
    Fail ServerError           -- ^ Keep trying other paths.
                               --   The 'ServantError' should only be 404, 405 or 406.
  | FailFatal !ServerError     -- ^ Don't try other paths.
  | Route !a
  deriving (RouteResult a -> RouteResult a -> Bool
(RouteResult a -> RouteResult a -> Bool)
-> (RouteResult a -> RouteResult a -> Bool) -> Eq (RouteResult a)
forall a. Eq a => RouteResult a -> RouteResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteResult a -> RouteResult a -> Bool
$c/= :: forall a. Eq a => RouteResult a -> RouteResult a -> Bool
== :: RouteResult a -> RouteResult a -> Bool
$c== :: forall a. Eq a => RouteResult a -> RouteResult a -> Bool
Eq, Int -> RouteResult a -> ShowS
[RouteResult a] -> ShowS
RouteResult a -> String
(Int -> RouteResult a -> ShowS)
-> (RouteResult a -> String)
-> ([RouteResult a] -> ShowS)
-> Show (RouteResult a)
forall a. Show a => Int -> RouteResult a -> ShowS
forall a. Show a => [RouteResult a] -> ShowS
forall a. Show a => RouteResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteResult a] -> ShowS
$cshowList :: forall a. Show a => [RouteResult a] -> ShowS
show :: RouteResult a -> String
$cshow :: forall a. Show a => RouteResult a -> String
showsPrec :: Int -> RouteResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RouteResult a -> ShowS
Show, ReadPrec [RouteResult a]
ReadPrec (RouteResult a)
Int -> ReadS (RouteResult a)
ReadS [RouteResult a]
(Int -> ReadS (RouteResult a))
-> ReadS [RouteResult a]
-> ReadPrec (RouteResult a)
-> ReadPrec [RouteResult a]
-> Read (RouteResult a)
forall a. Read a => ReadPrec [RouteResult a]
forall a. Read a => ReadPrec (RouteResult a)
forall a. Read a => Int -> ReadS (RouteResult a)
forall a. Read a => ReadS [RouteResult a]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [RouteResult a]
$creadListPrec :: forall a. Read a => ReadPrec [RouteResult a]
readPrec :: ReadPrec (RouteResult a)
$creadPrec :: forall a. Read a => ReadPrec (RouteResult a)
readList :: ReadS [RouteResult a]
$creadList :: forall a. Read a => ReadS [RouteResult a]
readsPrec :: Int -> ReadS (RouteResult a)
$creadsPrec :: forall a. Read a => Int -> ReadS (RouteResult a)
Read, a -> RouteResult b -> RouteResult a
(a -> b) -> RouteResult a -> RouteResult b
(forall a b. (a -> b) -> RouteResult a -> RouteResult b)
-> (forall a b. a -> RouteResult b -> RouteResult a)
-> Functor RouteResult
forall a b. a -> RouteResult b -> RouteResult a
forall a b. (a -> b) -> RouteResult a -> RouteResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RouteResult b -> RouteResult a
$c<$ :: forall a b. a -> RouteResult b -> RouteResult a
fmap :: (a -> b) -> RouteResult a -> RouteResult b
$cfmap :: forall a b. (a -> b) -> RouteResult a -> RouteResult b
Functor)

instance Applicative RouteResult where
    pure :: a -> RouteResult a
pure = a -> RouteResult a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: RouteResult (a -> b) -> RouteResult a -> RouteResult b
(<*>) = RouteResult (a -> b) -> RouteResult a -> RouteResult b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad RouteResult where
    return :: a -> RouteResult a
return = a -> RouteResult a
forall a. a -> RouteResult a
Route
    Route a
a     >>= :: RouteResult a -> (a -> RouteResult b) -> RouteResult b
>>= a -> RouteResult b
f = a -> RouteResult b
f a
a
    Fail ServerError
e      >>= a -> RouteResult b
_ = ServerError -> RouteResult b
forall a. ServerError -> RouteResult a
Fail ServerError
e
    FailFatal ServerError
e >>= a -> RouteResult b
_ = ServerError -> RouteResult b
forall a. ServerError -> RouteResult a
FailFatal ServerError
e

newtype RouteResultT m a = RouteResultT { RouteResultT m a -> m (RouteResult a)
runRouteResultT :: m (RouteResult a) }
  deriving (a -> RouteResultT m b -> RouteResultT m a
(a -> b) -> RouteResultT m a -> RouteResultT m b
(forall a b. (a -> b) -> RouteResultT m a -> RouteResultT m b)
-> (forall a b. a -> RouteResultT m b -> RouteResultT m a)
-> Functor (RouteResultT m)
forall a b. a -> RouteResultT m b -> RouteResultT m a
forall a b. (a -> b) -> RouteResultT m a -> RouteResultT m b
forall (m :: * -> *) a b.
Functor m =>
a -> RouteResultT m b -> RouteResultT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RouteResultT m a -> RouteResultT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> RouteResultT m b -> RouteResultT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> RouteResultT m b -> RouteResultT m a
fmap :: (a -> b) -> RouteResultT m a -> RouteResultT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> RouteResultT m a -> RouteResultT m b
Functor)

instance MonadTrans RouteResultT where
    lift :: m a -> RouteResultT m a
lift = m (RouteResult a) -> RouteResultT m a
forall (m :: * -> *) a. m (RouteResult a) -> RouteResultT m a
RouteResultT (m (RouteResult a) -> RouteResultT m a)
-> (m a -> m (RouteResult a)) -> m a -> RouteResultT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> RouteResult a) -> m a -> m (RouteResult a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> RouteResult a
forall a. a -> RouteResult a
Route

instance (Functor m, Monad m) => Applicative (RouteResultT m) where
    pure :: a -> RouteResultT m a
pure  = a -> RouteResultT m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: RouteResultT m (a -> b) -> RouteResultT m a -> RouteResultT m b
(<*>) = RouteResultT m (a -> b) -> RouteResultT m a -> RouteResultT m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (RouteResultT m) where
    return :: a -> RouteResultT m a
return = m (RouteResult a) -> RouteResultT m a
forall (m :: * -> *) a. m (RouteResult a) -> RouteResultT m a
RouteResultT (m (RouteResult a) -> RouteResultT m a)
-> (a -> m (RouteResult a)) -> a -> RouteResultT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RouteResult a -> m (RouteResult a)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult a -> m (RouteResult a))
-> (a -> RouteResult a) -> a -> m (RouteResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> RouteResult a
forall a. a -> RouteResult a
Route
    RouteResultT m a
m >>= :: RouteResultT m a -> (a -> RouteResultT m b) -> RouteResultT m b
>>= a -> RouteResultT m b
k = m (RouteResult b) -> RouteResultT m b
forall (m :: * -> *) a. m (RouteResult a) -> RouteResultT m a
RouteResultT (m (RouteResult b) -> RouteResultT m b)
-> m (RouteResult b) -> RouteResultT m b
forall a b. (a -> b) -> a -> b
$ do
        RouteResult a
a <- RouteResultT m a -> m (RouteResult a)
forall (m :: * -> *) a. RouteResultT m a -> m (RouteResult a)
runRouteResultT RouteResultT m a
m
        case RouteResult a
a of
            Fail ServerError
e      -> RouteResult b -> m (RouteResult b)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult b -> m (RouteResult b))
-> RouteResult b -> m (RouteResult b)
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult b
forall a. ServerError -> RouteResult a
Fail ServerError
e
            FailFatal ServerError
e -> RouteResult b -> m (RouteResult b)
forall (m :: * -> *) a. Monad m => a -> m a
return (RouteResult b -> m (RouteResult b))
-> RouteResult b -> m (RouteResult b)
forall a b. (a -> b) -> a -> b
$ ServerError -> RouteResult b
forall a. ServerError -> RouteResult a
FailFatal ServerError
e
            Route a
b     -> RouteResultT m b -> m (RouteResult b)
forall (m :: * -> *) a. RouteResultT m a -> m (RouteResult a)
runRouteResultT (a -> RouteResultT m b
k a
b)

instance MonadIO m => MonadIO (RouteResultT m) where
    liftIO :: IO a -> RouteResultT m a
liftIO = m a -> RouteResultT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> RouteResultT m a)
-> (IO a -> m a) -> IO a -> RouteResultT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

instance MonadBase b m => MonadBase b (RouteResultT m) where
    liftBase :: b α -> RouteResultT m α
liftBase = m α -> RouteResultT m α
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m α -> RouteResultT m α)
-> (b α -> m α) -> b α -> RouteResultT m α
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b α -> m α
forall (b :: * -> *) (m :: * -> *) α. MonadBase b m => b α -> m α
liftBase

instance MonadBaseControl b m => MonadBaseControl b (RouteResultT m) where
    type StM (RouteResultT m) a = ComposeSt RouteResultT m a
    liftBaseWith :: (RunInBase (RouteResultT m) b -> b a) -> RouteResultT m a
liftBaseWith = (RunInBase (RouteResultT m) b -> b a) -> RouteResultT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
(RunInBaseDefault t m b -> b a) -> t m a
defaultLiftBaseWith
    restoreM :: StM (RouteResultT m) a -> RouteResultT m a
restoreM     = StM (RouteResultT m) a -> RouteResultT m a
forall (t :: (* -> *) -> * -> *) (b :: * -> *) (m :: * -> *) a.
(MonadTransControl t, MonadBaseControl b m) =>
ComposeSt t m a -> t m a
defaultRestoreM

instance MonadTransControl RouteResultT where
    type StT RouteResultT a = RouteResult a
    liftWith :: (Run RouteResultT -> m a) -> RouteResultT m a
liftWith Run RouteResultT -> m a
f = m (RouteResult a) -> RouteResultT m a
forall (m :: * -> *) a. m (RouteResult a) -> RouteResultT m a
RouteResultT (m (RouteResult a) -> RouteResultT m a)
-> m (RouteResult a) -> RouteResultT m a
forall a b. (a -> b) -> a -> b
$ (a -> RouteResult a) -> m a -> m (RouteResult a)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM a -> RouteResult a
forall (m :: * -> *) a. Monad m => a -> m a
return (m a -> m (RouteResult a)) -> m a -> m (RouteResult a)
forall a b. (a -> b) -> a -> b
$ Run RouteResultT -> m a
f Run RouteResultT
forall (m :: * -> *) a. RouteResultT m a -> m (RouteResult a)
runRouteResultT
    restoreT :: m (StT RouteResultT a) -> RouteResultT m a
restoreT = m (StT RouteResultT a) -> RouteResultT m a
forall (m :: * -> *) a. m (RouteResult a) -> RouteResultT m a
RouteResultT

instance MonadThrow m => MonadThrow (RouteResultT m) where
    throwM :: e -> RouteResultT m a
throwM = m a -> RouteResultT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m a -> RouteResultT m a) -> (e -> m a) -> e -> RouteResultT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM