{-# LANGUAGE CPP #-}

module Servant.Auth.Server.Internal.Types where

import Control.Applicative
import Control.Monad (MonadPlus (..), ap)
import qualified Control.Monad.Fail as Fail
import Control.Monad.Reader
import Control.Monad.Time
import Data.Monoid (Monoid (..))
import Data.Semigroup (Semigroup (..))
import Data.Time (getCurrentTime)
import GHC.Generics (Generic)
import Network.Wai (Request)

-- | The result of an authentication attempt.
data AuthResult val
  = BadPassword
  | NoSuchUser
  | -- | Authentication succeeded.
    Authenticated val
  | -- | If an authentication procedure cannot be carried out - if for example it
    -- expects a password and username in a header that is not present -
    -- @Indefinite@ is returned. This indicates that other authentication
    -- methods should be tried.
    Indefinite
  deriving (AuthResult val -> AuthResult val -> Bool
(AuthResult val -> AuthResult val -> Bool)
-> (AuthResult val -> AuthResult val -> Bool)
-> Eq (AuthResult val)
forall val. Eq val => AuthResult val -> AuthResult val -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall val. Eq val => AuthResult val -> AuthResult val -> Bool
== :: AuthResult val -> AuthResult val -> Bool
$c/= :: forall val. Eq val => AuthResult val -> AuthResult val -> Bool
/= :: AuthResult val -> AuthResult val -> Bool
Eq, (forall m. Monoid m => AuthResult m -> m)
-> (forall m a. Monoid m => (a -> m) -> AuthResult a -> m)
-> (forall m a. Monoid m => (a -> m) -> AuthResult a -> m)
-> (forall a b. (a -> b -> b) -> b -> AuthResult a -> b)
-> (forall a b. (a -> b -> b) -> b -> AuthResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> AuthResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> AuthResult a -> b)
-> (forall a. (a -> a -> a) -> AuthResult a -> a)
-> (forall a. (a -> a -> a) -> AuthResult a -> a)
-> (forall a. AuthResult a -> [a])
-> (forall a. AuthResult a -> Bool)
-> (forall a. AuthResult a -> Int)
-> (forall a. Eq a => a -> AuthResult a -> Bool)
-> (forall a. Ord a => AuthResult a -> a)
-> (forall a. Ord a => AuthResult a -> a)
-> (forall a. Num a => AuthResult a -> a)
-> (forall a. Num a => AuthResult a -> a)
-> Foldable AuthResult
forall a. Eq a => a -> AuthResult a -> Bool
forall a. Num a => AuthResult a -> a
forall a. Ord a => AuthResult a -> a
forall m. Monoid m => AuthResult m -> m
forall a. AuthResult a -> Bool
forall a. AuthResult a -> Int
forall a. AuthResult a -> [a]
forall a. (a -> a -> a) -> AuthResult a -> a
forall m a. Monoid m => (a -> m) -> AuthResult a -> m
forall b a. (b -> a -> b) -> b -> AuthResult a -> b
forall a b. (a -> b -> b) -> b -> AuthResult a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => AuthResult m -> m
fold :: forall m. Monoid m => AuthResult m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
foldr :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AuthResult a -> b
foldl :: forall b a. (b -> a -> b) -> b -> AuthResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AuthResult a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> AuthResult a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> AuthResult a -> a
foldr1 :: forall a. (a -> a -> a) -> AuthResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AuthResult a -> a
foldl1 :: forall a. (a -> a -> a) -> AuthResult a -> a
$ctoList :: forall a. AuthResult a -> [a]
toList :: forall a. AuthResult a -> [a]
$cnull :: forall a. AuthResult a -> Bool
null :: forall a. AuthResult a -> Bool
$clength :: forall a. AuthResult a -> Int
length :: forall a. AuthResult a -> Int
$celem :: forall a. Eq a => a -> AuthResult a -> Bool
elem :: forall a. Eq a => a -> AuthResult a -> Bool
$cmaximum :: forall a. Ord a => AuthResult a -> a
maximum :: forall a. Ord a => AuthResult a -> a
$cminimum :: forall a. Ord a => AuthResult a -> a
minimum :: forall a. Ord a => AuthResult a -> a
$csum :: forall a. Num a => AuthResult a -> a
sum :: forall a. Num a => AuthResult a -> a
$cproduct :: forall a. Num a => AuthResult a -> a
product :: forall a. Num a => AuthResult a -> a
Foldable, (forall a b. (a -> b) -> AuthResult a -> AuthResult b)
-> (forall a b. a -> AuthResult b -> AuthResult a)
-> Functor AuthResult
forall a b. a -> AuthResult b -> AuthResult a
forall a b. (a -> b) -> AuthResult a -> AuthResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AuthResult a -> AuthResult b
fmap :: forall a b. (a -> b) -> AuthResult a -> AuthResult b
$c<$ :: forall a b. a -> AuthResult b -> AuthResult a
<$ :: forall a b. a -> AuthResult b -> AuthResult a
Functor, (forall x. AuthResult val -> Rep (AuthResult val) x)
-> (forall x. Rep (AuthResult val) x -> AuthResult val)
-> Generic (AuthResult val)
forall x. Rep (AuthResult val) x -> AuthResult val
forall x. AuthResult val -> Rep (AuthResult val) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall val x. Rep (AuthResult val) x -> AuthResult val
forall val x. AuthResult val -> Rep (AuthResult val) x
$cfrom :: forall val x. AuthResult val -> Rep (AuthResult val) x
from :: forall x. AuthResult val -> Rep (AuthResult val) x
$cto :: forall val x. Rep (AuthResult val) x -> AuthResult val
to :: forall x. Rep (AuthResult val) x -> AuthResult val
Generic, Eq (AuthResult val)
Eq (AuthResult val) =>
(AuthResult val -> AuthResult val -> Ordering)
-> (AuthResult val -> AuthResult val -> Bool)
-> (AuthResult val -> AuthResult val -> Bool)
-> (AuthResult val -> AuthResult val -> Bool)
-> (AuthResult val -> AuthResult val -> Bool)
-> (AuthResult val -> AuthResult val -> AuthResult val)
-> (AuthResult val -> AuthResult val -> AuthResult val)
-> Ord (AuthResult val)
AuthResult val -> AuthResult val -> Bool
AuthResult val -> AuthResult val -> Ordering
AuthResult val -> AuthResult val -> AuthResult val
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall val. Ord val => Eq (AuthResult val)
forall val. Ord val => AuthResult val -> AuthResult val -> Bool
forall val. Ord val => AuthResult val -> AuthResult val -> Ordering
forall val.
Ord val =>
AuthResult val -> AuthResult val -> AuthResult val
$ccompare :: forall val. Ord val => AuthResult val -> AuthResult val -> Ordering
compare :: AuthResult val -> AuthResult val -> Ordering
$c< :: forall val. Ord val => AuthResult val -> AuthResult val -> Bool
< :: AuthResult val -> AuthResult val -> Bool
$c<= :: forall val. Ord val => AuthResult val -> AuthResult val -> Bool
<= :: AuthResult val -> AuthResult val -> Bool
$c> :: forall val. Ord val => AuthResult val -> AuthResult val -> Bool
> :: AuthResult val -> AuthResult val -> Bool
$c>= :: forall val. Ord val => AuthResult val -> AuthResult val -> Bool
>= :: AuthResult val -> AuthResult val -> Bool
$cmax :: forall val.
Ord val =>
AuthResult val -> AuthResult val -> AuthResult val
max :: AuthResult val -> AuthResult val -> AuthResult val
$cmin :: forall val.
Ord val =>
AuthResult val -> AuthResult val -> AuthResult val
min :: AuthResult val -> AuthResult val -> AuthResult val
Ord, ReadPrec [AuthResult val]
ReadPrec (AuthResult val)
Int -> ReadS (AuthResult val)
ReadS [AuthResult val]
(Int -> ReadS (AuthResult val))
-> ReadS [AuthResult val]
-> ReadPrec (AuthResult val)
-> ReadPrec [AuthResult val]
-> Read (AuthResult val)
forall val. Read val => ReadPrec [AuthResult val]
forall val. Read val => ReadPrec (AuthResult val)
forall val. Read val => Int -> ReadS (AuthResult val)
forall val. Read val => ReadS [AuthResult val]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: forall val. Read val => Int -> ReadS (AuthResult val)
readsPrec :: Int -> ReadS (AuthResult val)
$creadList :: forall val. Read val => ReadS [AuthResult val]
readList :: ReadS [AuthResult val]
$creadPrec :: forall val. Read val => ReadPrec (AuthResult val)
readPrec :: ReadPrec (AuthResult val)
$creadListPrec :: forall val. Read val => ReadPrec [AuthResult val]
readListPrec :: ReadPrec [AuthResult val]
Read, Int -> AuthResult val -> ShowS
[AuthResult val] -> ShowS
AuthResult val -> String
(Int -> AuthResult val -> ShowS)
-> (AuthResult val -> String)
-> ([AuthResult val] -> ShowS)
-> Show (AuthResult val)
forall val. Show val => Int -> AuthResult val -> ShowS
forall val. Show val => [AuthResult val] -> ShowS
forall val. Show val => AuthResult val -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall val. Show val => Int -> AuthResult val -> ShowS
showsPrec :: Int -> AuthResult val -> ShowS
$cshow :: forall val. Show val => AuthResult val -> String
show :: AuthResult val -> String
$cshowList :: forall val. Show val => [AuthResult val] -> ShowS
showList :: [AuthResult val] -> ShowS
Show, Functor AuthResult
Foldable AuthResult
(Functor AuthResult, Foldable AuthResult) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> AuthResult a -> f (AuthResult b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    AuthResult (f a) -> f (AuthResult a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> AuthResult a -> m (AuthResult b))
-> (forall (m :: * -> *) a.
    Monad m =>
    AuthResult (m a) -> m (AuthResult a))
-> Traversable AuthResult
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
AuthResult (m a) -> m (AuthResult a)
forall (f :: * -> *) a.
Applicative f =>
AuthResult (f a) -> f (AuthResult a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AuthResult a -> m (AuthResult b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AuthResult a -> f (AuthResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AuthResult a -> f (AuthResult b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AuthResult a -> f (AuthResult b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
AuthResult (f a) -> f (AuthResult a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
AuthResult (f a) -> f (AuthResult a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AuthResult a -> m (AuthResult b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AuthResult a -> m (AuthResult b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
AuthResult (m a) -> m (AuthResult a)
sequence :: forall (m :: * -> *) a.
Monad m =>
AuthResult (m a) -> m (AuthResult a)
Traversable)

instance Semigroup (AuthResult val) where
  AuthResult val
Indefinite <> :: AuthResult val -> AuthResult val -> AuthResult val
<> AuthResult val
y = AuthResult val
y
  AuthResult val
x <> AuthResult val
_ = AuthResult val
x

instance Monoid (AuthResult val) where
  mempty :: AuthResult val
mempty = AuthResult val
forall val. AuthResult val
Indefinite
  mappend :: AuthResult val -> AuthResult val -> AuthResult val
mappend = AuthResult val -> AuthResult val -> AuthResult val
forall a. Semigroup a => a -> a -> a
(<>)

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

instance Monad AuthResult where
  return :: forall a. a -> AuthResult a
return = a -> AuthResult a
forall a. a -> AuthResult a
Authenticated
  Authenticated a
v >>= :: forall a b. AuthResult a -> (a -> AuthResult b) -> AuthResult b
>>= a -> AuthResult b
f = a -> AuthResult b
f a
v
  AuthResult a
BadPassword >>= a -> AuthResult b
_ = AuthResult b
forall val. AuthResult val
BadPassword
  AuthResult a
NoSuchUser >>= a -> AuthResult b
_ = AuthResult b
forall val. AuthResult val
NoSuchUser
  AuthResult a
Indefinite >>= a -> AuthResult b
_ = AuthResult b
forall val. AuthResult val
Indefinite

instance Alternative AuthResult where
  empty :: forall val. AuthResult val
empty = AuthResult a
forall val. AuthResult val
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall val. AuthResult val -> AuthResult val -> AuthResult val
(<|>) = AuthResult a -> AuthResult a -> AuthResult a
forall val. AuthResult val -> AuthResult val -> AuthResult val
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus AuthResult where
  mzero :: forall val. AuthResult val
mzero = AuthResult a
forall a. Monoid a => a
mempty
  mplus :: forall val. AuthResult val -> AuthResult val -> AuthResult val
mplus = AuthResult a -> AuthResult a -> AuthResult a
forall a. Semigroup a => a -> a -> a
(<>)

-- | An @AuthCheck@ is the function used to decide the authentication status
-- (the 'AuthResult') of a request. Different @AuthCheck@s may be combined as a
-- Monoid or Alternative; the semantics of this is that the *first*
-- non-'Indefinite' result from left to right is used and the rest are ignored.
newtype AuthCheck val = AuthCheck
  {forall val. AuthCheck val -> Request -> IO (AuthResult val)
runAuthCheck :: Request -> IO (AuthResult val)}
  deriving ((forall a b. (a -> b) -> AuthCheck a -> AuthCheck b)
-> (forall a b. a -> AuthCheck b -> AuthCheck a)
-> Functor AuthCheck
forall a b. a -> AuthCheck b -> AuthCheck a
forall a b. (a -> b) -> AuthCheck a -> AuthCheck b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> AuthCheck a -> AuthCheck b
fmap :: forall a b. (a -> b) -> AuthCheck a -> AuthCheck b
$c<$ :: forall a b. a -> AuthCheck b -> AuthCheck a
<$ :: forall a b. a -> AuthCheck b -> AuthCheck a
Functor, (forall x. AuthCheck val -> Rep (AuthCheck val) x)
-> (forall x. Rep (AuthCheck val) x -> AuthCheck val)
-> Generic (AuthCheck val)
forall x. Rep (AuthCheck val) x -> AuthCheck val
forall x. AuthCheck val -> Rep (AuthCheck val) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall val x. Rep (AuthCheck val) x -> AuthCheck val
forall val x. AuthCheck val -> Rep (AuthCheck val) x
$cfrom :: forall val x. AuthCheck val -> Rep (AuthCheck val) x
from :: forall x. AuthCheck val -> Rep (AuthCheck val) x
$cto :: forall val x. Rep (AuthCheck val) x -> AuthCheck val
to :: forall x. Rep (AuthCheck val) x -> AuthCheck val
Generic)

instance Semigroup (AuthCheck val) where
  AuthCheck Request -> IO (AuthResult val)
f <> :: AuthCheck val -> AuthCheck val -> AuthCheck val
<> AuthCheck Request -> IO (AuthResult val)
g = (Request -> IO (AuthResult val)) -> AuthCheck val
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult val)) -> AuthCheck val)
-> (Request -> IO (AuthResult val)) -> AuthCheck val
forall a b. (a -> b) -> a -> b
$ \Request
x -> do
    AuthResult val
fx <- Request -> IO (AuthResult val)
f Request
x
    case AuthResult val
fx of
      AuthResult val
Indefinite -> Request -> IO (AuthResult val)
g Request
x
      AuthResult val
r -> AuthResult val -> IO (AuthResult val)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult val
r

instance Monoid (AuthCheck val) where
  mempty :: AuthCheck val
mempty = (Request -> IO (AuthResult val)) -> AuthCheck val
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult val)) -> AuthCheck val)
-> (Request -> IO (AuthResult val)) -> AuthCheck val
forall a b. (a -> b) -> a -> b
$ IO (AuthResult val) -> Request -> IO (AuthResult val)
forall a b. a -> b -> a
const (IO (AuthResult val) -> Request -> IO (AuthResult val))
-> IO (AuthResult val) -> Request -> IO (AuthResult val)
forall a b. (a -> b) -> a -> b
$ AuthResult val -> IO (AuthResult val)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult val
forall a. Monoid a => a
mempty
  mappend :: AuthCheck val -> AuthCheck val -> AuthCheck val
mappend = AuthCheck val -> AuthCheck val -> AuthCheck val
forall a. Semigroup a => a -> a -> a
(<>)

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

instance Monad AuthCheck where
  return :: forall a. a -> AuthCheck a
return = (Request -> IO (AuthResult a)) -> AuthCheck a
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult a)) -> AuthCheck a)
-> (a -> Request -> IO (AuthResult a)) -> a -> AuthCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (AuthResult a) -> Request -> IO (AuthResult a)
forall a. a -> Request -> a
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (AuthResult a) -> Request -> IO (AuthResult a))
-> (a -> IO (AuthResult a)) -> a -> Request -> IO (AuthResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthResult a -> IO (AuthResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthResult a -> IO (AuthResult a))
-> (a -> AuthResult a) -> a -> IO (AuthResult a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> AuthResult a
forall a. a -> AuthResult a
forall (m :: * -> *) a. Monad m => a -> m a
return
  AuthCheck Request -> IO (AuthResult a)
ac >>= :: forall a b. AuthCheck a -> (a -> AuthCheck b) -> AuthCheck b
>>= a -> AuthCheck b
f = (Request -> IO (AuthResult b)) -> AuthCheck b
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult b)) -> AuthCheck b)
-> (Request -> IO (AuthResult b)) -> AuthCheck b
forall a b. (a -> b) -> a -> b
$ \Request
req -> do
    AuthResult a
