mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 20:41:49 +03:00
4ce6002af2
* improve jsonpath parser to accept special characters and property tests for the same * make the JWTClaimsMapValueG parametrizable * add documentation in the JWT file * modify processAuthZHeader Co-authored-by: Karthikeyan Chinnakonda <karthikeyan@hasura.io> Co-authored-by: Marion Schleifer <marion@hasura.io>
637 lines
25 KiB
Haskell
637 lines
25 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module Hasura.Server.Auth.JWT
|
|
( processJwt
|
|
, RawJWT
|
|
, JWTConfig (..)
|
|
, JWTCtx (..)
|
|
, Jose.JWKSet (..)
|
|
, JWTClaimsFormat (..)
|
|
, JWTClaims(..)
|
|
, JwkFetchError (..)
|
|
, JWTNamespace (..)
|
|
, JWTCustomClaimsMapDefaultRole
|
|
, JWTCustomClaimsMapAllowedRoles
|
|
, JWTCustomClaimsMapValue
|
|
, ClaimsMap
|
|
, updateJwkRef
|
|
, jwkRefreshCtrl
|
|
, defaultClaimsFormat
|
|
, defaultClaimsNamespace
|
|
|
|
-- * Exposed for testing
|
|
, processJwt_
|
|
, allowedRolesClaim
|
|
, defaultRoleClaim
|
|
, parseClaimsMap
|
|
, JWTCustomClaimsMapValueG(..)
|
|
, JWTCustomClaimsMap(..)
|
|
) where
|
|
|
|
import Control.Exception.Lifted (try)
|
|
import Control.Lens
|
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
|
import Control.Monad.Trans.Maybe
|
|
import Data.IORef (IORef, readIORef, writeIORef)
|
|
import Data.Parser.JSONPath (parseJSONPath)
|
|
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime,
|
|
getCurrentTime)
|
|
#ifndef PROFILING
|
|
import GHC.AssertNF
|
|
#endif
|
|
import Network.URI (URI)
|
|
|
|
import Data.Aeson.Internal (JSONPath)
|
|
import Data.Parser.CacheControl
|
|
import Data.Parser.Expires
|
|
import Hasura.HTTP
|
|
import Hasura.Logging (Hasura, LogLevel (..), Logger (..))
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types
|
|
import Hasura.Server.Auth.JWT.Internal (parseHmacKey, parseRsaKey)
|
|
import Hasura.Server.Auth.JWT.Logging
|
|
import Hasura.Server.Utils (executeJSONPath, getRequestHeader, userRoleHeader, isSessionVariable)
|
|
import Hasura.Server.Version (HasVersion)
|
|
import Hasura.Session
|
|
import qualified Hasura.Tracing as Tracing
|
|
|
|
import qualified Control.Concurrent.Extended as C
|
|
import qualified Crypto.JWT as Jose
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.Aeson.Casing as J
|
|
import qualified Data.Aeson.TH as J
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.ByteString.Lazy.Char8 as BLC
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as T
|
|
import qualified Network.HTTP.Client as HTTP
|
|
import qualified Network.HTTP.Types as HTTP
|
|
import qualified Network.Wreq as Wreq
|
|
|
|
newtype RawJWT = RawJWT BL.ByteString
|
|
|
|
data JWTClaimsFormat
|
|
= JCFJson
|
|
| JCFStringifiedJson
|
|
deriving (Show, Eq)
|
|
|
|
$(J.deriveJSON J.defaultOptions { J.sumEncoding = J.ObjectWithSingleField
|
|
, J.constructorTagModifier = J.snakeCase . drop 3 } ''JWTClaimsFormat)
|
|
|
|
defaultClaimsFormat :: JWTClaimsFormat
|
|
defaultClaimsFormat = JCFJson
|
|
|
|
allowedRolesClaim :: SessionVariable
|
|
allowedRolesClaim = mkSessionVariable "x-hasura-allowed-roles"
|
|
|
|
defaultRoleClaim :: SessionVariable
|
|
defaultRoleClaim = mkSessionVariable "x-hasura-default-role"
|
|
|
|
defaultClaimsNamespace :: Text
|
|
defaultClaimsNamespace = "https://hasura.io/jwt/claims"
|
|
|
|
-- | 'JWTCustomClaimsMapValueG' is used to represent a single value of
|
|
-- the 'JWTCustomClaimsMap'. A 'JWTCustomClaimsMapValueG' can either be
|
|
-- an JSON object or the literal value of the claim. If the value is an
|
|
-- JSON object, then it should contain a key `path`, which is the JSON path
|
|
-- to the claim value in the JWT token. There's also an option to specify a
|
|
-- default value in the map via the 'default' key, which will be used
|
|
-- when a peek at the JWT token using the JSON path fails (key does not exist).
|
|
data JWTCustomClaimsMapValueG v
|
|
= JWTCustomClaimsMapJSONPath !J.JSONPath !(Maybe v)
|
|
-- ^ JSONPath to the key in the claims map, in case
|
|
-- the key doesn't exist in the claims map then the default
|
|
-- value will be used (if provided)
|
|
| JWTCustomClaimsMapStatic !v
|
|
deriving (Show, Eq, Functor, Foldable, Traversable)
|
|
|
|
instance (J.FromJSON v) => J.FromJSON (JWTCustomClaimsMapValueG v) where
|
|
parseJSON (J.Object obj) = do
|
|
path <- obj J..: "path" >>= (either fail pure . parseJSONPath)
|
|
defaultVal <- obj J..:? "default" >>= traverse pure
|
|
pure $ JWTCustomClaimsMapJSONPath path defaultVal
|
|
parseJSON v = JWTCustomClaimsMapStatic <$> J.parseJSON v
|
|
|
|
instance (J.ToJSON v) => J.ToJSON (JWTCustomClaimsMapValueG v) where
|
|
toJSON (JWTCustomClaimsMapJSONPath jsonPath mDefVal) =
|
|
J.object $
|
|
[ "path" J..= encodeJSONPath jsonPath ]
|
|
<> [ "default" J..= defVal | Just defVal <- [mDefVal]]
|
|
toJSON (JWTCustomClaimsMapStatic v) = J.toJSON v
|
|
|
|
type JWTCustomClaimsMapDefaultRole = JWTCustomClaimsMapValueG RoleName
|
|
type JWTCustomClaimsMapAllowedRoles = JWTCustomClaimsMapValueG [RoleName]
|
|
|
|
-- Used to store other session variables like `x-hasura-user-id`
|
|
type JWTCustomClaimsMapValue = JWTCustomClaimsMapValueG SessionVariableValue
|
|
|
|
type CustomClaimsMap = Map.HashMap SessionVariable JWTCustomClaimsMapValue
|
|
|
|
-- | JWTClaimsMap is an option to provide a custom JWT claims map.
|
|
-- The JWTClaimsMap should be specified in the `HASURA_GRAPHQL_JWT_SECRET`
|
|
-- in the `claims_map`. The JWTClaimsMap, if specified, requires two
|
|
-- mandatory fields, namely, `x-hasura-allowed-roles` and the
|
|
-- `x-hasura-default-role`, other claims may also be provided in the claims map.
|
|
data JWTCustomClaimsMap
|
|
= JWTCustomClaimsMap
|
|
{ jcmDefaultRole :: !JWTCustomClaimsMapDefaultRole
|
|
, jcmAllowedRoles :: !JWTCustomClaimsMapAllowedRoles
|
|
, jcmCustomClaims :: !CustomClaimsMap
|
|
} deriving (Show,Eq)
|
|
|
|
instance J.ToJSON JWTCustomClaimsMap where
|
|
toJSON (JWTCustomClaimsMap defaultRole allowedRoles customClaims) =
|
|
J.Object $
|
|
Map.fromList $ [ (sessionVariableToText defaultRoleClaim, J.toJSON defaultRole)
|
|
, (sessionVariableToText allowedRolesClaim, J.toJSON allowedRoles)
|
|
]
|
|
<> map (sessionVariableToText *** J.toJSON) (Map.toList customClaims)
|
|
|
|
instance J.FromJSON JWTCustomClaimsMap where
|
|
parseJSON = J.withObject "JWTClaimsMap" $ \obj -> do
|
|
let withNotFoundError sessionVariable =
|
|
let errorMsg = T.unpack $
|
|
sessionVariableToText sessionVariable <> " is expected but not found"
|
|
in maybe (fail errorMsg) pure $ Map.lookup (sessionVariableToText sessionVariable) obj
|
|
|
|
allowedRoles <- withNotFoundError allowedRolesClaim >>= J.parseJSON
|
|
defaultRole <- withNotFoundError defaultRoleClaim >>= J.parseJSON
|
|
let filteredClaims = Map.delete allowedRolesClaim $ Map.delete defaultRoleClaim
|
|
$ Map.fromList $ map (first mkSessionVariable) $ Map.toList obj
|
|
customClaims <- flip Map.traverseWithKey filteredClaims $ const $ J.parseJSON
|
|
pure $ JWTCustomClaimsMap defaultRole allowedRoles customClaims
|
|
|
|
-- | JWTNamespace is used to locate the claims map within the JWT token.
|
|
-- The location can be either provided via a JSON path or the name of the
|
|
-- key in the JWT token.
|
|
data JWTNamespace
|
|
= ClaimNsPath JSONPath
|
|
| ClaimNs T.Text
|
|
deriving (Show, Eq)
|
|
|
|
instance J.ToJSON JWTNamespace where
|
|
toJSON (ClaimNsPath nsPath) = J.String . T.pack $ encodeJSONPath nsPath
|
|
toJSON (ClaimNs ns) = J.String ns
|
|
|
|
data JWTClaims
|
|
= JCNamespace !JWTNamespace !JWTClaimsFormat
|
|
| JCMap !JWTCustomClaimsMap
|
|
deriving (Show, Eq)
|
|
|
|
-- | The JWT configuration we got from the user.
|
|
data JWTConfig
|
|
= JWTConfig
|
|
{ jcKeyOrUrl :: !(Either Jose.JWK URI)
|
|
, jcAudience :: !(Maybe Jose.Audience)
|
|
, jcIssuer :: !(Maybe Jose.StringOrURI)
|
|
, jcClaims :: !JWTClaims
|
|
} deriving (Show, Eq)
|
|
|
|
-- | The validated runtime JWT configuration returned by 'mkJwtCtx' in 'setupAuthMode'.
|
|
--
|
|
-- This is also evidence that the 'jwkRefreshCtrl' thread is running, if an
|
|
-- expiration schedule could be determined.
|
|
data JWTCtx
|
|
= JWTCtx
|
|
{ jcxKey :: !(IORef Jose.JWKSet)
|
|
-- ^ This needs to be a mutable variable for 'updateJwkRef'.
|
|
, jcxAudience :: !(Maybe Jose.Audience)
|
|
, jcxIssuer :: !(Maybe Jose.StringOrURI)
|
|
, jcxClaims :: !JWTClaims
|
|
} deriving (Eq)
|
|
|
|
instance Show JWTCtx where
|
|
show (JWTCtx _ audM iss claims) =
|
|
show ["<IORef JWKSet>", show audM, show iss, show claims]
|
|
|
|
data HasuraClaims
|
|
= HasuraClaims
|
|
{ _cmAllowedRoles :: ![RoleName]
|
|
, _cmDefaultRole :: !RoleName
|
|
} deriving (Show, Eq)
|
|
$(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''HasuraClaims)
|
|
|
|
-- | An action that refreshes the JWK at intervals in an infinite loop.
|
|
jwkRefreshCtrl
|
|
:: (HasVersion, MonadIO m, MonadBaseControl IO m, Tracing.HasReporter m)
|
|
=> Logger Hasura
|
|
-> HTTP.Manager
|
|
-> URI
|
|
-> IORef Jose.JWKSet
|
|
-> DiffTime
|
|
-> m void
|
|
jwkRefreshCtrl logger manager url ref time = do
|
|
liftIO $ C.sleep time
|
|
forever $ Tracing.runTraceT "jwk refresh" do
|
|
res <- runExceptT $ updateJwkRef logger manager url ref
|
|
mTime <- either (const $ logNotice >> return Nothing) return res
|
|
-- if can't parse time from header, defaults to 1 min
|
|
-- let delay = maybe (minutes 1) fromUnits mTime
|
|
let delay = maybe (minutes 1) convertDuration mTime
|
|
liftIO $ C.sleep delay
|
|
where
|
|
logNotice = do
|
|
let err = JwkRefreshLog LevelInfo (Just "retrying again in 60 secs") Nothing
|
|
liftIO $ unLogger logger err
|
|
|
|
-- | Given a JWK url, fetch JWK from it and update the IORef
|
|
updateJwkRef
|
|
:: ( HasVersion
|
|
, MonadIO m
|
|
, MonadBaseControl IO m
|
|
, MonadError JwkFetchError m
|
|
, Tracing.MonadTrace m
|
|
)
|
|
=> Logger Hasura
|
|
-> HTTP.Manager
|
|
-> URI
|
|
-> IORef Jose.JWKSet
|
|
-> m (Maybe NominalDiffTime)
|
|
updateJwkRef (Logger logger) manager url jwkRef = do
|
|
let urlT = T.pack $ show url
|
|
infoMsg = "refreshing JWK from endpoint: " <> urlT
|
|
liftIO $ logger $ JwkRefreshLog LevelInfo (Just infoMsg) Nothing
|
|
res <- try $ do
|
|
initReq <- liftIO $ HTTP.parseRequest $ show url
|
|
let req = initReq { HTTP.requestHeaders = addDefaultHeaders (HTTP.requestHeaders initReq) }
|
|
Tracing.tracedHttpRequest req \req' -> do
|
|
liftIO $ HTTP.httpLbs req' manager
|
|
resp <- either logAndThrowHttp return res
|
|
let status = resp ^. Wreq.responseStatus
|
|
respBody = resp ^. Wreq.responseBody
|
|
statusCode = status ^. Wreq.statusCode
|
|
|
|
unless (statusCode >= 200 && statusCode < 300) $ do
|
|
let errMsg = "Non-2xx response on fetching JWK from: " <> urlT
|
|
err = JFEHttpError url status respBody errMsg
|
|
logAndThrow err
|
|
|
|
let parseErr e = JFEJwkParseError (T.pack e) $ "Error parsing JWK from url: " <> urlT
|
|
!jwkset <- either (logAndThrow . parseErr) return $ J.eitherDecode' respBody
|
|
liftIO $ do
|
|
#ifndef PROFILING
|
|
$assertNFHere jwkset -- so we don't write thunks to mutable vars
|
|
#endif
|
|
writeIORef jwkRef jwkset
|
|
|
|
-- first check for Cache-Control header to get max-age, if not found, look for Expires header
|
|
runMaybeT $ timeFromCacheControl resp <|> timeFromExpires resp
|
|
|
|
where
|
|
parseCacheControlErr e =
|
|
JFEExpiryParseError (Just e)
|
|
"Failed parsing Cache-Control header from JWK response. Could not find max-age or s-maxage"
|
|
parseTimeErr =
|
|
JFEExpiryParseError Nothing
|
|
"Failed parsing Expires header from JWK response. Value of header is not a valid timestamp"
|
|
|
|
timeFromCacheControl resp = do
|
|
header <- afold $ bsToTxt <$> resp ^? Wreq.responseHeader "Cache-Control"
|
|
fromInteger <$> parseMaxAge header `onLeft` \err -> logAndThrowInfo $ parseCacheControlErr $ T.pack err
|
|
timeFromExpires resp = do
|
|
header <- afold $ bsToTxt <$> resp ^? Wreq.responseHeader "Expires"
|
|
expiry <- parseExpirationTime header `onLeft` const (logAndThrowInfo parseTimeErr)
|
|
diffUTCTime expiry <$> liftIO getCurrentTime
|
|
|
|
logAndThrowInfo :: (MonadIO m, MonadError JwkFetchError m) => JwkFetchError -> m a
|
|
logAndThrowInfo err = do
|
|
liftIO $ logger $ JwkRefreshLog LevelInfo Nothing (Just err)
|
|
throwError err
|
|
|
|
logAndThrow :: (MonadIO m, MonadError JwkFetchError m) => JwkFetchError -> m a
|
|
logAndThrow err = do
|
|
liftIO $ logger $ JwkRefreshLog (LevelOther "critical") Nothing (Just err)
|
|
throwError err
|
|
|
|
logAndThrowHttp :: (MonadIO m, MonadError JwkFetchError m) => HTTP.HttpException -> m a
|
|
logAndThrowHttp httpEx = do
|
|
let errMsg = "Error fetching JWK: " <> T.pack (getHttpExceptionMsg httpEx)
|
|
err = JFEHttpException (HttpException httpEx) errMsg
|
|
logAndThrow err
|
|
|
|
getHttpExceptionMsg = \case
|
|
HTTP.HttpExceptionRequest _ reason -> show reason
|
|
HTTP.InvalidUrlException _ reason -> show reason
|
|
|
|
type ClaimsMap = Map.HashMap SessionVariable J.Value
|
|
|
|
-- | Process the request headers to verify the JWT and extract UserInfo from it
|
|
--
|
|
-- Iff no "Authorization" header was passed, we will fall back to the
|
|
-- unauthenticated user role [1], if one was configured at server start.
|
|
--
|
|
-- When no 'x-hasura-user-role' is specified in the request, the mandatory
|
|
-- 'x-hasura-default-role' [2] from the JWT claims will be used.
|
|
|
|
-- [1]: https://hasura.io/docs/1.0/graphql/manual/auth/authentication/unauthenticated-access.html
|
|
-- [2]: https://hasura.io/docs/1.0/graphql/manual/auth/authentication/jwt.html#the-spec
|
|
processJwt
|
|
:: ( MonadIO m
|
|
, MonadError QErr m)
|
|
=> JWTCtx
|
|
-> HTTP.RequestHeaders
|
|
-> Maybe RoleName
|
|
-> m (UserInfo, Maybe UTCTime)
|
|
processJwt = processJwt_ processAuthZHeader
|
|
|
|
-- Broken out for testing with mocks:
|
|
processJwt_
|
|
:: (MonadError QErr m)
|
|
=> (_JWTCtx -> BLC.ByteString -> m (ClaimsMap, Maybe UTCTime))
|
|
-- ^ mock 'processAuthZHeader'
|
|
-> _JWTCtx
|
|
-> HTTP.RequestHeaders
|
|
-> Maybe RoleName
|
|
-> m (UserInfo, Maybe UTCTime)
|
|
processJwt_ processAuthZHeader_ jwtCtx headers mUnAuthRole =
|
|
maybe withoutAuthZHeader withAuthZHeader mAuthZHeader
|
|
where
|
|
mAuthZHeader = find (\h -> fst h == CI.mk "Authorization") headers
|
|
|
|
withAuthZHeader (_, authzHeader) = do
|
|
(claimsMap, expTimeM) <- processAuthZHeader_ jwtCtx $ BL.fromStrict authzHeader
|
|
|
|
HasuraClaims allowedRoles defaultRole <- parseHasuraClaims claimsMap
|
|
-- see if there is a x-hasura-role header, or else pick the default role.
|
|
-- The role returned is unauthenticated at this point:
|
|
let requestedRole = fromMaybe defaultRole $
|
|
getRequestHeader userRoleHeader headers >>= mkRoleName . bsToTxt
|
|
|
|
when (requestedRole `notElem` allowedRoles) $
|
|
throw400 AccessDenied "Your requested role is not in allowed roles"
|
|
let finalClaims =
|
|
Map.delete defaultRoleClaim . Map.delete allowedRolesClaim $ claimsMap
|
|
|
|
-- transform the map of text:aeson-value -> text:text
|
|
let finalClaimsObject = Map.fromList . map (first sessionVariableToText) . Map.toList $ finalClaims
|
|
metadata <- parseJwtClaim (J.Object $ finalClaimsObject) "x-hasura-* claims"
|
|
userInfo <- mkUserInfo (URBPreDetermined requestedRole) UAdminSecretNotSent $
|
|
mkSessionVariablesText $ Map.toList metadata
|
|
pure (userInfo, expTimeM)
|
|
|
|
withoutAuthZHeader = do
|
|
unAuthRole <- maybe missingAuthzHeader return mUnAuthRole
|
|
userInfo <- mkUserInfo (URBPreDetermined unAuthRole) UAdminSecretNotSent $
|
|
mkSessionVariablesHeaders headers
|
|
pure (userInfo, Nothing)
|
|
|
|
where
|
|
missingAuthzHeader =
|
|
throw400 InvalidHeaders "Missing Authorization header in JWT authentication mode"
|
|
|
|
-- Parse and verify the 'Authorization' header, returning the raw claims
|
|
-- object, and the expiration, if any.
|
|
processAuthZHeader
|
|
:: ( MonadIO m
|
|
, MonadError QErr m)
|
|
=> JWTCtx
|
|
-> BLC.ByteString
|
|
-> m (ClaimsMap, Maybe UTCTime)
|
|
processAuthZHeader jwtCtx authzHeader = do
|
|
-- try to parse JWT token from Authorization header
|
|
jwt <- parseAuthzHeader
|
|
|
|
-- verify the JWT
|
|
claims <- liftJWTError invalidJWTError $ verifyJwt jwtCtx $ RawJWT jwt
|
|
|
|
let expTimeM = fmap (\(Jose.NumericDate t) -> t) $ claims ^. Jose.claimExp
|
|
unregisteredClaims = claims ^. Jose.unregisteredClaims
|
|
|
|
claimsObject <- parseClaimsMap unregisteredClaims claimsConfig
|
|
|
|
pure $ (claimsObject, expTimeM)
|
|
|
|
where
|
|
claimsConfig = jcxClaims jwtCtx
|
|
parseAuthzHeader = do
|
|
let tokenParts = BLC.words authzHeader
|
|
case tokenParts of
|
|
["Bearer", jwt] -> return jwt
|
|
_ -> malformedAuthzHeader
|
|
|
|
liftJWTError :: (MonadError e' m) => (e -> e') -> ExceptT e m a -> m a
|
|
liftJWTError ef action = do
|
|
res <- runExceptT action
|
|
either (throwError . ef) return res
|
|
|
|
invalidJWTError e =
|
|
err400 JWTInvalid $ "Could not verify JWT: " <> T.pack (show e)
|
|
|
|
malformedAuthzHeader =
|
|
throw400 InvalidHeaders "Malformed Authorization header"
|
|
|
|
-- | parse the claims map from the JWT token or custom claims from the JWT config
|
|
parseClaimsMap
|
|
:: (MonadError QErr m)
|
|
=> J.Object -- ^ Unregistered JWT claims
|
|
-> JWTClaims -- ^ Claims config
|
|
-> m ClaimsMap -- ^ Hasura claims and other claims
|
|
parseClaimsMap unregisteredClaims jcxClaims =
|
|
case jcxClaims of
|
|
JCNamespace namespace claimsFormat -> do
|
|
claimsV <- maybe (claimsNotFound namespace) pure $ case namespace of
|
|
ClaimNs k -> Map.lookup k unregisteredClaims
|
|
ClaimNsPath path -> iResultToMaybe $ executeJSONPath path (J.toJSON unregisteredClaims)
|
|
-- get hasura claims value as an object. parse from string possibly
|
|
claimsObject <- parseObjectFromString namespace claimsFormat claimsV
|
|
|
|
-- filter only x-hasura claims
|
|
let claimsMap = Map.fromList
|
|
$ map (first mkSessionVariable)
|
|
$ filter (\(k, _) -> isSessionVariable k)
|
|
$ Map.toList claimsObject
|
|
|
|
pure claimsMap
|
|
|
|
JCMap claimsConfig -> do
|
|
let JWTCustomClaimsMap defaultRoleClaimsMap allowedRolesClaimsMap otherClaimsMap = claimsConfig
|
|
claimsObjValue = J.Object unregisteredClaims
|
|
|
|
allowedRoles <- case allowedRolesClaimsMap of
|
|
JWTCustomClaimsMapJSONPath allowedRolesJsonPath defaultVal ->
|
|
parseAllowedRolesClaim defaultVal $ iResultToMaybe $ executeJSONPath allowedRolesJsonPath claimsObjValue
|
|
JWTCustomClaimsMapStatic staticAllowedRoles -> pure staticAllowedRoles
|
|
|
|
defaultRole <- case defaultRoleClaimsMap of
|
|
JWTCustomClaimsMapJSONPath defaultRoleJsonPath defaultVal ->
|
|
parseDefaultRoleClaim defaultVal $ iResultToMaybe $
|
|
executeJSONPath defaultRoleJsonPath claimsObjValue
|
|
JWTCustomClaimsMapStatic staticDefaultRole -> pure staticDefaultRole
|
|
|
|
otherClaims <- flip Map.traverseWithKey otherClaimsMap $ \k claimObj -> do
|
|
let throwClaimErr = throw400 JWTInvalidClaims $ "JWT claim from claims_map, "
|
|
<> sessionVariableToText k <> " not found"
|
|
case claimObj of
|
|
JWTCustomClaimsMapJSONPath path defaultVal ->
|
|
maybe (onNothing (J.String <$> defaultVal) throwClaimErr) pure
|
|
$ iResultToMaybe $ executeJSONPath path claimsObjValue
|
|
JWTCustomClaimsMapStatic claimStaticValue -> pure $ J.String claimStaticValue
|
|
|
|
pure $ Map.fromList [
|
|
(allowedRolesClaim, J.toJSON allowedRoles),
|
|
(defaultRoleClaim, J.toJSON defaultRole)
|
|
] <> otherClaims
|
|
|
|
where
|
|
parseAllowedRolesClaim defaultVal = \case
|
|
Nothing ->
|
|
onNothing defaultVal $
|
|
throw400 JWTRoleClaimMissing $ "JWT claim does not contain " <> sessionVariableToText allowedRolesClaim
|
|
Just v -> parseJwtClaim v $ "invalid " <> sessionVariableToText allowedRolesClaim <>
|
|
"; should be a list of roles"
|
|
|
|
parseDefaultRoleClaim defaultVal = \case
|
|
Nothing ->
|
|
onNothing defaultVal $
|
|
throw400 JWTRoleClaimMissing $ "JWT claim does not contain " <> sessionVariableToText defaultRoleClaim
|
|
Just v -> parseJwtClaim v $ "invalid " <> sessionVariableToText defaultRoleClaim <>
|
|
"; should be a role"
|
|
|
|
claimsNotFound namespace =
|
|
throw400 JWTInvalidClaims $ case namespace of
|
|
ClaimNsPath path -> T.pack $ "claims not found at claims_namespace_path: '"
|
|
<> encodeJSONPath path <> "'"
|
|
ClaimNs ns -> "claims key: '" <> ns <> "' not found"
|
|
|
|
parseObjectFromString namespace claimsFmt jVal =
|
|
case (claimsFmt, jVal) of
|
|
(JCFStringifiedJson, J.String v) ->
|
|
either (const $ claimsErr $ strngfyErr v) return
|
|
$ J.eitherDecodeStrict $ T.encodeUtf8 v
|
|
(JCFStringifiedJson, _) ->
|
|
claimsErr "expecting a string when claims_format is stringified_json"
|
|
(JCFJson, J.Object o) -> return o
|
|
(JCFJson, _) ->
|
|
claimsErr "expecting a json object when claims_format is json"
|
|
where
|
|
strngfyErr v =
|
|
let claimsLocation = case namespace of
|
|
ClaimNsPath path -> T.pack $ "claims_namespace_path " <> encodeJSONPath path
|
|
ClaimNs ns -> "claims_namespace " <> ns
|
|
in "expecting stringified json at: '"
|
|
<> claimsLocation
|
|
<> "', but found: " <> v
|
|
|
|
claimsErr = throw400 JWTInvalidClaims
|
|
|
|
-- | Verify the JWT against given JWK
|
|
verifyJwt
|
|
:: ( MonadError Jose.JWTError m
|
|
, MonadIO m
|
|
)
|
|
=> JWTCtx
|
|
-> RawJWT
|
|
-> m Jose.ClaimsSet
|
|
verifyJwt ctx (RawJWT rawJWT) = do
|
|
key <- liftIO $ readIORef $ jcxKey ctx
|
|
jwt <- Jose.decodeCompact rawJWT
|
|
t <- liftIO getCurrentTime
|
|
Jose.verifyClaimsAt config key t jwt
|
|
where
|
|
config = case jcxIssuer ctx of
|
|
Nothing -> Jose.defaultJWTValidationSettings audCheck
|
|
Just iss -> Jose.defaultJWTValidationSettings audCheck
|
|
& set Jose.issuerPredicate (== iss)
|
|
audCheck audience =
|
|
-- dont perform the check if there are no audiences in the conf
|
|
case jcxAudience ctx of
|
|
Nothing -> True
|
|
Just (Jose.Audience audiences) -> audience `elem` audiences
|
|
|
|
|
|
instance J.ToJSON JWTConfig where
|
|
toJSON (JWTConfig keyOrUrl aud iss claims) =
|
|
let keyOrUrlPairs = case keyOrUrl of
|
|
Left _ -> [ "type" J..= J.String "<TYPE REDACTED>"
|
|
, "key" J..= J.String "<JWK REDACTED>"
|
|
]
|
|
Right url -> ["jwk_url" J..= url]
|
|
claimsPairs = case claims of
|
|
JCNamespace namespace claimsFormat ->
|
|
let namespacePairs = case namespace of
|
|
ClaimNsPath nsPath ->
|
|
["claims_namespace_path" J..= encodeJSONPath nsPath]
|
|
ClaimNs ns -> ["claims_namespace" J..= J.String ns]
|
|
in namespacePairs <> ["claims_format" J..= claimsFormat]
|
|
JCMap claimsMap -> ["claims_map" J..= claimsMap]
|
|
in J.object $ keyOrUrlPairs <>
|
|
[ "audience" J..= aud
|
|
, "issuer" J..= iss
|
|
] <> claimsPairs
|
|
|
|
-- | Parse from a json string like:
|
|
-- | `{"type": "RS256", "key": "<PEM-encoded-public-key-or-X509-cert>"}`
|
|
-- | to JWTConfig
|
|
instance J.FromJSON JWTConfig where
|
|
|
|
parseJSON = J.withObject "JWTConfig" $ \o -> do
|
|
mRawKey <- o J..:? "key"
|
|
claimsNs <- o J..:? "claims_namespace"
|
|
claimsNsPath <- o J..:? "claims_namespace_path"
|
|
aud <- o J..:? "audience"
|
|
iss <- o J..:? "issuer"
|
|
jwkUrl <- o J..:? "jwk_url"
|
|
claimsFormat <- o J..:? "claims_format" J..!= defaultClaimsFormat
|
|
claimsMap <- o J..:? "claims_map"
|
|
|
|
hasuraClaimsNs <-
|
|
case (claimsNsPath,claimsNs) of
|
|
(Nothing, Nothing) -> pure $ ClaimNs defaultClaimsNamespace
|
|
(Just nsPath, Nothing) -> either failJSONPathParsing (return . ClaimNsPath) . parseJSONPath $ nsPath
|
|
(Nothing, Just ns) -> return $ ClaimNs ns
|
|
(Just _, Just _) -> fail "claims_namespace and claims_namespace_path both cannot be set"
|
|
|
|
keyOrUrl <- case (mRawKey, jwkUrl) of
|
|
(Nothing, Nothing) -> fail "key and jwk_url both cannot be empty"
|
|
(Just _, Just _) -> fail "key, jwk_url both cannot be present"
|
|
(Just rawKey, Nothing) -> do
|
|
keyType <- o J..: "type"
|
|
key <- parseKey keyType rawKey
|
|
pure $ Left key
|
|
(Nothing, Just url) -> pure $ Right url
|
|
|
|
pure $ JWTConfig keyOrUrl aud iss $
|
|
maybe (JCNamespace hasuraClaimsNs claimsFormat) JCMap claimsMap
|
|
|
|
where
|
|
parseKey keyType rawKey =
|
|
case keyType of
|
|
"HS256" -> runEither $ parseHmacKey rawKey 256
|
|
"HS384" -> runEither $ parseHmacKey rawKey 384
|
|
"HS512" -> runEither $ parseHmacKey rawKey 512
|
|
"RS256" -> runEither $ parseRsaKey rawKey
|
|
"RS384" -> runEither $ parseRsaKey rawKey
|
|
"RS512" -> runEither $ parseRsaKey rawKey
|
|
-- TODO(from master): support ES256, ES384, ES512, PS256, PS384
|
|
_ -> invalidJwk ("Key type: " <> T.unpack keyType <> " is not supported")
|
|
|
|
runEither = either (invalidJwk . T.unpack) return
|
|
|
|
invalidJwk msg = fail ("Invalid JWK: " <> msg)
|
|
|
|
failJSONPathParsing err = fail $ "invalid JSON path claims_namespace_path error: " ++ err
|
|
|
|
-- parse x-hasura-allowed-roles, x-hasura-default-role from JWT claims
|
|
parseHasuraClaims :: forall m. (MonadError QErr m) => ClaimsMap -> m HasuraClaims
|
|
parseHasuraClaims claimsMap = do
|
|
HasuraClaims <$>
|
|
parseClaim allowedRolesClaim "should be a list of roles" <*>
|
|
parseClaim defaultRoleClaim "should be a single role name"
|
|
|
|
where
|
|
parseClaim :: J.FromJSON a => SessionVariable -> Text -> m a
|
|
parseClaim claim hint = do
|
|
claimV <- maybe missingClaim return $ Map.lookup claim claimsMap
|
|
parseJwtClaim claimV $ "invalid " <> claimText <> "; " <> hint
|
|
where
|
|
missingClaim = throw400 JWTRoleClaimMissing $ "JWT claim does not contain " <> claimText
|
|
claimText = sessionVariableToText claim
|
|
|
|
-- Utility:
|
|
parseJwtClaim :: (J.FromJSON a, MonadError QErr m) => J.Value -> Text -> m a
|
|
parseJwtClaim v errMsg =
|
|
case J.fromJSON v of
|
|
J.Success val -> return val
|
|
J.Error e -> throw400 JWTInvalidClaims $ errMsg <> ": " <> T.pack e
|