{-# LANGUAGE DerivingStrategies #-}

module Hasura.Server.Auth
  ( getUserInfoWithExpTime,
    AuthMode (..),
    setupAuthMode,
    AdminSecretHash,
    unsafeMkAdminSecretHash,
    hashAdminSecret,

    -- * WebHook related
    AuthHookType (..),
    AuthHook (..),

    -- * JWT related
    RawJWT,
    JWTConfig (..),
    JWTCtx (..),
    JWKSet (..),
    processJwt,
    updateJwkRef,
    UserAuthentication (..),

    -- * Exposed for testing
    getUserInfoWithExpTime_,
  )
where

import Control.Concurrent.Extended (ForkableMonadIO, forkManagedT)
import Control.Monad.Morph (hoist)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Trans.Managed (ManagedT)
import Crypto.Hash qualified as Crypto
import Data.ByteArray qualified as BA
import Data.ByteString (ByteString)
import Data.HashSet qualified as Set
import Data.Hashable qualified as Hash
import Data.IORef (newIORef)
import Data.List qualified as L
import Data.Text.Encoding qualified as T
import Data.Time.Clock (UTCTime)
import Hasura.Base.Error
import Hasura.GraphQL.Transport.HTTP.Protocol (ReqsText)
import Hasura.Logging
import Hasura.Prelude
import Hasura.Server.Auth.JWT hiding (processJwt_)
import Hasura.Server.Auth.WebHook
import Hasura.Server.Utils
import Hasura.Session
import Hasura.Tracing qualified as Tracing
import Network.HTTP.Client qualified as HTTP
import Network.HTTP.Types qualified as HTTP

-- | Typeclass representing the @UserInfo@ authorization and resolving effect
class (Monad m) => UserAuthentication m where
  resolveUserInfo ::
    Logger Hasura ->
    HTTP.Manager ->
    -- | request headers
    [HTTP.Header] ->
    AuthMode ->
    Maybe ReqsText ->
    m (Either QErr (UserInfo, Maybe UTCTime, [HTTP.Header]))

-- | The hashed admin password. 'hashAdminSecret' is our public interface for
-- constructing the secret.
--
-- To prevent misuse and leaking we keep this opaque and don't provide
-- instances that could leak information. Likewise for 'AuthMode'.
--
-- Although this exists only in memory we store only a hash of the admin secret
-- primarily in order to:
--
--     - prevent theoretical timing attacks from a naive `==` check
--     - prevent misuse or inadvertent leaking of the secret
newtype AdminSecretHash = AdminSecretHash (Crypto.Digest Crypto.SHA512)
  deriving (Eq AdminSecretHash
Eq AdminSecretHash
-> (AdminSecretHash -> AdminSecretHash -> Ordering)
-> (AdminSecretHash -> AdminSecretHash -> Bool)
-> (AdminSecretHash -> AdminSecretHash -> Bool)
-> (AdminSecretHash -> AdminSecretHash -> Bool)
-> (AdminSecretHash -> AdminSecretHash -> Bool)
-> (AdminSecretHash -> AdminSecretHash -> AdminSecretHash)
-> (AdminSecretHash -> AdminSecretHash -> AdminSecretHash)
-> Ord AdminSecretHash
AdminSecretHash -> AdminSecretHash -> Bool
AdminSecretHash -> AdminSecretHash -> Ordering
AdminSecretHash -> AdminSecretHash -> AdminSecretHash
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
min :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
$cmin :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
max :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
$cmax :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
>= :: AdminSecretHash -> AdminSecretHash -> Bool
$c>= :: AdminSecretHash -> AdminSecretHash -> Bool
> :: AdminSecretHash -> AdminSecretHash -> Bool
$c> :: AdminSecretHash -> AdminSecretHash -> Bool
<= :: AdminSecretHash -> AdminSecretHash -> Bool
$c<= :: AdminSecretHash -> AdminSecretHash -> Bool
< :: AdminSecretHash -> AdminSecretHash -> Bool
$c< :: AdminSecretHash -> AdminSecretHash -> Bool
compare :: AdminSecretHash -> AdminSecretHash -> Ordering
$ccompare :: AdminSecretHash -> AdminSecretHash -> Ordering
$cp1Ord :: Eq AdminSecretHash
Ord, AdminSecretHash -> AdminSecretHash -> Bool
(AdminSecretHash -> AdminSecretHash -> Bool)
-> (AdminSecretHash -> AdminSecretHash -> Bool)
-> Eq AdminSecretHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AdminSecretHash -> AdminSecretHash -> Bool
$c/= :: AdminSecretHash -> AdminSecretHash -> Bool
== :: AdminSecretHash -> AdminSecretHash -> Bool
$c== :: AdminSecretHash -> AdminSecretHash -> Bool
Eq)

unsafeMkAdminSecretHash :: (Crypto.Digest Crypto.SHA512) -> AdminSecretHash
unsafeMkAdminSecretHash :: Digest SHA512 -> AdminSecretHash
unsafeMkAdminSecretHash = Digest SHA512 -> AdminSecretHash
AdminSecretHash

instance Hash.Hashable AdminSecretHash where
  hashWithSalt :: Int -> AdminSecretHash -> Int
hashWithSalt Int
salt (AdminSecretHash Digest SHA512
h) = Int -> ByteString -> Int
forall a. Hashable a => Int -> a -> Int
Hash.hashWithSalt @ByteString Int
salt (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ Digest SHA512 -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert Digest SHA512
h

-- We don't want to be able to leak the secret hash. This is a dummy instance
-- to support 'Show AuthMode' which we want for testing.
instance Show AdminSecretHash where
  show :: AdminSecretHash -> String
show AdminSecretHash
_ = String
"(error \"AdminSecretHash hidden\")"

hashAdminSecret :: Text -> AdminSecretHash
hashAdminSecret :: Text -> AdminSecretHash
hashAdminSecret = Digest SHA512 -> AdminSecretHash
AdminSecretHash (Digest SHA512 -> AdminSecretHash)
-> (Text -> Digest SHA512) -> Text -> AdminSecretHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA512
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
Crypto.hash (ByteString -> Digest SHA512)
-> (Text -> ByteString) -> Text -> Digest SHA512
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8

-- | The methods we'll use to derive roles for authenticating requests.
--
-- @Maybe RoleName@ below is the optionally-defined role for the
-- unauthenticated (anonymous) user.
--
-- See: https://hasura.io/docs/latest/graphql/core/auth/authentication/unauthenticated-access.html
data AuthMode
  = AMNoAuth
  | AMAdminSecret !(Set.HashSet AdminSecretHash) !(Maybe RoleName)
  | AMAdminSecretAndHook !(Set.HashSet AdminSecretHash) !AuthHook
  | AMAdminSecretAndJWT !(Set.HashSet AdminSecretHash) ![JWTCtx] !(Maybe RoleName)
  deriving (Int -> AuthMode -> ShowS
[AuthMode] -> ShowS
AuthMode -> String
(Int -> AuthMode -> ShowS)
-> (AuthMode -> String) -> ([AuthMode] -> ShowS) -> Show AuthMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthMode] -> ShowS
$cshowList :: [AuthMode] -> ShowS
show :: AuthMode -> String
$cshow :: AuthMode -> String
showsPrec :: Int -> AuthMode -> ShowS
$cshowsPrec :: Int -> AuthMode -> ShowS
Show, AuthMode -> AuthMode -> Bool
(AuthMode -> AuthMode -> Bool)
-> (AuthMode -> AuthMode -> Bool) -> Eq AuthMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthMode -> AuthMode -> Bool
$c/= :: AuthMode -> AuthMode -> Bool
== :: AuthMode -> AuthMode -> Bool
$c== :: AuthMode -> AuthMode -> Bool
Eq)

-- | Validate the user's requested authentication configuration, launching any
-- required maintenance threads for JWT etc.
--
-- This must only be run once, on launch.
setupAuthMode ::
  ( ForkableMonadIO m,
    Tracing.HasReporter m
  ) =>
  Set.HashSet AdminSecretHash ->
  Maybe AuthHook ->
  [JWTConfig] ->
  Maybe RoleName ->
  HTTP.Manager ->
  Logger Hasura ->
  ExceptT Text (ManagedT m) AuthMode
setupAuthMode :: HashSet AdminSecretHash
-> Maybe AuthHook
-> [JWTConfig]
-> Maybe RoleName
-> Manager
-> Logger Hasura
-> ExceptT Text (ManagedT m) AuthMode
setupAuthMode HashSet AdminSecretHash
adminSecretHashSet Maybe AuthHook
mWebHook [JWTConfig]
mJwtSecrets Maybe RoleName
mUnAuthRole Manager
httpManager Logger Hasura
logger =
  case (Bool -> Bool
not (HashSet AdminSecretHash -> Bool
forall a. HashSet a -> Bool
Set.null HashSet AdminSecretHash
adminSecretHashSet), Maybe AuthHook
mWebHook, Bool -> Bool
not ([JWTConfig] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JWTConfig]
mJwtSecrets)) of
    (Bool
True, Maybe AuthHook
Nothing, Bool
False) -> AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthMode -> ExceptT Text (ManagedT m) AuthMode)
-> AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall a b. (a -> b) -> a -> b
$ HashSet AdminSecretHash -> Maybe RoleName -> AuthMode
AMAdminSecret HashSet AdminSecretHash
adminSecretHashSet Maybe RoleName
mUnAuthRole
    (Bool
True, Maybe AuthHook
Nothing, Bool
True) -> do
      [JWTCtx]
