{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.ZAuth.Validation
( Env,
Validate,
mkEnv,
runValidate,
Failure (..),
validate,
validateUser,
validateAccess,
validateBot,
validateProvider,
check,
)
where
import Control.Lens
import Control.Monad.Except
import Data.ByteString qualified as Strict
import Data.ByteString.Conversion
import Data.Time.Clock.POSIX
import Data.Vector (Vector, (!))
import Data.Vector qualified as Vec
import Data.ZAuth.Token
import Imports
import Sodium.Crypto.Sign (PublicKey, Signature, verifyWith)
data Failure
=
Falsified
|
Expired
|
Invalid
|
Unsupported
deriving (Failure -> Failure -> Bool
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
/= :: Failure -> Failure -> Bool
Eq, Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
(Int -> Failure -> ShowS)
-> (Failure -> String) -> ([Failure] -> ShowS) -> Show Failure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Failure -> ShowS
showsPrec :: Int -> Failure -> ShowS
$cshow :: Failure -> String
show :: Failure -> String
$cshowList :: [Failure] -> ShowS
showList :: [Failure] -> ShowS
Show)
instance Exception Failure
newtype Env = Env
{Env -> Vector (Signature -> ByteString -> IO Bool)
verifyFns :: Vector (Signature -> Strict.ByteString -> IO Bool)}
newtype Validate a = Validate
{ forall a. Validate a -> ExceptT Failure (ReaderT Env IO) a
valid :: ExceptT Failure (ReaderT Env IO) a
}
deriving
( (forall a b. (a -> b) -> Validate a -> Validate b)
-> (forall a b. a -> Validate b -> Validate a) -> Functor Validate
forall a b. a -> Validate b -> Validate a
forall a b. (a -> b) -> Validate a -> Validate 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) -> Validate a -> Validate b
fmap :: forall a b. (a -> b) -> Validate a -> Validate b
$c<$ :: forall a b. a -> Validate b -> Validate a
<$ :: forall a b. a -> Validate b -> Validate a
Functor,
Functor Validate
Functor Validate =>
(forall a. a -> Validate a)
-> (forall a b. Validate (a -> b) -> Validate a -> Validate b)
-> (forall a b c.
(a -> b -> c) -> Validate a -> Validate b -> Validate c)
-> (forall a b. Validate a -> Validate b -> Validate b)
-> (forall a b. Validate a -> Validate b -> Validate a)
-> Applicative Validate
forall a. a -> Validate a
forall a b. Validate a -> Validate b -> Validate a
forall a b. Validate a -> Validate b -> Validate b
forall a b. Validate (a -> b) -> Validate a -> Validate b
forall a b c.
(a -> b -> c) -> Validate a -> Validate b -> Validate c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Validate a
pure :: forall a. a -> Validate a
$c<*> :: forall a b. Validate (a -> b) -> Validate a -> Validate b
<*> :: forall a b. Validate (a -> b) -> Validate a -> Validate b
$cliftA2 :: forall a b c.
(a -> b -> c) -> Validate a -> Validate b -> Validate c
liftA2 :: forall a b c.
(a -> b -> c) -> Validate a -> Validate b -> Validate c
$c*> :: forall a b. Validate a -> Validate b -> Validate b
*> :: forall a b. Validate a -> Validate b -> Validate b
$c<* :: forall a b. Validate a -> Validate b -> Validate a
<* :: forall a b. Validate a -> Validate b -> Validate a
Applicative,
Applicative Validate
Applicative Validate =>
(forall a b. Validate a -> (a -> Validate b) -> Validate b)
-> (forall a b. Validate a -> Validate b -> Validate b)
-> (forall a. a -> Validate a)
-> Monad Validate
forall a. a -> Validate a
forall a b. Validate a -> Validate b -> Validate b
forall a b. Validate a -> (a -> Validate b) -> Validate b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Validate a -> (a -> Validate b) -> Validate b
>>= :: forall a b. Validate a -> (a -> Validate b) -> Validate b
$c>> :: forall a b. Validate a -> Validate b -> Validate b
>> :: forall a b. Validate a -> Validate b -> Validate b
$creturn :: forall a. a -> Validate a
return :: forall a. a -> Validate a
Monad,
Monad Validate
Monad Validate =>
(forall a. IO a -> Validate a) -> MonadIO Validate
forall a. IO a -> Validate a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> Validate a
liftIO :: forall a. IO a -> Validate a
MonadIO,
MonadError Failure
)
mkEnv :: PublicKey -> [PublicKey] -> Env
mkEnv :: PublicKey -> [PublicKey] -> Env
mkEnv PublicKey
k [PublicKey]
kk = Vector (Signature -> ByteString -> IO Bool) -> Env
Env (Vector (Signature -> ByteString -> IO Bool) -> Env)
-> Vector (Signature -> ByteString -> IO Bool) -> Env
forall a b. (a -> b) -> a -> b
$ [Signature -> ByteString -> IO Bool]
-> Vector (Signature -> ByteString -> IO Bool)
forall a. [a] -> Vector a
Vec.fromList ((PublicKey -> Signature -> ByteString -> IO Bool)
-> [PublicKey] -> [Signature -> ByteString -> IO Bool]
forall a b. (a -> b) -> [a] -> [b]
map PublicKey -> Signature -> ByteString -> IO Bool
verifyWith (PublicKey
k PublicKey -> [PublicKey] -> [PublicKey]
forall a. a -> [a] -> [a]
: [PublicKey]
kk))
runValidate :: (MonadIO m) => Env -> Validate a -> m (Either Failure a)
runValidate :: forall (m :: * -> *) a.
MonadIO m =>
Env -> Validate a -> m (Either Failure a)
runValidate Env
v Validate a
m = IO (Either Failure a) -> m (Either Failure a)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Failure a) -> m (Either Failure a))
-> IO (Either Failure a) -> m (Either Failure a)
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Either Failure a) -> Env -> IO (Either Failure a)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ExceptT Failure (ReaderT Env IO) a
-> ReaderT Env IO (Either Failure a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Validate a -> ExceptT Failure (ReaderT Env IO) a
forall a. Validate a -> ExceptT Failure (ReaderT Env IO) a
valid Validate a
m)) Env
v
validateUser :: ByteString -> Validate (Token User)
validateUser :: ByteString -> Validate (Token User)
validateUser ByteString
t = Validate (Token User)
-> (Token User -> Validate (Token User))
-> Maybe (Token User)
-> Validate (Token User)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Failure -> Validate (Token User)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid) Token User -> Validate (Token User)
forall a. ToByteString a => Token a -> Validate (Token a)
check (ByteString -> Maybe (Token User)
forall a. FromByteString a => ByteString -> Maybe a
fromByteString ByteString
t)
validateAccess :: ByteString -> Validate (Token Access)
validateAccess :: ByteString -> Validate (Token Access)
validateAccess ByteString
t = Validate (Token Access)
-> (Token Access -> Validate (Token Access))
-> Maybe (Token Access)
-> Validate (Token Access)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Failure -> Validate (Token Access)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid) Token Access -> Validate (Token Access)
forall a. ToByteString a => Token a -> Validate (Token a)
check (ByteString -> Maybe (Token Access)
forall a. FromByteString a => ByteString -> Maybe a
fromByteString ByteString
t)
validateBot :: ByteString -> Validate (Token Bot)
validateBot :: ByteString -> Validate (Token Bot)
validateBot ByteString
t = Validate (Token Bot)
-> (Token Bot -> Validate (Token Bot))
-> Maybe (Token Bot)
-> Validate (Token Bot)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Failure -> Validate (Token Bot)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid) Token Bot -> Validate (Token Bot)
forall a. ToByteString a => Token a -> Validate (Token a)
check (ByteString -> Maybe (Token Bot)
forall a. FromByteString a => ByteString -> Maybe a
fromByteString ByteString
t)
validateProvider :: ByteString -> Validate (Token Provider)
validateProvider :: ByteString -> Validate (Token Provider)
validateProvider ByteString
t = Validate (Token Provider)
-> (Token Provider -> Validate (Token Provider))
-> Maybe (Token Provider)
-> Validate (Token Provider)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Failure -> Validate (Token Provider)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid) Token Provider -> Validate (Token Provider)
forall a. ToByteString a => Token a -> Validate (Token a)
check (ByteString -> Maybe (Token Provider)
forall a. FromByteString a => ByteString -> Maybe a
fromByteString ByteString
t)
validate ::
Maybe ByteString ->
Maybe ByteString ->
Validate (Token Access)
validate :: Maybe ByteString -> Maybe ByteString -> Validate (Token Access)
validate Maybe ByteString
Nothing Maybe ByteString
Nothing = Failure -> Validate (Token Access)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid
validate (Just ByteString
_) Maybe ByteString
Nothing = Failure -> Validate (Token Access)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid
validate Maybe ByteString
Nothing (Just ByteString
t) = ByteString -> Validate (Token Access)
validateAccess ByteString
t
validate (Just ByteString
c) (Just ByteString
t) = do
Token User
u <- Validate (Token User)
-> (Token User -> Validate (Token User))
-> Maybe (Token User)
-> Validate (Token User)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Failure -> Validate (Token User)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid) Token User -> Validate (Token User)
forall a. a -> Validate a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe (Token User)
forall a. FromByteString a => ByteString -> Maybe a
fromByteString ByteString
c)
Token Access
a <- Validate (Token Access)
-> (Token Access -> Validate (Token Access))
-> Maybe (Token Access)
-> Validate (Token Access)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Failure -> Validate (Token Access)
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid) Token Access -> Validate (Token Access)
forall a. a -> Validate a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> Maybe (Token Access)
forall a. FromByteString a => ByteString -> Maybe a
fromByteString ByteString
t)
Validate (Token User) -> Validate ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Validate (Token User) -> Validate ())
-> Validate (Token User) -> Validate ()
forall a b. (a -> b) -> a -> b
$ Token User -> Validate (Token User)
forall a. ToByteString a => Token a -> Validate (Token a)
check Token User
u
Validate (Token Access) -> Validate ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Validate (Token Access) -> Validate ())
-> Validate (Token Access) -> Validate ()
forall a b. (a -> b) -> a -> b
$ Token Access -> Validate (Token Access)
forall a. ToByteString a => Token a -> Validate (Token a)
check Token Access
a
Bool -> Validate () -> Validate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Token User
u Token User -> Getting UUID (Token User) UUID -> UUID
forall s a. s -> Getting a s a -> a
^. (User -> Const UUID User) -> Token User -> Const UUID (Token User)
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(a -> f a) -> Token a -> f (Token a)
body ((User -> Const UUID User)
-> Token User -> Const UUID (Token User))
-> ((UUID -> Const UUID UUID) -> User -> Const UUID User)
-> Getting UUID (Token User) UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UUID -> Const UUID UUID) -> User -> Const UUID User
Lens' User UUID
user UUID -> UUID -> Bool
forall a. Eq a => a -> a -> Bool
== Token Access
a Token Access -> Getting UUID (Token Access) UUID -> UUID
forall s a. s -> Getting a s a -> a
^. (Access -> Const UUID Access)
-> Token Access -> Const UUID (Token Access)
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(a -> f a) -> Token a -> f (Token a)
body ((Access -> Const UUID Access)
-> Token Access -> Const UUID (Token Access))
-> ((UUID -> Const UUID UUID) -> Access -> Const UUID Access)
-> Getting UUID (Token Access) UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UUID -> Const UUID UUID) -> Access -> Const UUID Access
Lens' Access UUID
userId) (Validate () -> Validate ()) -> Validate () -> Validate ()
forall a b. (a -> b) -> a -> b
$
Failure -> Validate ()
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid
Token Access -> Validate (Token Access)
forall a. a -> Validate a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Token Access
a
check :: (ToByteString a) => Token a -> Validate (Token a)
check :: forall a. ToByteString a => Token a -> Validate (Token a)
check Token a
t = do
Vector (Signature -> ByteString -> IO Bool)
ff <- ExceptT
Failure
(ReaderT Env IO)
(Vector (Signature -> ByteString -> IO Bool))
-> Validate (Vector (Signature -> ByteString -> IO Bool))
forall a. ExceptT Failure (ReaderT Env IO) a -> Validate a
Validate (ExceptT
Failure
(ReaderT Env IO)
(Vector (Signature -> ByteString -> IO Bool))
-> Validate (Vector (Signature -> ByteString -> IO Bool)))
-> ExceptT
Failure
(ReaderT Env IO)
(Vector (Signature -> ByteString -> IO Bool))
-> Validate (Vector (Signature -> ByteString -> IO Bool))
forall a b. (a -> b) -> a -> b
$ ReaderT Env IO (Vector (Signature -> ByteString -> IO Bool))
-> ExceptT
Failure
(ReaderT Env IO)
(Vector (Signature -> ByteString -> IO Bool))
forall (m :: * -> *) a. Monad m => m a -> ExceptT Failure m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ReaderT Env IO (Vector (Signature -> ByteString -> IO Bool))
-> ExceptT
Failure
(ReaderT Env IO)
(Vector (Signature -> ByteString -> IO Bool)))
-> ReaderT Env IO (Vector (Signature -> ByteString -> IO Bool))
-> ExceptT
Failure
(ReaderT Env IO)
(Vector (Signature -> ByteString -> IO Bool))
forall a b. (a -> b) -> a -> b
$ (Env -> Vector (Signature -> ByteString -> IO Bool))
-> ReaderT Env IO (Vector (Signature -> ByteString -> IO Bool))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Vector (Signature -> ByteString -> IO Bool)
verifyFns
let dat :: ByteString
dat = Builder -> ByteString
forall a. ToByteString a => a -> ByteString
toByteString' (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ Header -> a -> Builder
forall a. ToByteString a => Header -> a -> Builder
writeData (Token a
t Token a -> Getting Header (Token a) Header -> Header
forall s a. s -> Getting a s a -> a
^. Getting Header (Token a) Header
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(Header -> f Header) -> Token a -> f (Token a)
header) (Token a
t Token a -> Getting a (Token a) a -> a
forall s a. s -> Getting a s a -> a
^. Getting a (Token a) a
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(a -> f a) -> Token a -> f (Token a)
body)
let k :: Int
k = Token a
t Token a -> Getting Int (Token a) Int -> Int
forall s a. s -> Getting a s a -> a
^. (Header -> Const Int Header) -> Token a -> Const Int (Token a)
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(Header -> f Header) -> Token a -> f (Token a)
header ((Header -> Const Int Header) -> Token a -> Const Int (Token a))
-> ((Int -> Const Int Int) -> Header -> Const Int Header)
-> Getting Int (Token a) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Header -> Const Int Header
Lens' Header Int
key
Bool -> Validate () -> Validate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 Bool -> Bool -> Bool
|| Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Vector (Signature -> ByteString -> IO Bool) -> Int
forall a. Vector a -> Int
Vec.length Vector (Signature -> ByteString -> IO Bool)
ff) (Validate () -> Validate ()) -> Validate () -> Validate ()
forall a b. (a -> b) -> a -> b
$
Failure -> Validate ()
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Invalid
Bool
ok <- IO Bool -> Validate Bool
forall a. IO a -> Validate a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> Validate Bool) -> IO Bool -> Validate Bool
forall a b. (a -> b) -> a -> b
$ (Vector (Signature -> ByteString -> IO Bool)
ff Vector (Signature -> ByteString -> IO Bool)
-> Int -> Signature -> ByteString -> IO Bool
forall a. Vector a -> Int -> a
! (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)) (Token a
t Token a -> Getting Signature (Token a) Signature -> Signature
forall s a. s -> Getting a s a -> a
^. Getting Signature (Token a) Signature
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(Signature -> f Signature) -> Token a -> f (Token a)
signature) ByteString
dat
Bool -> Validate () -> Validate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ok (Validate () -> Validate ()) -> Validate () -> Validate ()
forall a b. (a -> b) -> a -> b
$
Failure -> Validate ()
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Falsified
Bool
isExpired <-
if Token a
t Token a -> Getting Integer (Token a) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. (Header -> Const Integer Header)
-> Token a -> Const Integer (Token a)
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(Header -> f Header) -> Token a -> f (Token a)
header ((Header -> Const Integer Header)
-> Token a -> Const Integer (Token a))
-> ((Integer -> Const Integer Integer)
-> Header -> Const Integer Header)
-> Getting Integer (Token a) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Const Integer Integer)
-> Header -> Const Integer Header
Lens' Header Integer
time Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== -Integer
1
then Bool -> Validate Bool
forall a. a -> Validate a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
else (Token a
t Token a -> Getting Integer (Token a) Integer -> Integer
forall s a. s -> Getting a s a -> a
^. (Header -> Const Integer Header)
-> Token a -> Const Integer (Token a)
forall a (f :: * -> *).
(Contravariant f, Functor f) =>
(Header -> f Header) -> Token a -> f (Token a)
header ((Header -> Const Integer Header)
-> Token a -> Const Integer (Token a))
-> ((Integer -> Const Integer Integer)
-> Header -> Const Integer Header)
-> Getting Integer (Token a) Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Const Integer Integer)
-> Header -> Const Integer Header
Lens' Header Integer
time <) (Integer -> Bool) -> Validate Integer -> Validate Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Validate Integer
forall (m :: * -> *). MonadIO m => m Integer
now
Bool -> Validate () -> Validate ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isExpired (Validate () -> Validate ()) -> Validate () -> Validate ()
forall a b. (a -> b) -> a -> b
$
Failure -> Validate ()
forall a. Failure -> Validate a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Failure
Expired
Token a -> Validate (Token a)
forall a. a -> Validate a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Token a
t
now :: (MonadIO m) => m Integer
now :: forall (m :: * -> *). MonadIO m => m Integer
now = POSIXTime -> Integer
forall b. Integral b => POSIXTime -> b
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Integer) -> m POSIXTime -> m Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO POSIXTime -> m POSIXTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime