{-# LANGUAGE DerivingStrategies #-}

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

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

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

    -- * Exposed for testing
    getUserInfoWithExpTime_,
  )
where

import Control.Monad.Trans.Control (MonadBaseControl)
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, readIORef)
import Data.List qualified as L
import Data.Text.Encoding qualified as T
import Data.Time.Clock (UTCTime, getCurrentTime)
import Hasura.Base.Error
import Hasura.GraphQL.Transport.HTTP.Protocol (ReqsText)
import Hasura.Logging
import Hasura.Prelude
import Hasura.RQL.Types.Roles (RoleName, adminRoleName)
import Hasura.Server.Auth.JWT hiding (processJwt_)
import Hasura.Server.Auth.WebHook
import Hasura.Server.Utils
import Hasura.Session (ExtraUserInfo, UserAdminSecret (..), UserInfo, UserRoleBuild (..), getSessionVariableValue, mkSessionVariablesHeaders, mkUserInfo)
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], ExtraUserInfo))

-- | 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
$ccompare :: AdminSecretHash -> AdminSecretHash -> Ordering
compare :: AdminSecretHash -> AdminSecretHash -> Ordering
$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
>= :: AdminSecretHash -> AdminSecretHash -> Bool
$cmax :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
max :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
$cmin :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
min :: AdminSecretHash -> AdminSecretHash -> AdminSecretHash
Ord, AdminSecretHash -> AdminSecretHash -> Bool
(AdminSecretHash -> AdminSecretHash -> Bool)
-> (AdminSecretHash -> AdminSecretHash -> Bool)
-> Eq AdminSecretHash
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AdminSecretHash -> AdminSecretHash -> Bool
== :: AdminSecretHash -> AdminSecretHash -> Bool
$c/= :: AdminSecretHash -> AdminSecretHash -> Bool
/= :: 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) = 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 (AuthMode -> AuthMode -> Bool
(AuthMode -> AuthMode -> Bool)
-> (AuthMode -> AuthMode -> Bool) -> Eq AuthMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AuthMode -> AuthMode -> Bool
== :: AuthMode -> AuthMode -> Bool
$c/= :: AuthMode -> AuthMode -> Bool
/= :: AuthMode -> AuthMode -> Bool
Eq, 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
$cshowsPrec :: Int -> AuthMode -> ShowS
showsPrec :: Int -> AuthMode -> ShowS
$cshow :: AuthMode -> String
show :: AuthMode -> String
$cshowList :: [AuthMode] -> ShowS
showList :: [AuthMode] -> ShowS
Show)