jwtCtxs <- (JWTConfig -> ExceptT Text (ManagedT m) JWTCtx)
-> [JWTConfig] -> ExceptT Text (ManagedT m) [JWTCtx]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse JWTConfig -> ExceptT Text (ManagedT m) JWTCtx
forall (m :: * -> *).
(ForkableMonadIO m, HasReporter m) =>
JWTConfig -> ExceptT Text (ManagedT m) JWTCtx
mkJwtCtx ([JWTConfig] -> [JWTConfig]
forall a. Eq a => [a] -> [a]
L.nub [JWTConfig]
mJwtSecrets)
      AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthMode -> ExceptT Text (ManagedT m) AuthMode)
-> AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall a b. (a -> b) -> a -> b
$ HashSet AdminSecretHash -> [JWTCtx] -> Maybe RoleName -> AuthMode
AMAdminSecretAndJWT HashSet AdminSecretHash
adminSecretHashSet [JWTCtx]
jwtCtxs Maybe RoleName
mUnAuthRole
    -- Nothing below this case uses unauth role. Throw a fatal error if we would otherwise ignore
    -- that parameter, lest users misunderstand their auth configuration:
    (Bool, Maybe AuthHook, Bool)
_
      | Maybe RoleName -> Bool
forall a. Maybe a -> Bool
isJust Maybe RoleName
mUnAuthRole ->
        Text -> ExceptT Text (ManagedT m) AuthMode
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text (ManagedT m) AuthMode)
-> Text -> ExceptT Text (ManagedT m) AuthMode
forall a b. (a -> b) -> a -> b
$
          Text
