{-# LANGUAGE CPP #-}
module Servant.Auth.Server.Internal.Types where

import Control.Applicative
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)

import qualified Control.Monad.Fail as Fail

-- | 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
/= :: AuthResult val -> AuthResult val -> Bool
$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
Eq, 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
showList :: [AuthResult val] -> ShowS
$cshowList :: forall val. Show val => [AuthResult val] -> ShowS
show :: AuthResult val -> String
$cshow :: forall val. Show val => AuthResult val -> String
showsPrec :: Int -> AuthResult val -> ShowS
$cshowsPrec :: forall val. Show val => Int -> AuthResult val -> ShowS
Show, 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
readListPrec :: ReadPrec [AuthResult val]
$creadListPrec :: forall val. Read val => ReadPrec [AuthResult val]
readPrec :: ReadPrec (AuthResult val)
$creadPrec :: forall val. Read val => ReadPrec (AuthResult val)
readList :: ReadS [AuthResult val]
$creadList :: forall val. Read val => ReadS [AuthResult val]
readsPrec :: Int -> ReadS (AuthResult val)
$creadsPrec :: forall val. Read val => Int -> ReadS (AuthResult val)
Read, (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
$cto :: forall val x. Rep (AuthResult val) x -> AuthResult val
$cfrom :: forall val x. AuthResult val -> Rep (AuthResult val) x
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
min :: AuthResult val -> AuthResult val -> AuthResult val
$cmin :: forall val.
Ord val =>
AuthResult val -> AuthResult val -> AuthResult val
max :: AuthResult val -> AuthResult val -> AuthResult val
$cmax :: forall val.
Ord val =>
AuthResult val -> AuthResult val -> AuthResult val
>= :: 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
$c< :: forall val. Ord val => AuthResult val -> AuthResult val -> Bool
compare :: AuthResult val -> AuthResult val -> Ordering
$ccompare :: forall val. Ord val => AuthResult val -> AuthResult val -> Ordering
$cp1Ord :: forall val. Ord val => Eq (AuthResult val)
Ord, a -> AuthResult b -> AuthResult a
(a -> b) -> AuthResult a -> AuthResult b
(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
<$ :: a -> AuthResult b -> AuthResult a
$c<$ :: forall a b. a -> AuthResult b -> AuthResult a
fmap :: (a -> b) -> AuthResult a -> AuthResult b
$cfmap :: forall a b. (a -> b) -> AuthResult a -> AuthResult b
Functor, 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
(a -> f b) -> AuthResult a -> f (AuthResult b)
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)
sequence :: AuthResult (m a) -> m (AuthResult a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
AuthResult (m a) -> m (AuthResult a)
mapM :: (a -> m b) -> AuthResult a -> m (AuthResult b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AuthResult a -> m (AuthResult b)
sequenceA :: AuthResult (f a) -> f (AuthResult a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
AuthResult (f a) -> f (AuthResult a)
traverse :: (a -> f b) -> AuthResult a -> f (AuthResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> AuthResult a -> f (AuthResult b)
$cp2Traversable :: Foldable AuthResult
$cp1Traversable :: Functor AuthResult
Traversable, AuthResult a -> Bool
(a -> m) -> AuthResult a -> m
(a -> b -> b) -> b -> AuthResult a -> b
(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
product :: AuthResult a -> a
$cproduct :: forall a. Num a => AuthResult a -> a
sum :: AuthResult a -> a
$csum :: forall a. Num a => AuthResult a -> a
minimum :: AuthResult a -> a
$cminimum :: forall a. Ord a => AuthResult a -> a
maximum :: AuthResult a -> a
$cmaximum :: forall a. Ord a => AuthResult a -> a
elem :: a -> AuthResult a -> Bool
$celem :: forall a. Eq a => a -> AuthResult a -> Bool
length :: AuthResult a -> Int
$clength :: forall a. AuthResult a -> Int
null :: AuthResult a -> Bool
$cnull :: forall a. AuthResult a -> Bool
toList :: AuthResult a -> [a]
$ctoList :: forall a. AuthResult a -> [a]
foldl1 :: (a -> a -> a) -> AuthResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AuthResult a -> a
foldr1 :: (a -> a -> a) -> AuthResult a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> AuthResult a -> a
foldl' :: (b -> a -> b) -> b -> AuthResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> AuthResult a -> b
foldl :: (b -> a -> b) -> b -> AuthResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> AuthResult a -> b
foldr' :: (a -> b -> b) -> b -> AuthResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
foldr :: (a -> b -> b) -> b -> AuthResult a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
foldMap' :: (a -> m) -> AuthResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
foldMap :: (a -> m) -> AuthResult a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
fold :: AuthResult m -> m
$cfold :: forall m. Monoid m => AuthResult m -> m
Foldable)

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 :: a -> AuthResult a
pure = a -> AuthResult a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: 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 :: a -> AuthResult a
return = a -> AuthResult a
forall a. a -> AuthResult a
Authenticated
  Authenticated a
v >>= :: 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 :: AuthResult a
empty = AuthResult a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: AuthResult a -> AuthResult a -> AuthResult a
(<|>) = AuthResult a -> AuthResult a -> AuthResult a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
mplus

instance MonadPlus AuthResult where
  mzero :: AuthResult a
mzero = AuthResult a
forall a. Monoid a => a
mempty
  mplus :: AuthResult a -> AuthResult a -> AuthResult a
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
  { AuthCheck val -> Request -> IO (AuthResult val)
runAuthCheck :: Request -> IO (AuthResult val) }
  deriving ((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
$cto :: forall val x. Rep (AuthCheck val) x -> AuthCheck val
$cfrom :: forall val x. AuthCheck val -> Rep (AuthCheck val) x
Generic, a -> AuthCheck b -> AuthCheck a
(a -> b) -> AuthCheck a -> AuthCheck b
(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
<$ :: a -> AuthCheck b -> AuthCheck a
$c<$ :: forall a b. a -> AuthCheck b -> AuthCheck a
fmap :: (a -> b) -> AuthCheck a -> AuthCheck b
$cfmap :: forall a b. (a -> b) -> AuthCheck a -> AuthCheck b
Functor)

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 (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 (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 :: a -> AuthCheck a
pure = a -> AuthCheck a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: 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 :: 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 (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 (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 (m :: * -> *) a. Monad m => a -> m a
return
  AuthCheck Request -> IO (AuthResult a)
ac >>= :: 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 (m :: * -> *) a. Monad m => a -> m a
return AuthResult b
forall val. AuthResult val
BadPassword
      AuthResult a
NoSuchUser        -> AuthResult b -> IO (AuthResult b)
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 (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 :: 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 (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 (m :: * -> *) a. Monad m => a -> m a
return (Request -> AuthResult Request
forall a. a -> AuthResult a
Authenticated Request
x)
  local :: (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 :: 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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime

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

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