-- | In case JWT is used as an authentication mode, the JWKs are stored inside JWTCtx
-- as an `IORef`. `IORef` has pointer equality, so we need to compare the values
-- inside the `IORef` to check if the `JWTCtx` is same.
compareAuthMode :: AuthMode -> AuthMode -> IO Bool
compareAuthMode :: AuthMode -> AuthMode -> IO Bool
compareAuthMode AuthMode
authMode AuthMode
authMode' = do
  case (AuthMode
authMode, AuthMode
authMode') of
    ((AMAdminSecretAndJWT HashSet AdminSecretHash
adminSecretHash [JWTCtx]
jwtCtx Maybe RoleName
roleName), (AMAdminSecretAndJWT HashSet AdminSecretHash
adminSecretHash' [JWTCtx]
jwtCtx' Maybe RoleName
roleName')) -> do
      -- Since keyConfig of JWTCtx is an IORef it is necessary to extract the value before checking the equality
      [Bool]
isJwtCtxSame <- (JWTCtx -> JWTCtx -> IO Bool) -> [JWTCtx] -> [JWTCtx] -> IO [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM JWTCtx -> JWTCtx -> IO Bool
compareJWTConfig [JWTCtx]
jwtCtx [JWTCtx]
jwtCtx'
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (HashSet AdminSecretHash
adminSecretHash HashSet AdminSecretHash -> HashSet AdminSecretHash -> Bool
forall a. Eq a => a -> a -> Bool
== HashSet AdminSecretHash
adminSecretHash') Bool -> Bool -> Bool
&& ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
isJwtCtxSame) Bool -> Bool -> Bool
&& (Maybe RoleName
roleName Maybe RoleName -> Maybe RoleName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe RoleName
roleName')
    (AuthMode, AuthMode)
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ AuthMode
authMode AuthMode -> AuthMode -> Bool
forall a. Eq a => a -> a -> Bool
== AuthMode
authMode'
  where
    compareJWTConfig :: JWTCtx -> JWTCtx -> IO Bool
    compareJWTConfig :: JWTCtx -> JWTCtx -> IO Bool
compareJWTConfig (JWTCtx Maybe URI
url IORef (JWKSet, Maybe UTCTime)
keyConfigRef Maybe Audience
audM Maybe StringOrURI
iss JWTClaims
claims Maybe NominalDiffTime
allowedSkew JWTHeader
headers) (JWTCtx Maybe URI
url' IORef (JWKSet, Maybe UTCTime)
keyConfigRef' Maybe Audience
audM' Maybe StringOrURI
iss' JWTClaims
claims' Maybe NominalDiffTime
allowedSkew' JWTHeader
headers') = do
      (JWKSet, Maybe UTCTime)
keyConfig <- IORef (JWKSet, Maybe UTCTime) -> IO (JWKSet, Maybe UTCTime)
forall a. IORef a -> IO a
readIORef IORef (JWKSet, Maybe UTCTime)
keyConfigRef
      (JWKSet, Maybe UTCTime)
keyConfig' <- IORef (JWKSet, Maybe UTCTime) -> IO (JWKSet, Maybe UTCTime)
forall a. IORef a -> IO a
readIORef IORef (JWKSet, Maybe UTCTime)
keyConfigRef'
      Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (Maybe URI
url, (JWKSet, Maybe UTCTime)
keyConfig, Maybe Audience
audM, Maybe StringOrURI
iss, JWTClaims
claims, Maybe NominalDiffTime
allowedSkew, JWTHeader
headers) (Maybe URI, (JWKSet, Maybe UTCTime), Maybe Audience,
 Maybe StringOrURI, JWTClaims, Maybe NominalDiffTime, JWTHeader)
-> (Maybe URI, (JWKSet, Maybe UTCTime), Maybe Audience,
    Maybe StringOrURI, JWTClaims, Maybe NominalDiffTime, JWTHeader)
-> Bool
forall a. Eq a => a -> a -> Bool
== (Maybe URI
url', (JWKSet, Maybe UTCTime)
keyConfig', Maybe Audience
audM', Maybe StringOrURI
iss', JWTClaims
claims', Maybe NominalDiffTime
allowedSkew', JWTHeader
headers')

-- | Validate the user's requested authentication configuration, launching any
-- required maintenance threads for JWT etc.
--
-- This must only be run once, on launch.
setupAuthMode ::
  ( MonadError Text m,
    MonadIO m,
    MonadBaseControl IO m
  ) =>
  Set.HashSet AdminSecretHash ->
  Maybe AuthHook ->
  [JWTConfig] ->
  Maybe RoleName ->
  Logger Hasura ->
  HTTP.Manager ->
  m AuthMode
setupAuthMode :: forall (m :: * -> *).
(MonadError Text m, MonadIO m, MonadBaseControl IO m) =>
HashSet AdminSecretHash
-> Maybe AuthHook
-> [JWTConfig]
-> Maybe RoleName
-> Logger Hasura
-> Manager
-> m AuthMode
setupAuthMode HashSet AdminSecretHash
adminSecretHashSet Maybe AuthHook
mWebHook [JWTConfig]
mJwtSecrets Maybe RoleName
mUnAuthRole Logger Hasura
logger Manager
httpManager =
  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 a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [JWTConfig]
mJwtSecrets)) of
    (Bool
True, Maybe AuthHook
Nothing, Bool
False) -> AuthMode -> m AuthMode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthMode -> m AuthMode) -> AuthMode -> 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 -> m JWTCtx) -> [JWTConfig] -> m [JWTCtx]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\JWTConfig
jSecret -> JWTConfig -> Logger Hasura -> Manager -> m JWTCtx
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError Text m) =>
JWTConfig -> Logger Hasura -> Manager -> m JWTCtx
mkJwtCtx JWTConfig
jSecret Logger Hasura
logger Manager
httpManager) ([JWTConfig] -> [JWTConfig]
forall a. Eq a => [a] -> [a]
L.nub [JWTConfig]
mJwtSecrets)
      AuthMode -> m AuthMode
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AuthMode -> m AuthMode) -> AuthMode -> 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 -> m AuthMode
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
            (Text -> m AuthMode) -> Text -> 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 -> m AuthMode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return AuthMode
AMNoAuth
    (Bool
True, Just AuthHook
hook, Bool
False) -> AuthMode -> m AuthMode
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (AuthMode -> m AuthMode) -> AuthMode -> 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 -> m AuthMode
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (Text -> m AuthMode) -> Text -> 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 -> m AuthMode
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
        (Text -> m AuthMode) -> Text -> 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 -> m AuthMode