"Fatal Error: --unauthorized-role (HASURA_GRAPHQL_UNAUTHORIZED_ROLE)"
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
requiresAdminScrtMsg
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and is not allowed when --auth-hook (HASURA_GRAPHQL_AUTH_HOOK) is set"
    (Bool
False, Maybe AuthHook
Nothing, Bool
False) -> AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall (m :: * -> *) a. Monad m => a -> m a
return AuthMode
AMNoAuth
    (Bool
True, Just AuthHook
hook, Bool
False) -> AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthMode -> ExceptT Text (ManagedT m) AuthMode)
-> AuthMode -> ExceptT Text (ManagedT m) AuthMode
forall a b. (a -> b) -> a -> b
$ HashSet AdminSecretHash -> AuthHook -> AuthMode
AMAdminSecretAndHook HashSet AdminSecretHash
adminSecretHashSet AuthHook
hook
    (Bool
False, Just AuthHook
_, Bool
False) ->
      Text -> ExceptT Text (ManagedT m) AuthMode
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text (ManagedT m) AuthMode)
-> Text -> ExceptT Text (ManagedT m) AuthMode
forall a b. (a -> b) -> a -> b
$
        Text
"Fatal Error : --auth-hook (HASURA_GRAPHQL_AUTH_HOOK)" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
requiresAdminScrtMsg
    (Bool
False, Maybe AuthHook
Nothing, Bool
True) ->
      Text -> ExceptT Text (ManagedT m) AuthMode
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Text -> ExceptT Text (ManagedT m) AuthMode)
-> Text -> ExceptT Text (ManagedT m) AuthMode
forall a b. (a -> b) -> a -> b
$
        Text
