1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-17 20:41:49 +03:00
graphql-engine/server/src-lib/Hasura/Server/Auth/JWT.hs
Rakesh Emmadi d52bfcda4e
backend only insert permissions (rfc ) ()
* move user info related code to Hasura.User module

* the RFC  implementation; insert permissions with admin secret

* revert back to old RoleName based schema maps

An attempt made to avoid duplication of schema contexts in types
if any role doesn't possess any admin secret specific schema

* fix compile errors in haskell test

* keep 'user_vars' for session variables in http-logs

* no-op refacto

* tests for admin only inserts

* update docs for admin only inserts

* updated CHANGELOG.md

* default behaviour when admin secret is not set

* fix x-hasura-role to X-Hasura-Role in pytests

* introduce effective timeout in actions async tests

* update docs for admin-secret not configured case

* Update docs/graphql/manual/api-reference/schema-metadata-api/permission.rst

Co-Authored-By: Marion Schleifer <marion@hasura.io>

* Apply suggestions from code review

Co-Authored-By: Marion Schleifer <marion@hasura.io>

* a complete iteration

backend insert permissions accessable via 'x-hasura-backend-privilege'
session variable

* console changes for backend-only permissions

* provide tooltip id; update labels and tooltips;

* requested changes

* requested changes

- remove className from Toggle component
- use appropriate function name (capitalizeFirstChar -> capitalize)

* use toggle props from definitelyTyped

* fix accidental commit

* Revert "introduce effective timeout in actions async tests"

This reverts commit b7a59c19d6.

* generate complete schema for both 'default' and 'backend' sessions

* Apply suggestions from code review

Co-Authored-By: Marion Schleifer <marion@hasura.io>

* remove unnecessary import, export Toggle as is

* update session variable in tooltip

* 'x-hasura-use-backend-only-permissions' variable to switch

* update help texts

* update docs

* update docs

* update console help text

* regenerate package-lock

* serve no backend schema when backend_only: false and header set to true

- Few type name refactor as suggested by @0x777

* update CHANGELOG.md

* Update CHANGELOG.md

* Update CHANGELOG.md

* fix a merge bug where a certain entity didn't get removed

Co-authored-by: Marion Schleifer <marion@hasura.io>
Co-authored-by: Rishichandra Wawhal <rishi@hasura.io>
Co-authored-by: rikinsk <rikin.kachhia@gmail.com>
Co-authored-by: Tirumarai Selvan <tiru@hasura.io>
2020-04-24 14:40:53 +05:30

469 lines
17 KiB
Haskell

