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

import Control.Applicative
import Control.Monad        (MonadPlus(..), ap)
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
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
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)
ReadS [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 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, AuthResult val -> AuthResult val -> Ordering
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
Ord, 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
<$ :: forall a b. a -> AuthResult b -> AuthResult a
$c<$ :: forall a b. a -> AuthResult b -> AuthResult a
fmap :: forall a b. (a -> b) -> AuthResult a -> AuthResult b
$cfmap :: forall a b. (a -> b) -> AuthResult a -> AuthResult b
Functor, Functor AuthResult
Foldable 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)
sequence :: forall (m :: * -> *) a.
Monad m =>
AuthResult (m a) -> m (AuthResult a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
AuthResult (m a) -> m (AuthResult a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AuthResult a -> m (AuthResult b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> AuthResult a -> m (AuthResult b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
AuthResult (f a) -> f (AuthResult a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
AuthResult (f a) -> f (AuthResult a)
traverse :: 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)
Traversable, 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 :: forall a. Num a => AuthResult a -> a
$cproduct :: forall a. Num a => AuthResult a -> a
sum :: forall a. Num a => AuthResult a -> a
$csum :: forall a. Num a => AuthResult a -> a
minimum :: forall a. Ord a => AuthResult a -> a
$cminimum :: forall a. Ord a => AuthResult a -> a
maximum :: forall a. Ord a => AuthResult a -> a
$cmaximum :: forall a. Ord a => AuthResult a -> a
elem :: forall a. Eq a => a -> AuthResult a -> Bool
$celem :: forall a. Eq a => a -> AuthResult a -> Bool
length :: forall a. AuthResult a -> Int
$clength :: forall a. AuthResult a -> Int
null :: forall a. AuthResult a -> Bool
$cnull :: forall a. AuthResult a -> Bool
toList :: forall a. AuthResult a -> [a]
$ctoList :: forall a. AuthResult a -> [a]
foldl1 :: forall a. (a -> a -> a) -> AuthResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> AuthResult a -> a
foldr1 :: forall a. (a -> a -> a) -> AuthResult a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> AuthResult a -> a
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
$cfoldl :: forall b a. (b -> a -> 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
$cfoldr :: forall a b. (a -> b -> b) -> b -> AuthResult a -> b
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
$cfoldMap :: forall m a. Monoid m => (a -> m) -> AuthResult a -> m
fold :: forall m. Monoid m => 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 = forall val. AuthResult val
Indefinite
  mappend :: AuthResult val -> AuthResult val -> AuthResult val
mappend = forall a. Semigroup a => a -> a -> a
(<>)

instance Applicative AuthResult where
  pure :: forall a. a -> AuthResult a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a 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 = 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
_ = forall val. AuthResult val
BadPassword
  AuthResult a
NoSuchUser   >>= a -> AuthResult b
_ = forall val. AuthResult val
NoSuchUser
  AuthResult a
Indefinite   >>= a -> AuthResult b
_ = forall val. AuthResult val
Indefinite

instance Alternative AuthResult where
  empty :: forall val. AuthResult val
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: 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 = forall a. Monoid a => a
mempty
  mplus :: forall val. AuthResult val -> AuthResult val -> AuthResult val
mplus = 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.
(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, 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
<$ :: forall a b. a -> AuthCheck b -> AuthCheck a
$c<$ :: forall a b. a -> AuthCheck b -> AuthCheck a
fmap :: forall a b. (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 = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthResult val
r

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

instance Applicative AuthCheck where
  pure :: forall a. a -> AuthCheck a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a 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 = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck 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 -> forall val. AuthCheck val -> Request -> IO (AuthResult val)
runAuthCheck (a -> AuthCheck b
f a
usr) Request
req
      AuthResult a
BadPassword       -> forall (m :: * -> *) a. Monad m => a -> m a
return forall val. AuthResult val
BadPassword
      AuthResult a
NoSuchUser        -> forall (m :: * -> *) a. Monad m => a -> m a
return forall val. AuthResult val
NoSuchUser
      AuthResult a
Indefinite        -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall val. AuthResult val
Indefinite

instance MonadReader Request AuthCheck where
  ask :: AuthCheck Request
ask = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck forall a b. (a -> b) -> a -> b
$ \Request
x -> forall (m :: * -> *) a. Monad m => a -> m a
return (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) = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck 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 = forall val. (Request -> IO (AuthResult val)) -> AuthCheck val
AuthCheck forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a. a -> AuthResult a
Authenticated forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
action

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

instance Alternative AuthCheck where
  empty :: forall val. AuthCheck val
empty = forall (m :: * -> *) a. MonadPlus m => m a
mzero
  <|> :: 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 = forall a. Monoid a => a
mempty
  mplus :: forall val. AuthCheck val -> AuthCheck val -> AuthCheck val
mplus = forall a. Semigroup a => a -> a -> a
(<>)