"Fatal Error : --jwt-secret (HASURA_GRAPHQL_JWT_SECRET)" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
requiresAdminScrtMsg
    (Bool
_, Just AuthHook
_, Bool
True) ->
      Text -> ExceptT Text (ManagedT m) AuthMode
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        Text
"Fatal Error: Both webhook and JWT mode cannot be enabled at the same time"
  where
    requiresAdminScrtMsg :: Text
requiresAdminScrtMsg =
      Text
" requires --admin-secret (HASURA_GRAPHQL_ADMIN_SECRET) or "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" --access-key (HASURA_GRAPHQL_ACCESS_KEY) to be set"

    mkJwtCtx ::
      ( ForkableMonadIO m,
        Tracing.HasReporter m
      ) =>
      JWTConfig ->
      ExceptT Text (ManagedT m) JWTCtx
    mkJwtCtx :: JWTConfig -> ExceptT Text (ManagedT m) JWTCtx
mkJwtCtx JWTConfig {Maybe NominalDiffTime
Maybe Audience
Maybe StringOrURI
Maybe JWTHeader
Either JWK URI
JWTClaims
jcHeader :: JWTConfig -> Maybe JWTHeader
jcAllowedSkew :: JWTConfig -> Maybe NominalDiffTime
jcClaims :: JWTConfig -> JWTClaims
jcIssuer :: JWTConfig -> Maybe StringOrURI
jcAudience :: JWTConfig -> Maybe Audience
jcKeyOrUrl :: JWTConfig -> Either JWK URI
jcHeader :: Maybe JWTHeader
jcAllowedSkew :: Maybe NominalDiffTime
jcClaims :: JWTClaims
jcIssuer :: Maybe StringOrURI
jcAudience :: Maybe Audience
jcKeyOrUrl :: Either JWK URI
..} = do
      IORef JWKSet
jwkRef <- case Either JWK URI
jcKeyOrUrl of
        Left JWK
jwk -> IO (IORef JWKSet) -> ExceptT Text (ManagedT m) (IORef JWKSet)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef JWKSet) -> ExceptT Text (ManagedT m) (IORef JWKSet))
-> IO (IORef JWKSet) -> ExceptT Text (ManagedT m) (IORef JWKSet)
forall a b. (a -> b) -> a -> b
$ JWKSet -> IO (IORef JWKSet)
forall a. a -> IO (IORef a)
newIORef ([JWK] -> JWKSet
JWKSet [JWK
jwk])
        Right URI
url -> URI -> ExceptT Text (ManagedT m) (IORef JWKSet)
getJwkFromUrl URI
url
      let jwtHeader :: JWTHeader
jwtHeader = JWTHeader -> Maybe JWTHeader -> JWTHeader
forall a. a -> Maybe a -> a
fromMaybe JWTHeader
JHAuthorization Maybe JWTHeader
jcHeader
      JWTCtx -> ExceptT Text (ManagedT m) JWTCtx
forall (m :: * -> *) a. Monad m => a -> m a
return (JWTCtx -> ExceptT Text (ManagedT m) JWTCtx)
-> JWTCtx -> ExceptT Text (ManagedT m) JWTCtx
forall a b. (a -> b) -> a -> b
$ IORef JWKSet
-> Maybe Audience
-> Maybe StringOrURI
-> JWTClaims
-> Maybe NominalDiffTime
-> JWTHeader
-> JWTCtx
JWTCtx IORef JWKSet
jwkRef Maybe Audience
jcAudience Maybe StringOrURI
jcIssuer JWTClaims
jcClaims Maybe NominalDiffTime
jcAllowedSkew JWTHeader
jwtHeader
      where
        -- if we can't find any expiry time for the JWK (either in @Expires@ header or @Cache-Control@
        -- header), do not start a background thread for refreshing the JWK
        getJwkFromUrl :: URI -> ExceptT Text (ManagedT m) (IORef JWKSet)
getJwkFromUrl URI
url = do
          IORef JWKSet