aresult <- Request -> IO (AuthResult a)
ac Request
req
    case AuthResult a
aresult of
      Authenticated a
usr -> AuthCheck b -> Request -> IO (AuthResult b)
forall val. AuthCheck val -> Request -> IO (AuthResult val)
runAuthCheck (a -> AuthCheck b
f a
usr) Request
req
      AuthResult a
BadPassword -> AuthResult b -> IO (AuthResult b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult b
forall val. AuthResult val
BadPassword
      AuthResult a
NoSuchUser -> AuthResult b -> IO (AuthResult b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult b
forall val. AuthResult val
NoSuchUser
      AuthResult a
Indefinite -> AuthResult b -> IO (AuthResult b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult b
forall val. AuthResult val
Indefinite

#if !MIN_VERSION_base(4,13,0)
  fail = Fail.fail
#endif

instance Fail.MonadFail AuthCheck where
  fail :: forall a. String -> AuthCheck a
fail String
_ = (Request -> IO (AuthResult a)) -> AuthCheck a
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult a)) -> AuthCheck a)
-> (IO (AuthResult a) -> Request -> IO (AuthResult a))
-> IO (AuthResult a)
-> AuthCheck a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (AuthResult a) -> Request -> IO (AuthResult a)
forall a b. a -> b -> a
const (IO (AuthResult a) -> AuthCheck a)
-> IO (AuthResult a) -> AuthCheck a
forall a b. (a -> b) -> a -> b
$ AuthResult a -> IO (AuthResult a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthResult a
forall val. AuthResult val
Indefinite

instance MonadReader Request AuthCheck where
  ask :: AuthCheck Request
ask = (Request -> IO (AuthResult Request)) -> AuthCheck Request
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult Request)) -> AuthCheck Request)
-> (Request -> IO (AuthResult Request)) -> AuthCheck Request
forall a b. (a -> b) -> a -> b
$ \Request
x -> AuthResult Request -> IO (AuthResult Request)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Request -> AuthResult Request
forall a. a -> AuthResult a
Authenticated Request
x)
  local :: forall a. (Request -> Request) -> AuthCheck a -> AuthCheck a