module Hasura.Server.Auth.JWT
( processJwt
, RawJWT
, JWTConfig (..)
, JWTCtx (..)
, Jose.JWKSet (..)
, JWTClaimsFormat (..)
, JwkFetchError (..)
, JWTConfigClaims (..)
, updateJwkRef
, jwkRefreshCtrl
, defaultClaimNs
) where
import Control.Exception (try)
import Control.Lens
import Control.Monad (when)
import Control.Monad.Trans.Maybe
import Data.IORef (IORef, readIORef, writeIORef)
import Data.List (find)
import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime,
getCurrentTime)
import GHC.AssertNF
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.RQL.Types.Error (encodeJSONPath)
import Hasura.Server.Auth.JWT.Internal (parseHmacKey, parseRsaKey)
import Hasura.Server.Auth.JWT.Logging
import Hasura.Server.Utils (executeJSONPath, getRequestHeader,
isSessionVariable, userRoleHeader)
import Hasura.Server.Version (HasVersion)
import Hasura.Session
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.Internal 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.Parser.JSONPath as JSONPath
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)
data JWTConfigClaims
= ClaimNsPath JSONPath
| ClaimNs T.Text
deriving (Show, Eq)
instance J.ToJSON JWTConfigClaims where
toJSON (ClaimNsPath nsPath) = J.String . T.pack $ encodeJSONPath nsPath
toJSON (ClaimNs ns) = J.String ns
data JWTConfig
= JWTConfig
{ jcKeyOrUrl :: !(Either Jose.JWK URI)
, jcClaimNs :: !JWTConfigClaims
, jcAudience :: !(Maybe Jose.Audience)
, jcClaimsFormat :: !(Maybe JWTClaimsFormat)
, jcIssuer :: !(Maybe Jose.StringOrURI)
} deriving (Show, Eq)
data JWTCtx
= JWTCtx
{ jcxKey :: !(IORef Jose.JWKSet)
, jcxClaimNs :: !JWTConfigClaims
, jcxAudience :: !(Maybe Jose.Audience)
, jcxClaimsFormat :: !JWTClaimsFormat
, jcxIssuer :: !(Maybe Jose.StringOrURI)
} deriving (Eq)
instance Show JWTCtx where
show (JWTCtx _ nsM audM cf iss) =
show ["<IORef JWKSet>", show nsM,show audM, show cf, show iss]
data HasuraClaims
= HasuraClaims
{ _cmAllowedRoles :: ![RoleName]
, _cmDefaultRole :: !RoleName
} deriving (Show, Eq)
$(J.deriveJSON (J.aesonDrop 3 J.snakeCase) ''HasuraClaims)
allowedRolesClaim :: T.Text
allowedRolesClaim = "x-hasura-allowed-roles"
defaultRoleClaim :: T.Text
defaultRoleClaim = "x-hasura-default-role"
defaultClaimNs :: T.Text
defaultClaimNs = "https://hasura.io/jwt/claims"
-- | An action that refreshes the JWK at intervals in an infinite loop.
jwkRefreshCtrl
:: HasVersion
=> Logger Hasura
-> HTTP.Manager
-> URI
-> IORef Jose.JWKSet
-> DiffTime
-> IO void
jwkRefreshCtrl logger manager url ref time = liftIO $ do
C.sleep time
forever $ 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
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
, MonadError JwkFetchError m
)
=> Logger Hasura
-> HTTP.Manager
-> URI
-> IORef Jose.JWKSet
-> m (Maybe NominalDiffTime)
updateJwkRef (Logger logger) manager url jwkRef = do
let options = wreqOptions manager []
urlT = T.pack $ show url
infoMsg = "refreshing JWK from endpoint: " <> urlT
liftIO $ logger $ JwkRefreshLog LevelInfo (Just infoMsg) Nothing
res <- liftIO $ try $ Wreq.getWith options $ show url
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
$assertNFHere jwkset -- so we don't write thunks to mutable vars
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
-- | Process the request headers to verify the JWT and extract UserInfo from it
processJwt
:: ( MonadIO m
, MonadError QErr m)
=> JWTCtx
-> HTTP.RequestHeaders
-> Maybe RoleName
-> m (UserInfo, Maybe UTCTime)
processJwt jwtCtx headers mUnAuthRole =
maybe withoutAuthZHeader withAuthZHeader mAuthZHeader
where
mAuthZHeader = find (\h -> fst h == CI.mk "Authorization") headers
withAuthZHeader (_, authzHeader) =
processAuthZHeader jwtCtx headers $ BL.fromStrict authzHeader
withoutAuthZHeader = do
unAuthRole <- maybe missingAuthzHeader return mUnAuthRole
userInfo <- mkUserInfo UAdminSecretNotSent (mkSessionVariables headers) $ Just unAuthRole
pure (userInfo, Nothing)
missingAuthzHeader =
throw400 InvalidHeaders "Missing Authorization header in JWT authentication mode"
processAuthZHeader
:: ( MonadIO m
, MonadError QErr m)
=> JWTCtx
-> HTTP.RequestHeaders
-> BLC.ByteString
-> m (UserInfo, Maybe UTCTime)
processAuthZHeader jwtCtx headers authzHeader = do
-- try to parse JWT token from Authorization header
jwt <- parseAuthzHeader
-- verify the JWT
claims <- liftJWTError invalidJWTError $ verifyJwt jwtCtx $ RawJWT jwt
let claimsFmt = jcxClaimsFormat jwtCtx
expTimeM = fmap (\(Jose.NumericDate t) -> t) $ claims ^. Jose.claimExp
-- see if the hasura claims key exists in the claims map
let mHasuraClaims =
case jcxClaimNs jwtCtx of
ClaimNs k -> Map.lookup k $ claims ^. Jose.unregisteredClaims
ClaimNsPath path -> parseIValueJsonValue $ executeJSONPath path (J.toJSON $ claims ^. Jose.unregisteredClaims)
hasuraClaimsV <- maybe claimsNotFound return mHasuraClaims
-- get hasura claims value as an object. parse from string possibly
hasuraClaims <- parseObjectFromString claimsFmt hasuraClaimsV
-- filter only x-hasura claims and convert to lower-case
let claimsMap = Map.filterWithKey (\k _ -> isSessionVariable k)
$ Map.fromList $ map (first T.toLower)
$ Map.toList hasuraClaims
HasuraClaims allowedRoles defaultRole <- parseHasuraClaims claimsMap
let roleName = getCurrentRole defaultRole
when (roleName `notElem` allowedRoles) currRoleNotAllowed
let finalClaims =
Map.delete defaultRoleClaim . Map.delete allowedRolesClaim $ claimsMap
-- transform the map of text:aeson-value -> text:text
metadata <- decodeJSON $ J.Object finalClaims
userInfo <- mkUserInfo UAdminSecretNotSent
(mkSessionVariablesText $ Map.toList metadata) $ Just roleName
pure (userInfo, expTimeM)
where
parseAuthzHeader = do
let tokenParts = BLC.words authzHeader
case tokenParts of
["Bearer", jwt] -> return jwt
_ -> malformedAuthzHeader
parseObjectFromString 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"
strngfyErr v =
"expecting stringified json at: '"
<> claimsLocation
<> "', but found: " <> v
where
claimsLocation :: Text
claimsLocation =
case jcxClaimNs jwtCtx of
ClaimNsPath path -> T.pack $ "claims_namespace_path " <> encodeJSONPath path
ClaimNs ns -> "claims_namespace " <> ns
claimsErr = throw400 JWTInvalidClaims
parseIValueJsonValue (J.IError _ _) = Nothing
parseIValueJsonValue (J.ISuccess v) = Just v
-- see if there is a x-hasura-role header, or else pick the default role
getCurrentRole defaultRole =
let mUserRole = getRequestHeader userRoleHeader headers
in fromMaybe defaultRole $ mUserRole >>= mkRoleName . bsToTxt
decodeJSON val = case J.fromJSON val of
J.Error e -> throw400 JWTInvalidClaims ("x-hasura-* claims: " <> T.pack e)
J.Success a -> return a
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"
currRoleNotAllowed =
throw400 AccessDenied "Your current role is not in allowed roles"
claimsNotFound = do
let claimsNsError = case jcxClaimNs jwtCtx of
ClaimNsPath path -> T.pack $ "claims not found at claims_namespace_path: '"
<> encodeJSONPath path <> "'"
ClaimNs ns -> "claims key: '" <> ns <> "' not found"
throw400 JWTInvalidClaims claimsNsError
-- parse x-hasura-allowed-roles, x-hasura-default-role from JWT claims
parseHasuraClaims
:: (MonadError QErr m)
=> J.Object -> m HasuraClaims
parseHasuraClaims claimsMap = do
let mAllowedRolesV = Map.lookup allowedRolesClaim claimsMap
allowedRolesV <- maybe missingAllowedRolesClaim return mAllowedRolesV
allowedRoles <- parseJwtClaim (J.fromJSON allowedRolesV) errMsg
let mDefaultRoleV = Map.lookup defaultRoleClaim claimsMap
defaultRoleV <- maybe missingDefaultRoleClaim return mDefaultRoleV
defaultRole <- parseJwtClaim (J.fromJSON defaultRoleV) errMsg
return $ HasuraClaims allowedRoles defaultRole
where
missingAllowedRolesClaim =
let msg = "JWT claim does not contain " <> allowedRolesClaim
in throw400 JWTRoleClaimMissing msg
missingDefaultRoleClaim =
let msg = "JWT claim does not contain " <> defaultRoleClaim
in throw400 JWTRoleClaimMissing msg
errMsg _ = "invalid " <> allowedRolesClaim <> "; should be a list of roles"
parseJwtClaim :: (MonadError QErr m) => J.Result a -> (String -> Text) -> m a
parseJwtClaim res errFn =
case res of
J.Success val -> return val
J.Error e -> throw400 JWTInvalidClaims $ errFn e
-- | 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 claimNs aud claimsFmt iss) =
J.object (jwkFields ++ sharedFields ++ claimsNsFields)
where
jwkFields = case keyOrUrl of
Left _ -> [ "type" J..= J.String "<TYPE REDACTED>"
, "key" J..= J.String "<JWK REDACTED>" ]
Right url -> [ "jwk_url" J..= url ]
claimsNsFields = case claimNs of
ClaimNsPath nsPath ->
["claims_namespace_path" J..= encodeJSONPath nsPath]
ClaimNs ns -> ["claims_namespace" J..= J.String ns]
sharedFields = [ "claims_format" J..= claimsFmt
, "audience" J..= aud
, "issuer" J..= iss
]
-- | 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"
isStrngfd <- o J..:? "claims_format"
hasuraClaimsNs <-
case (claimsNsPath,claimsNs) of
(Nothing, Nothing) -> return $ ClaimNs defaultClaimNs
(Just nsPath, Nothing) -> either failJSONPathParsing (return . ClaimNsPath) . JSONPath.parseJSONPath $ nsPath
(Nothing, Just ns) -> return $ ClaimNs ns
(Just _, Just _) -> fail "claims_namespace and claims_namespace_path both cannot be set"
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
return $ JWTConfig (Left key) hasuraClaimsNs aud isStrngfd iss
(Nothing, Just url) ->
return $ JWTConfig (Right url) hasuraClaimsNs aud isStrngfd iss
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: 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