forall a. Text -> m a
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 :: (MonadIO m, MonadBaseControl IO m, MonadError Text m) => JWTConfig -> Logger Hasura -> HTTP.Manager -> m JWTCtx
mkJwtCtx :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError Text m) =>
JWTConfig -> Logger Hasura -> Manager -> m JWTCtx
mkJwtCtx JWTConfig {Maybe StringOrURI
Maybe Audience
Maybe NominalDiffTime
Maybe JWTHeader
Either JWK URI
JWTClaims
jcKeyOrUrl :: Either JWK URI
jcAudience :: Maybe Audience
jcIssuer :: Maybe StringOrURI
jcClaims :: JWTClaims
jcAllowedSkew :: Maybe NominalDiffTime
jcHeader :: Maybe JWTHeader
jcKeyOrUrl :: JWTConfig -> Either JWK URI
jcAudience :: JWTConfig -> Maybe Audience
jcIssuer :: JWTConfig -> Maybe StringOrURI
jcClaims :: JWTConfig -> JWTClaims
jcAllowedSkew :: JWTConfig -> Maybe NominalDiffTime
jcHeader :: JWTConfig -> Maybe JWTHeader
..} Logger Hasura
logger Manager
httpManager = do
  (Maybe URI
jwkUri, IORef (JWKSet, Maybe UTCTime)
jwkKeyConfig) <- case Either JWK URI
jcKeyOrUrl of
    Left JWK
jwk -> do
      IORef (JWKSet, Maybe UTCTime)
jwkRef <- IO (IORef (JWKSet, Maybe UTCTime))
-> m (IORef (JWKSet, Maybe UTCTime))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (JWKSet, Maybe UTCTime))
 -> m (IORef (JWKSet, Maybe UTCTime)))
-> IO (IORef (JWKSet, Maybe UTCTime))
-> m (IORef (JWKSet, Maybe UTCTime))
forall a b. (a -> b) -> a -> b
$ (JWKSet, Maybe UTCTime) -> IO (IORef (JWKSet, Maybe UTCTime))
forall a. a -> IO (IORef a)
newIORef ([JWK] -> JWKSet
JWKSet [JWK
jwk], Maybe UTCTime
forall a. Maybe a
Nothing)
      (Maybe URI, IORef (JWKSet, Maybe UTCTime))
-> m (Maybe URI, IORef (JWKSet, Maybe UTCTime))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe URI
forall a. Maybe a
Nothing, IORef (JWKSet, Maybe UTCTime)
jwkRef)
    -- in case JWT url is provided, an empty JWKSet is initialised,
    -- which will be populated by the 'updateJWKCtx' poller thread
    Right URI
uri -> do
      -- fetch JWK initially and throw error if it fails
      m (JWKSet, [Header]) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m (JWKSet, [Header]) -> m ()) -> m (JWKSet, [Header]) -> m ()
forall a b. (a -> b) -> a -> b
$ ExceptT JwkFetchError m (JWKSet, [Header]) -> m (JWKSet, [Header])
forall {m :: * -> *} {a}.
MonadError Text m =>
ExceptT JwkFetchError m (JWKSet, [a]) -> m (JWKSet, [a])
withJwkError (ExceptT JwkFetchError m (JWKSet, [Header])
 -> m (JWKSet, [Header]))
-> ExceptT JwkFetchError m (JWKSet, [Header])
-> m (JWKSet, [Header])
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> Manager -> URI -> ExceptT JwkFetchError m (JWKSet, [Header])
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError JwkFetchError m) =>
Logger Hasura -> Manager -> URI -> m (JWKSet, [Header])
fetchJwk Logger Hasura
logger Manager
httpManager URI
uri
      IORef (JWKSet, Maybe UTCTime)
jwkRef <- IO (IORef (JWKSet, Maybe UTCTime))
-> m (IORef (JWKSet, Maybe UTCTime))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (JWKSet, Maybe UTCTime))
 -> m (IORef (JWKSet, Maybe UTCTime)))
-> IO (IORef (JWKSet, Maybe UTCTime))
-> m (IORef (JWKSet, Maybe UTCTime))
forall a b. (a -> b) -> a -> b
$ (JWKSet, Maybe UTCTime) -> IO (IORef (JWKSet, Maybe UTCTime))
forall a. a -> IO (IORef a)
newIORef ([JWK] -> JWKSet
JWKSet [], Maybe UTCTime
forall a. Maybe a
Nothing)
      (Maybe URI, IORef (JWKSet, Maybe UTCTime))
-> m (Maybe URI, IORef (JWKSet, Maybe UTCTime))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (URI -> Maybe URI
forall a. a -> Maybe a
Just URI
uri, IORef (JWKSet, Maybe UTCTime)
jwkRef)
  let jwtHeader :: JWTHeader
jwtHeader = JWTHeader -> Maybe JWTHeader -> JWTHeader
forall a. a -> Maybe a -> a
fromMaybe JWTHeader
JHAuthorization Maybe JWTHeader
jcHeader
  JWTCtx -> m JWTCtx
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (JWTCtx -> m JWTCtx) -> JWTCtx -> m JWTCtx
forall a b. (a -> b) -> a -> b
$ Maybe URI
-> IORef (JWKSet, Maybe UTCTime)
-> Maybe Audience
-> Maybe StringOrURI
-> JWTClaims
-> Maybe NominalDiffTime
-> JWTHeader
-> JWTCtx
JWTCtx Maybe URI
jwkUri IORef (JWKSet, Maybe UTCTime)
jwkKeyConfig Maybe Audience
jcAudience Maybe StringOrURI
jcIssuer JWTClaims
jcClaims Maybe NominalDiffTime
jcAllowedSkew JWTHeader
jwtHeader
  where
    withJwkError :: ExceptT JwkFetchError m (JWKSet, [a]) -> m (JWKSet, [a])
withJwkError ExceptT JwkFetchError m (JWKSet, [a])
a = do
      Either JwkFetchError (JWKSet, [a])
res <- ExceptT JwkFetchError m (JWKSet, [a])
-> m (Either JwkFetchError (JWKSet, [a]))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT JwkFetchError m (JWKSet, [a])
a
      Either JwkFetchError (JWKSet, [a])
-> (JwkFetchError -> m (JWKSet, [a])) -> m (JWKSet, [a])
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either JwkFetchError (JWKSet, [a])
res \case
        -- when fetching JWK initially, except expiry parsing error, all errors are critical
        JFEHttpException HttpException
_ Text
msg -> Text -> m (JWKSet, [a])
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
msg
        JFEHttpError URI
_ Status
_ ByteString
_ Text
e -> Text -> m (JWKSet, [a])
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
e
        JFEJwkParseError Text
_ Text
e -> Text -> m (JWKSet, [a])
forall a. Text -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Text
e
        JFEExpiryParseError Maybe Text
_ Text
_ -> (JWKSet, [a]) -> m (JWKSet, [a])
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([JWK] -> JWKSet
JWKSet [], [])

-- | Update the JWK based on the expiry time specified in @Expires@ header or
-- @Cache-Control@ header
updateJwkCtx ::
  forall m.
  (MonadIO m, MonadBaseControl IO m) =>
  AuthMode ->
  HTTP.Manager ->
  Logger Hasura ->
  m ()
updateJwkCtx :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
AuthMode -> Manager -> Logger Hasura -> m ()
updateJwkCtx AuthMode
authMode Manager
httpManager Logger Hasura
logger = do
  case AuthMode
authMode of
    AMAdminSecretAndJWT HashSet AdminSecretHash
_ [JWTCtx]
jwtCtxs Maybe RoleName
_ -> [JWTCtx] -> (JWTCtx -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [JWTCtx]
jwtCtxs JWTCtx -> m ()
updateJwkFromUrl_
    AuthMode
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    updateJwkFromUrl_ :: JWTCtx -> m ()
updateJwkFromUrl_ JWTCtx
jwtCtx = JWTCtx -> Manager -> Logger Hasura -> m ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
JWTCtx -> Manager -> Logger Hasura -> m ()
updateJwkFromUrl JWTCtx
jwtCtx Manager
httpManager Logger Hasura
logger

updateJwkFromUrl :: forall m. (MonadIO m, MonadBaseControl IO m) => JWTCtx -> HTTP.Manager -> Logger Hasura -> m ()
updateJwkFromUrl :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
JWTCtx -> Manager -> Logger Hasura -> m ()
updateJwkFromUrl (JWTCtx Maybe URI
url IORef (JWKSet, Maybe UTCTime)
ref Maybe Audience
_ Maybe StringOrURI
_ JWTClaims
_ Maybe NominalDiffTime
_ JWTHeader
_) Manager
httpManager Logger Hasura
logger =
  Maybe URI -> (URI -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe URI
url \URI
uri -> do
    (JWKSet
jwkSet, Maybe UTCTime
jwkExpiry) <- IO (JWKSet, Maybe UTCTime) -> m (JWKSet, Maybe UTCTime)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (JWKSet, Maybe UTCTime) -> m (JWKSet, Maybe UTCTime))
-> IO (JWKSet, Maybe UTCTime) -> m (JWKSet, Maybe UTCTime)
forall a b. (a -> b) -> a -> b
$ IORef (JWKSet, Maybe UTCTime) -> IO (JWKSet, Maybe UTCTime)
forall a. IORef a -> IO a
readIORef IORef (JWKSet, Maybe UTCTime)
ref
    case JWKSet
jwkSet of
      -- get the JWKs initially if the JWKSet is empty
      JWKSet [] -> Logger Hasura
-> Manager -> URI -> IORef (JWKSet, Maybe UTCTime) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
Logger Hasura
-> Manager -> URI -> IORef (JWKSet, Maybe UTCTime) -> m ()
fetchAndUpdateJWKs Logger Hasura
logger Manager
httpManager URI
uri IORef (JWKSet, Maybe UTCTime)
ref
      -- if the JWKSet is not empty, get the new JWK based on the
      -- expiry time
      JWKSet
_ -> do
        UTCTime
currentTime <- IO UTCTime -> m UTCTime
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
        Maybe UTCTime -> (UTCTime -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe UTCTime
jwkExpiry \UTCTime
expiryTime ->
          Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (UTCTime
currentTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
expiryTime)
            (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Logger Hasura
-> Manager -> URI -> IORef (JWKSet, Maybe UTCTime) -> m ()
forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m) =>
Logger Hasura
-> Manager -> URI -> IORef (JWKSet, Maybe UTCTime) -> m ()
fetchAndUpdateJWKs Logger Hasura
logger Manager
httpManager URI
uri IORef (JWKSet, Maybe UTCTime)
ref

-- | Authenticate the request using the headers and the configured 'AuthMode'.
getUserInfoWithExpTime ::
  forall m.
  (MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
  Logger Hasura ->
  HTTP.Manager ->
  [HTTP.Header] ->
  AuthMode ->
  Maybe ReqsText ->
  m (UserInfo, Maybe UTCTime, [HTTP.Header])
getUserInfoWithExpTime :: forall (m :: * -> *).
(MonadIO m, MonadBaseControl IO m, MonadError QErr m) =>
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], Maybe JWTCtx))
-> 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], Maybe JWTCtx))
-> 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) =>
Logger Hasura
-> Manager
-> AuthHook
-> [Header]
-> Maybe ReqsText
-> m (UserInfo, Maybe UTCTime, [Header])
userInfoFromAuthHook [JWTCtx]
-> [Header]
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime, [Header], Maybe JWTCtx)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m) =>
[JWTCtx]
-> [Header]
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime, [Header], Maybe JWTCtx)
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], Maybe JWTCtx)
  ) ->
  logger ->
  mgr ->
  [HTTP.Header] ->
  AuthMode ->
  Maybe ReqsText ->
  m (UserInfo, Maybe UTCTime, [HTTP.Header])
getUserInfoWithExpTime_ :: 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], Maybe JWTCtx))
-> 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], Maybe JWTCtx)
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 :: * -> *} {a} {a} {a}.
Functor f =>
f a -> f (a, 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 :: * -> *} {a} {a} {a}.
Functor f =>
f a -> f (a, 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], Maybe JWTCtx)
processJwt_ [JWTCtx]
jwtSecrets [Header]
rawHeaders Maybe RoleName
unAuthRole
      m (UserInfo, Maybe UTCTime, [Header], Maybe JWTCtx)
-> ((UserInfo, Maybe UTCTime, [Header], Maybe JWTCtx)
    -> (UserInfo, Maybe UTCTime, [Header]))
-> m (UserInfo, Maybe UTCTime, [Header])
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (\(UserInfo
a, Maybe UTCTime
b, [Header]
c, Maybe JWTCtx
_) -> (UserInfo
a, Maybe UTCTime
b, [Header]
c))
  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 a. (a -> a -> a) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
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 :: * -> *} {a} {a} {a}.
Functor f =>
f a -> f (a, 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 a -> f (a, Maybe a, [a])
withNoExpTime f a
a = (,Maybe a
forall a. Maybe a
Nothing,[]) (a -> (a, Maybe a, [a])) -> f a -> f (a, Maybe a, [a])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a