local Request -> Request
f (AuthCheck Request -> IO (AuthResult a)
check) = (Request -> IO (AuthResult a)) -> AuthCheck a
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult a)) -> AuthCheck a)
-> (Request -> IO (AuthResult a)) -> AuthCheck a
forall a b. (a -> b) -> a -> b
$ \Request
req -> Request -> IO (AuthResult a)
check (Request -> Request
f Request
req)

instance MonadIO AuthCheck where
  liftIO :: forall a. IO a -> AuthCheck a
liftIO IO a
action = (Request -> IO (AuthResult a)) -> AuthCheck a
forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck ((Request -> IO (AuthResult a)) -> AuthCheck a)
-> (Request -> IO (AuthResult a)) -> AuthCheck a
forall a b. (a -> b) -> a -> b
$ IO (AuthResult a) -> Request -> IO (AuthResult a)
forall a b. a -> b -> a
const (IO (AuthResult a) -> Request -> IO (AuthResult a))
-> IO (AuthResult a) -> Request -> IO (AuthResult a)
forall a b. (a -> b) -> a -> b
$ a -> AuthResult a
forall a. a -> AuthResult a
Authenticated (a -> AuthResult a) -> IO a -> IO (AuthResult a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action

instance MonadTime AuthCheck where
  currentTime :: AuthCheck UTCTime
currentTime = IO UTCTime -> AuthCheck UTCTime
forall a. IO a -> AuthCheck a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

instance Alternative AuthCheck where
  empty :: forall val. AuthCheck val
empty = AuthCheck a
forall val. AuthCheck val
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: forall val. AuthCheck val -> AuthCheck val -> AuthCheck val
(<|>) = AuthCheck a -> AuthCheck a -> AuthCheck a
forall val. AuthCheck val -> AuthCheck val -> AuthCheck val
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus AuthCheck where
  mzero :: forall val. AuthCheck val
mzero = AuthCheck a
forall a. Monoid a => a
mempty
  mplus :: forall val. AuthCheck val -> AuthCheck val -> AuthCheck val
mplus = AuthCheck a -> AuthCheck a -> AuthCheck a
forall a. Semigroup a => a -> a -> a
(<>)