ref <- IO (IORef JWKSet) -> ExceptT Text (ManagedT m) (IORef JWKSet)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef JWKSet) -> ExceptT Text (ManagedT m) (IORef JWKSet))
-> IO (IORef JWKSet) -> ExceptT Text (ManagedT m) (IORef JWKSet)
forall a b. (a -> b) -> a -> b
$ JWKSet -> IO (IORef JWKSet)
forall a. a -> IO (IORef a)
newIORef (JWKSet -> IO (IORef JWKSet)) -> JWKSet -> IO (IORef JWKSet)
forall a b. (a -> b) -> a -> b
$ [JWK] -> JWKSet
JWKSet []
          Maybe NominalDiffTime
maybeExpiry <- (forall a. m a -> ManagedT m a)
-> ExceptT Text m (Maybe NominalDiffTime)
-> ExceptT Text (ManagedT m) (Maybe NominalDiffTime)
forall k (t :: (* -> *) -> k -> *) (m :: * -> *) (n :: * -> *)
       (b :: k).
(MFunctor t, Monad m) =>
(forall a. m a -> n a) -> t m b -> t n b
hoist forall a. m a -> ManagedT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT Text m (Maybe NominalDiffTime)
 -> ExceptT Text (ManagedT m) (Maybe NominalDiffTime))
-> ExceptT Text m (Maybe NominalDiffTime)
-> ExceptT Text (ManagedT m) (Maybe NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ ExceptT JwkFetchError (ExceptT Text m) (Maybe NominalDiffTime)
-> ExceptT Text m (Maybe NominalDiffTime)
forall (m :: * -> *) a.
MonadError Text m =>
ExceptT JwkFetchError m (Maybe a) -> m (Maybe a)
withJwkError (ExceptT JwkFetchError (ExceptT Text m) (Maybe NominalDiffTime)
 -> ExceptT Text m (Maybe NominalDiffTime))
-> ExceptT JwkFetchError (ExceptT Text m) (Maybe NominalDiffTime)
-> ExceptT Text m (Maybe NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ Text
-> TraceT
     (ExceptT JwkFetchError (ExceptT Text m)) (Maybe NominalDiffTime)
-> ExceptT JwkFetchError (ExceptT Text m) (Maybe NominalDiffTime)
forall (m :: * -> *) a.
(HasReporter m, MonadIO m) =>
Text -> TraceT m a -> m a
Tracing.runTraceT Text
"jwk init" (TraceT
   (ExceptT JwkFetchError (ExceptT Text m)) (Maybe NominalDiffTime)
 -> ExceptT JwkFetchError (ExceptT Text m) (Maybe NominalDiffTime))
-> TraceT
     (ExceptT JwkFetchError (ExceptT Text m)) (Maybe NominalDiffTime)
-> ExceptT JwkFetchError (ExceptT Text m) (Maybe NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> Manager
-> URI
-> IORef JWKSet
-> TraceT
     (ExceptT JwkFetchError (ExceptT Text m)) (Maybe NominalDiffTime)
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError JwkFetchError m,
 MonadTrace m) =>
Logger Hasura
-> Manager -> URI -> IORef JWKSet -> m (Maybe NominalDiffTime)
updateJwkRef Logger Hasura
logger Manager
httpManager URI
url IORef JWKSet
ref
          case Maybe NominalDiffTime
maybeExpiry of
            Maybe NominalDiffTime
Nothing -> IORef JWKSet -> ExceptT Text (ManagedT m) (IORef JWKSet)
forall (m :: * -> *) a. Monad m => a -> m a
return IORef JWKSet
ref
            Just NominalDiffTime
time -> do
              ExceptT Text (ManagedT m) Thread -> ExceptT Text (ManagedT m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ExceptT Text (ManagedT m) Thread -> ExceptT Text (ManagedT m) ())
-> (ManagedT m Thread -> ExceptT Text (ManagedT m) Thread)
-> ManagedT m Thread
-> ExceptT Text (ManagedT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ManagedT m Thread -> ExceptT Text (ManagedT m) Thread
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ManagedT m Thread -> ExceptT Text (ManagedT m) ())
-> ManagedT m Thread -> ExceptT Text (ManagedT m) ()
forall a b. (a -> b) -> a -> b
$
                String -> Logger Hasura -> m Void -> ManagedT m Thread
forall (m :: * -> *).
ForkableMonadIO m =>
String -> Logger Hasura -> m Void -> ManagedT m Thread
forkManagedT String
"jwkRefreshCtrl" Logger Hasura
logger (m Void -> ManagedT m Thread) -> m Void -> ManagedT m Thread
forall a b. (a -> b) -> a -> b
$
                  Logger Hasura
-> Manager -> URI -> IORef JWKSet -> DiffTime -> m Void
forall (m :: * -> *) void.
(MonadIO m, MonadBaseControl IO m, HasReporter m) =>
Logger Hasura
-> Manager -> URI -> IORef JWKSet -> DiffTime -> m void
jwkRefreshCtrl Logger Hasura
logger Manager
httpManager URI
url IORef JWKSet
ref (NominalDiffTime -> DiffTime
forall x y. (Duration x, Duration y) => x -> y
convertDuration NominalDiffTime
time)
              IORef JWKSet -> ExceptT Text (ManagedT m) (IORef JWKSet)
forall (m :: * -> *) a. Monad m => a -> m a
return IORef JWKSet
ref

        withJwkError :: ExceptT JwkFetchError m (Maybe a) -> m (Maybe a)
withJwkError ExceptT JwkFetchError m (Maybe a)
act = do
          Either JwkFetchError (Maybe a)
res <- ExceptT JwkFetchError m (Maybe a)
-> m (Either JwkFetchError (Maybe a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT JwkFetchError m (Maybe a)
act
          Either JwkFetchError (Maybe a)
-> (JwkFetchError -> m (Maybe a)) -> m (Maybe a)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either JwkFetchError (Maybe a)
res ((JwkFetchError -> m (Maybe a)) -> m (Maybe a))
-> (JwkFetchError -> m (Maybe a)) -> m (Maybe a)
forall a b. (a -> b) -> a -> b
$ \case
            -- when fetching JWK initially, except expiry parsing error, all errors are critical
            JFEHttpException HttpException
_ Text
msg -> Text -> m (Maybe a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
msg
            JFEHttpError URI
_ Status
_ ByteString
_ Text
e -> Text -> m (Maybe a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
e
            JFEJwkParseError Text
_ Text
e -> Text -> m (Maybe a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
e
            JFEExpiryParseError Maybe Text
_ Text
_ -> Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing

-- | Authenticate the request using the headers and the configured 'AuthMode'.
getUserInfoWithExpTime ::
  forall m.
  (MonadIO m, MonadBaseControl IO m, MonadError QErr m, Tracing.MonadTrace m) =>
  Logger Hasura ->
  HTTP.Manager ->
  [HTTP.Header] ->
  AuthMode ->
  Maybe ReqsText ->
  m (UserInfo, Maybe UTCTime, [HTTP.Header])
getUserInfoWithExpTime :: Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
getUserInfoWithExpTime = (Logger Hasura
 -> Manager
 -> AuthHook
 -> [Header]
 -> Maybe ReqsText
 -> m (UserInfo, Maybe UTCTime, [Header]))
-> ([JWTCtx]
    -> [Header]
    -> Maybe RoleName
    -> m (UserInfo, Maybe UTCTime, [Header]))
-> Logger Hasura
-> Manager
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *) mgr logger.
(MonadIO m, MonadError QErr m) =>
(logger
 -> mgr
 -> AuthHook
 -> [Header]
 -> Maybe ReqsText
 -> m (UserInfo, Maybe UTCTime, [Header]))
-> ([JWTCtx]
    -> [Header]
    -> Maybe RoleName
    -> m (UserInfo, Maybe UTCTime, [Header]))
-> logger
-> mgr
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
getUserInfoWithExpTime_ Logger Hasura
-> Manager
-> AuthHook
-> [Header]
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m,
 MonadTrace m) =>
Logger Hasura
-> Manager
-> AuthHook
-> [Header]
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
userInfoFromAuthHook [JWTCtx]
-> [Header]
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime, [Header])
forall (m :: * -> *).
(MonadIO m, MonadError QErr m) =>
[JWTCtx]
-> [Header]
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime, [Header])
processJwt

-- Broken out for testing with mocks:
getUserInfoWithExpTime_ ::
  forall m mgr logger.
  (MonadIO m, MonadError QErr m) =>
  -- | mock 'userInfoFromAuthHook'
  ( logger ->
    mgr ->
    AuthHook ->
    [HTTP.Header] ->
    Maybe ReqsText ->
    m (UserInfo, Maybe UTCTime, [HTTP.Header])
  ) ->
  -- | mock 'processJwt'
  ( [JWTCtx] ->
    [HTTP.Header] ->
    Maybe RoleName ->
    m (UserInfo, Maybe UTCTime, [HTTP.Header])
  ) ->
  logger ->
  mgr ->
  [HTTP.Header] ->
  AuthMode ->
  Maybe ReqsText ->
  m (UserInfo, Maybe UTCTime, [HTTP.Header])
getUserInfoWithExpTime_ :: (logger
 -> mgr
 -> AuthHook
 -> [Header]
 -> Maybe ReqsText
 -> m (UserInfo, Maybe UTCTime, [Header]))
-> ([JWTCtx]
    -> [Header]
    -> Maybe RoleName
    -> m (UserInfo, Maybe UTCTime, [Header]))
-> logger
-> mgr
-> [Header]
-> AuthMode
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
getUserInfoWithExpTime_ logger
-> mgr
-> AuthHook
-> [Header]
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
userInfoFromAuthHook_ [JWTCtx]
-> [Header]
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime, [Header])
processJwt_ logger
logger mgr
manager [Header]
rawHeaders AuthMode
authMode Maybe ReqsText
reqs = case AuthMode
authMode of
  AuthMode
AMNoAuth -> m UserInfo -> m (UserInfo, Maybe UTCTime, [Header])
forall (f :: * -> *) t a a. Functor f => f t -> f (t, Maybe a, [a])
withNoExpTime (m UserInfo -> m (UserInfo, Maybe UTCTime, [Header]))
-> m UserInfo -> m (UserInfo, Maybe UTCTime, [Header])
forall a b. (a -> b) -> a -> b
$ UserAdminSecret -> m UserInfo
mkUserInfoFallbackAdminRole UserAdminSecret
UAuthNotSet
  -- If hasura was started with an admin secret we:
  --   - check if a secret was sent in the request
  --     - if so, check it and authorize as admin else fail
  --   - if not proceed with either webhook or JWT auth if configured
  AMAdminSecret HashSet AdminSecretHash
adminSecretHashSet Maybe RoleName
maybeUnauthRole ->
    HashSet AdminSecretHash
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
checkingSecretIfSent HashSet AdminSecretHash
adminSecretHashSet (m (UserInfo, Maybe UTCTime, [Header])
 -> m (UserInfo, Maybe UTCTime, [Header]))
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
forall a b. (a -> b) -> a -> b
$
      m UserInfo -> m (UserInfo, Maybe UTCTime, [Header])
forall (f :: * -> *) t a a. Functor f => f t -> f (t, Maybe a, [a])
withNoExpTime
        -- Consider unauthorized role, if not found raise admin secret header required exception
        case Maybe RoleName
maybeUnauthRole of
          Maybe RoleName
Nothing ->
            Text -> m UserInfo
forall (m :: * -> *) a. QErrM m => Text -> m a
throw401 (Text -> m UserInfo) -> Text -> m UserInfo
forall a b. (a -> b) -> a -> b
$
              Text
forall a. IsString a => a
adminSecretHeader Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/"
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall a. IsString a => a
deprecatedAccessKeyHeader
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" required, but not found"
          Just RoleName
unAuthRole ->
            UserRoleBuild -> UserAdminSecret -> SessionVariables -> m UserInfo
forall (m :: * -> *).
MonadError QErr m =>
UserRoleBuild -> UserAdminSecret -> SessionVariables -> m UserInfo
mkUserInfo (RoleName -> UserRoleBuild
URBPreDetermined RoleName
unAuthRole) UserAdminSecret
UAdminSecretNotSent SessionVariables
sessionVariables
  -- this is the case that actually ends up consuming the request AST
  AMAdminSecretAndHook HashSet AdminSecretHash
adminSecretHashSet AuthHook
hook ->
    HashSet AdminSecretHash
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
checkingSecretIfSent HashSet AdminSecretHash
adminSecretHashSet (m (UserInfo, Maybe UTCTime, [Header])
 -> m (UserInfo, Maybe UTCTime, [Header]))
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
forall a b. (a -> b) -> a -> b
$ logger
-> mgr
-> AuthHook
-> [Header]
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
userInfoFromAuthHook_ logger
logger mgr
manager AuthHook
hook [Header]
rawHeaders Maybe ReqsText
reqs
  AMAdminSecretAndJWT HashSet AdminSecretHash
adminSecretHashSet [JWTCtx]
jwtSecrets Maybe RoleName
unAuthRole ->
    HashSet AdminSecretHash
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
checkingSecretIfSent HashSet AdminSecretHash
adminSecretHashSet (m (UserInfo, Maybe UTCTime, [Header])
 -> m (UserInfo, Maybe UTCTime, [Header]))
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
forall a b. (a -> b) -> a -> b
$ [JWTCtx]
-> [Header]
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime, [Header])
processJwt_ [JWTCtx]
jwtSecrets [Header]
rawHeaders Maybe RoleName
unAuthRole
  where
    -- CAREFUL!:
    mkUserInfoFallbackAdminRole :: UserAdminSecret -> m UserInfo
mkUserInfoFallbackAdminRole UserAdminSecret
adminSecretState =
      UserRoleBuild -> UserAdminSecret -> SessionVariables -> m UserInfo
forall (m :: * -> *).
MonadError QErr m =>
UserRoleBuild -> UserAdminSecret -> SessionVariables -> m UserInfo
mkUserInfo
        (RoleName -> UserRoleBuild
URBFromSessionVariablesFallback RoleName
adminRoleName)
        UserAdminSecret
adminSecretState
        SessionVariables
sessionVariables

    sessionVariables :: SessionVariables
sessionVariables = [Header] -> SessionVariables
mkSessionVariablesHeaders [Header]
rawHeaders

    checkingSecretIfSent ::
      Set.HashSet AdminSecretHash -> m (UserInfo, Maybe UTCTime, [HTTP.Header]) -> m (UserInfo, Maybe UTCTime, [HTTP.Header])
    checkingSecretIfSent :: HashSet AdminSecretHash
-> m (UserInfo, Maybe UTCTime, [Header])
-> m (UserInfo, Maybe UTCTime, [Header])
checkingSecretIfSent HashSet AdminSecretHash
adminSecretHashSet m (UserInfo, Maybe UTCTime, [Header])
actionIfNoAdminSecret = do
      let maybeRequestAdminSecret :: Maybe Text
maybeRequestAdminSecret =
            (Maybe Text -> Maybe Text -> Maybe Text)
-> [Maybe Text] -> Maybe Text
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Maybe Text -> Maybe Text -> Maybe Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
(<|>) ([Maybe Text] -> Maybe Text) -> [Maybe Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$
              (SessionVariable -> Maybe Text)
-> [SessionVariable] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map
                (SessionVariable -> SessionVariables -> Maybe Text
`getSessionVariableValue` SessionVariables
sessionVariables)
                [SessionVariable
forall a. IsString a => a
adminSecretHeader, SessionVariable
forall a. IsString a => a
deprecatedAccessKeyHeader]

      -- when admin secret is absent, run the action to retrieve UserInfo
      case Maybe Text
maybeRequestAdminSecret of
        Maybe Text
Nothing -> m (UserInfo, Maybe UTCTime, [Header])
actionIfNoAdminSecret
        Just Text
requestAdminSecret -> do
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (AdminSecretHash -> HashSet AdminSecretHash -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
Set.member (Text -> AdminSecretHash
hashAdminSecret Text
requestAdminSecret) HashSet AdminSecretHash
adminSecretHashSet) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
            Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throw401 (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
              Text
"invalid " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall a. IsString a => a
adminSecretHeader Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
forall a. IsString a => a
deprecatedAccessKeyHeader
          m UserInfo -> m (UserInfo, Maybe UTCTime, [Header])
forall (f :: * -> *) t a a. Functor f => f t -> f (t, Maybe a, [a])
withNoExpTime (m UserInfo -> m (UserInfo, Maybe UTCTime, [Header]))
-> m UserInfo -> m (UserInfo, Maybe UTCTime, [Header])
forall a b. (a -> b) -> a -> b
$ UserAdminSecret -> m UserInfo
mkUserInfoFallbackAdminRole UserAdminSecret
UAdminSecretSent

    withNoExpTime :: f t -> f (t, Maybe a, [a])
withNoExpTime f t
a = (,Maybe a
forall a. Maybe a
Nothing,[]) (t -> (t, Maybe a, [a])) -> f t -> f (t, Maybe a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f t
a