mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-22 06:51:32 +03:00
634 lines
30 KiB
Haskell
634 lines
30 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Hasura.Server.AuthSpec (spec) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import qualified Crypto.JOSE.JWK as Jose
|
|
import qualified Crypto.JWT as JWT
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Network.HTTP.Types as N
|
|
|
|
import Control.Lens hiding ((.=))
|
|
import Control.Monad.Trans.Control
|
|
import Control.Monad.Trans.Managed (lowerManagedT)
|
|
import Data.Aeson ((.=))
|
|
import Data.Parser.JSONPath
|
|
|
|
import qualified Hasura.Tracing as Tracing
|
|
|
|
import Hasura.Base.Error
|
|
import Hasura.Logging
|
|
import Hasura.Server.Auth hiding (getUserInfoWithExpTime, processJwt)
|
|
import Hasura.Server.Auth.JWT hiding (processJwt)
|
|
import Hasura.Server.Auth.WebHook (ReqsText)
|
|
import Hasura.Server.Utils
|
|
import Hasura.Server.Version
|
|
import Hasura.Session
|
|
import Test.Hspec
|
|
|
|
|
|
spec :: Spec
|
|
spec = do
|
|
getUserInfoWithExpTimeTests
|
|
setupAuthModeTests
|
|
parseClaimsMapTests
|
|
|
|
allowedRolesClaimText :: Text
|
|
allowedRolesClaimText = sessionVariableToText allowedRolesClaim
|
|
|
|
defaultRoleClaimText :: Text
|
|
defaultRoleClaimText = sessionVariableToText defaultRoleClaim
|
|
|
|
-- Unit test the core of our authentication code. This doesn't test the details
|
|
-- of resolving roles from JWT or webhook.
|
|
-- TODO(swann): does this need to also test passing
|
|
getUserInfoWithExpTimeTests :: Spec
|
|
getUserInfoWithExpTimeTests = describe "getUserInfo" $ do
|
|
---- FUNCTION UNDER TEST:
|
|
let gqlUserInfoWithExpTime
|
|
:: J.Object
|
|
-- ^ For JWT, inject the raw claims object as though returned from 'processAuthZHeader'
|
|
-- acting on an 'Authorization' header from the request
|
|
-> [N.Header] -> AuthMode -> Maybe ReqsText -> IO (Either Code RoleName)
|
|
gqlUserInfoWithExpTime claims rawHeaders authMode =
|
|
runExceptT
|
|
. withExceptT qeCode -- just look at Code for purposes of tests
|
|
. fmap _uiRole -- just look at RoleName for purposes of tests
|
|
. fmap fst -- disregard Nothing expiration
|
|
. getUserInfoWithExpTime_ userInfoFromAuthHook processJwt () () rawHeaders authMode
|
|
where
|
|
-- mock authorization callbacks:
|
|
userInfoFromAuthHook _ _ _hook _reqHeaders _optionalReqs = do
|
|
(, Nothing) <$> _UserInfo "hook"
|
|
where
|
|
-- we don't care about details here; we'll just check role name in tests:
|
|
_UserInfo nm =
|
|
mkUserInfo (URBFromSessionVariablesFallback $ mkRoleNameE nm)
|
|
UAdminSecretNotSent
|
|
(mkSessionVariablesHeaders mempty)
|
|
|
|
processAuthZHeader _jwtCtx _authzHeader =
|
|
return (mapKeys mkSessionVariable claims, Nothing)
|
|
|
|
processJwt = processJwt_ processAuthZHeader (const JHAuthorization)
|
|
|
|
let getUserInfoWithExpTime
|
|
:: J.Object
|
|
-- ^ For JWT, inject the raw claims object as though returned from 'processAuthZHeader'
|
|
-- acting on an 'Authorization' header from the request
|
|
-> [N.Header] -> AuthMode -> IO (Either Code RoleName)
|
|
getUserInfoWithExpTime o claims authMode = gqlUserInfoWithExpTime o claims authMode Nothing
|
|
|
|
let setupAuthMode'E a b c d =
|
|
either (const $ error "fixme") id <$> setupAuthMode' a b c d
|
|
|
|
let ourUnauthRole = mkRoleNameE "an0nymous"
|
|
|
|
describe "started without admin secret" $ do
|
|
it "gives admin by default" $ do
|
|
mode <- setupAuthMode'E Nothing Nothing Nothing Nothing
|
|
getUserInfoWithExpTime mempty [] mode
|
|
`shouldReturn` Right adminRoleName
|
|
it "allows any requested role" $ do
|
|
mode <- setupAuthMode'E Nothing Nothing Nothing Nothing
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "r00t")
|
|
|
|
|
|
describe "admin secret only" $ do
|
|
describe "unauth role NOT set" $ do
|
|
mode <- runIO $ setupAuthMode'E (Just $ hashAdminSecret "secret") Nothing Nothing Nothing
|
|
|
|
it "accepts when admin secret matches" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
it "accepts when admin secret matches, honoring role request" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), (userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "r00t")
|
|
|
|
it "rejects when doesn't match" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (adminSecretHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
-- with deprecated header:
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (deprecatedAccessKeyHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
it "rejects when no secret sent, since no fallback unauth role" $ do
|
|
getUserInfoWithExpTime mempty [] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "r00t"), (userRoleHeader, "admin")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
describe "unauth role set" $ do
|
|
mode <- runIO $
|
|
setupAuthMode'E (Just $ hashAdminSecret "secret") Nothing Nothing (Just ourUnauthRole)
|
|
it "accepts when admin secret matches" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), ("heh", "heh")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
it "accepts when admin secret matches, honoring role request" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), (userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "r00t")
|
|
|
|
it "rejects when doesn't match" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (adminSecretHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
-- with deprecated header:
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (deprecatedAccessKeyHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
it "accepts when no secret sent and unauth role defined" $ do
|
|
getUserInfoWithExpTime mempty [] mode
|
|
`shouldReturn` Right ourUnauthRole
|
|
getUserInfoWithExpTime mempty [("heh", "heh")] mode
|
|
`shouldReturn` Right ourUnauthRole
|
|
-- FIXME MAYBE (see NOTE (*))
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right ourUnauthRole
|
|
|
|
|
|
-- Unauthorized role is not supported for webhook
|
|
describe "webhook" $ do
|
|
mode <- runIO $
|
|
setupAuthMode'E (Just $ hashAdminSecret "secret") (Just fakeAuthHook) Nothing Nothing
|
|
|
|
it "accepts when admin secret matches" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
it "accepts when admin secret matches, honoring role request" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), (userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "r00t")
|
|
|
|
it "rejects when admin secret doesn't match" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (adminSecretHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
-- with deprecated header:
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (deprecatedAccessKeyHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
it "authenticates with webhook when no admin secret sent" $ do
|
|
getUserInfoWithExpTime mempty [] mode
|
|
`shouldReturn` Right (mkRoleNameE "hook")
|
|
getUserInfoWithExpTime mempty [("blah", "blah")] mode
|
|
`shouldReturn` Right (mkRoleNameE "hook")
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "hook")] mode
|
|
`shouldReturn` Right (mkRoleNameE "hook")
|
|
|
|
-- FIXME MAYBE (see NOTE (*))
|
|
it "ignores requested role, uses webhook role" $ do
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "r00t"), (userRoleHeader, "admin")] mode
|
|
`shouldReturn` Right (mkRoleNameE "hook")
|
|
getUserInfoWithExpTime mempty [(userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "hook")
|
|
|
|
|
|
-- helper for generating mocked up verified JWT token claims, as though returned by 'processAuthZHeader':
|
|
let unObject l = case J.object l of
|
|
J.Object o -> o
|
|
_ -> error "impossible"
|
|
|
|
describe "JWT" $ do
|
|
describe "unauth role NOT set" $ do
|
|
mode <- runIO $
|
|
setupAuthMode'E (Just $ hashAdminSecret "secret") Nothing (Just fakeJWTConfig) Nothing
|
|
|
|
it "accepts when admin secret matches" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
it "accepts when admin secret matches, honoring role request" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), (userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "r00t")
|
|
|
|
it "rejects when admin secret doesn't match" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (adminSecretHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
-- with deprecated header:
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (deprecatedAccessKeyHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
it "rejects when admin secret not sent and no 'Authorization' header" $ do
|
|
getUserInfoWithExpTime mempty [("blah", "blah")] mode
|
|
`shouldReturn` Left InvalidHeaders
|
|
getUserInfoWithExpTime mempty [] mode
|
|
`shouldReturn` Left InvalidHeaders
|
|
|
|
describe "unauth role set" $ do
|
|
mode <- runIO $
|
|
setupAuthMode'E (Just $ hashAdminSecret "secret") Nothing
|
|
(Just fakeJWTConfig) (Just ourUnauthRole)
|
|
|
|
it "accepts when admin secret matches" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), ("heh", "heh")] mode
|
|
`shouldReturn` Right adminRoleName
|
|
it "accepts when admin secret matches, honoring role request" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "secret"), (userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Right (mkRoleNameE "r00t")
|
|
|
|
it "rejects when admin secret doesn't match" $ do
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(adminSecretHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (adminSecretHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
-- with deprecated header:
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "bad secret")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [(deprecatedAccessKeyHeader, "")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime mempty [("blah", "blah"), (deprecatedAccessKeyHeader, "blah")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
it "authorizes as unauth role when no 'Authorization' header" $ do
|
|
getUserInfoWithExpTime mempty [("blah", "blah")] mode
|
|
`shouldReturn` Right ourUnauthRole
|
|
getUserInfoWithExpTime mempty [] mode
|
|
`shouldReturn` Right ourUnauthRole
|
|
|
|
describe "when Authorization header sent, and no admin secret" $ do
|
|
modeA <- runIO $ setupAuthMode'E (Just $ hashAdminSecret "secret") Nothing
|
|
(Just fakeJWTConfig) (Just ourUnauthRole)
|
|
modeB <- runIO $ setupAuthMode'E (Just $ hashAdminSecret "secret") Nothing
|
|
(Just fakeJWTConfig) Nothing
|
|
|
|
-- Here the unauth role does not come into play at all, so map same tests over both modes:
|
|
forM_ [(modeA, "with unauth role set"), (modeB, "with unauth role NOT set")] $
|
|
\(mode, modeMsg) -> describe modeMsg $ do
|
|
|
|
it "authorizes successfully with JWT when requested role allowed" $ do
|
|
let claim = unObject [ allowedRolesClaimText .= (["editor","user", "mod"] :: [Text])
|
|
, defaultRoleClaimText .= ("user" :: Text)
|
|
]
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED"), (userRoleHeader, "editor")] mode
|
|
`shouldReturn` Right (mkRoleNameE "editor")
|
|
-- Uses the defaultRoleClaimText:
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED")] mode
|
|
`shouldReturn` Right (mkRoleNameE "user")
|
|
|
|
it "rejects when requested role is not allowed" $ do
|
|
let claim = unObject [ allowedRolesClaimText .= (["editor","user", "mod"] :: [Text])
|
|
, defaultRoleClaimText .= ("user" :: Text)
|
|
]
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED"), (userRoleHeader, "r00t")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED"), (userRoleHeader, "admin")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
-- A corner case, but the behavior seems desirable:
|
|
it "always rejects when token has empty allowedRolesClaimText" $ do
|
|
let claim = unObject [ allowedRolesClaimText .= ([] :: [Text]), defaultRoleClaimText .= ("user" :: Text) ]
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED"), (userRoleHeader, "admin")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED"), (userRoleHeader, "user")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED")] mode
|
|
`shouldReturn` Left AccessDenied
|
|
|
|
it "rejects when token doesn't have proper allowedRolesClaimText and defaultRoleClaimText" $ do
|
|
let claim0 = unObject [ allowedRolesClaimText .= (["editor","user", "mod"] :: [Text]) ]
|
|
claim1 = unObject [ defaultRoleClaimText .= ("user" :: Text) ]
|
|
claim2 = unObject []
|
|
for_ [claim0, claim1, claim2] $ \claim ->
|
|
getUserInfoWithExpTime claim [("Authorization", "IGNORED")] mode
|
|
`shouldReturn` Left JWTRoleClaimMissing
|
|
|
|
-- (*) FIXME NOTE (re above):
|
|
--
|
|
-- Ideally we should always return AccessDenied if the role we would
|
|
-- otherwise have returned does not match the requested role (from the
|
|
-- 'userRoleHeader').
|
|
--
|
|
-- This would harden a bit against bugs, makes the spec simpler, but
|
|
-- especially is better UX since in the current behavior the user can't be
|
|
-- sure which role their query is operating as (and in the worst case we
|
|
-- might e.g. delete rows the user didn't intend)
|
|
--
|
|
-- But this is a breaking change we need to think a little more about;
|
|
-- users might be relying on the behavior, e.g. just hardcoding a dev role
|
|
-- into clients.
|
|
|
|
|
|
-- Some very basic unit tests of AuthMode construction and error modes
|
|
setupAuthModeTests :: Spec
|
|
setupAuthModeTests = describe "setupAuthMode" $ do
|
|
let secret = hashAdminSecret "secret"
|
|
unauthRole = mkRoleNameE "anon"
|
|
|
|
-- These are all various error cases, except for the AMNoAuth mode:
|
|
it "with no admin secret provided" $ do
|
|
setupAuthMode' Nothing Nothing Nothing Nothing
|
|
`shouldReturn` Right AMNoAuth
|
|
-- We insist on an admin secret in order to use webhook or JWT auth:
|
|
setupAuthMode' Nothing Nothing (Just fakeJWTConfig) Nothing
|
|
`shouldReturn` Left ()
|
|
setupAuthMode' Nothing (Just fakeAuthHook) Nothing Nothing
|
|
`shouldReturn` Left ()
|
|
-- ...and we can't have both:
|
|
setupAuthMode' Nothing (Just fakeAuthHook) (Just fakeJWTConfig) Nothing
|
|
`shouldReturn` Left ()
|
|
-- If the unauthenticated role was set but would otherwise be ignored this
|
|
-- should be an error (for now), since users might expect all access to use
|
|
-- the specified role. This first case would be the real worrying one:
|
|
setupAuthMode' Nothing Nothing Nothing (Just unauthRole)
|
|
`shouldReturn` Left ()
|
|
setupAuthMode' Nothing Nothing (Just fakeJWTConfig) (Just unauthRole)
|
|
`shouldReturn` Left ()
|
|
setupAuthMode' Nothing (Just fakeAuthHook) Nothing (Just unauthRole)
|
|
`shouldReturn` Left ()
|
|
setupAuthMode' Nothing (Just fakeAuthHook) (Just fakeJWTConfig) (Just unauthRole)
|
|
`shouldReturn` Left ()
|
|
|
|
it "with admin secret provided" $ do
|
|
setupAuthMode' (Just secret) Nothing Nothing Nothing
|
|
`shouldReturn` Right (AMAdminSecret secret Nothing)
|
|
setupAuthMode' (Just secret) Nothing Nothing (Just unauthRole)
|
|
`shouldReturn` Right (AMAdminSecret secret $ Just unauthRole)
|
|
|
|
setupAuthMode' (Just secret) Nothing (Just fakeJWTConfig) Nothing >>= \case
|
|
Right (AMAdminSecretAndJWT s _ Nothing) -> do
|
|
s `shouldBe` secret
|
|
_ -> expectationFailure "AMAdminSecretAndJWT"
|
|
setupAuthMode' (Just secret) Nothing (Just fakeJWTConfig) (Just unauthRole) >>= \case
|
|
Right (AMAdminSecretAndJWT s _ ur) -> do
|
|
s `shouldBe` secret
|
|
ur `shouldBe` Just unauthRole
|
|
_ -> expectationFailure "AMAdminSecretAndJWT"
|
|
|
|
setupAuthMode' (Just secret) (Just fakeAuthHook) Nothing Nothing
|
|
`shouldReturn` Right (AMAdminSecretAndHook secret fakeAuthHook)
|
|
-- auth hook can't make use of unauthenticated role for now (no good UX):
|
|
setupAuthMode' (Just secret) (Just fakeAuthHook) Nothing (Just unauthRole)
|
|
`shouldReturn` Left ()
|
|
-- we can't have both:
|
|
setupAuthMode' (Just secret) (Just fakeAuthHook) (Just fakeJWTConfig) Nothing
|
|
`shouldReturn` Left ()
|
|
setupAuthMode' (Just secret) (Just fakeAuthHook) (Just fakeJWTConfig) (Just unauthRole)
|
|
`shouldReturn` Left ()
|
|
|
|
parseClaimsMapTests :: Spec
|
|
parseClaimsMapTests = describe "parseClaimMapTests" $ do
|
|
let
|
|
parseClaimsMap_
|
|
:: JWT.ClaimsSet
|
|
-> JWTClaims
|
|
-> IO (Either Code ClaimsMap)
|
|
parseClaimsMap_ claimsSet claims =
|
|
runExceptT $ withExceptT qeCode $ parseClaimsMap claimsSet claims
|
|
|
|
unObject l = case J.object l of
|
|
J.Object o -> o
|
|
_ -> error "Impossible!"
|
|
|
|
defaultClaimsMap =
|
|
Map.fromList
|
|
[ (allowedRolesClaim, J.toJSON (map mkRoleNameE ["user","editor"]))
|
|
, (defaultRoleClaim, J.toJSON (mkRoleNameE "user"))]
|
|
|
|
describe "JWT configured with namespace" $ do
|
|
|
|
describe "JWT configured with namespace key, the key is a text value which is expected to be at the root of the JWT token" $ do
|
|
it "parses claims map from the JWT token with correct namespace " $ do
|
|
let claimsObj = unObject $
|
|
[ "x-hasura-allowed-roles" .= (["user","editor"] :: [Text])
|
|
, "x-hasura-default-role" .= ("user" :: Text)
|
|
]
|
|
let obj = unObject $ ["claims_map" .= claimsObj]
|
|
claimsSet = mkClaimsSetWithUnregisteredClaims obj
|
|
parseClaimsMap_ claimsSet (JCNamespace (ClaimNs "claims_map") defaultClaimsFormat)
|
|
`shouldReturn`
|
|
Right defaultClaimsMap
|
|
|
|
it "doesn't parse claims map from the JWT token with wrong namespace " $ do
|
|
let claimsObj = unObject $
|
|
[ "x-hasura-allowed-roles" .= (["user","editor"] :: [Text])
|
|
, "x-hasura-default-role" .= ("user" :: Text)
|
|
]
|
|
let obj = unObject $ ["claims_map" .= claimsObj]
|
|
claimsSet = mkClaimsSetWithUnregisteredClaims obj
|
|
parseClaimsMap_ claimsSet (JCNamespace (ClaimNs "wrong_claims_map") defaultClaimsFormat)
|
|
`shouldReturn`
|
|
Left JWTInvalidClaims
|
|
|
|
describe "JWT configured with namespace JSON path, JSON path to the claims map" $ do
|
|
it "parse claims map from the JWT token using claims namespace JSON Path" $ do
|
|
let unregisteredClaims = unObject $
|
|
[ "x-hasura-allowed-roles" .= (["user","editor"] :: [Text])
|
|
, "x-hasura-default-role" .= ("user" :: Text)
|
|
, "sub" .= ("random" :: Text)
|
|
, "exp" .= (1626420800 :: Int) -- we ignore these non session variables, in the response
|
|
]
|
|
claimsSetWithSub =
|
|
(JWT.emptyClaimsSet & JWT.claimSub .~ Just "random") & JWT.unregisteredClaims .~ unregisteredClaims
|
|
parseClaimsMap_ claimsSetWithSub (JCNamespace (ClaimNsPath (mkJSONPathE "$")) defaultClaimsFormat)
|
|
-- "$" JSON path signifies the claims are to be found in the root of the JWT token
|
|
`shouldReturn`
|
|
Right defaultClaimsMap
|
|
|
|
it "throws error while attempting to parse claims map from the JWT token with a wrong namespace JSON Path" $ do
|
|
let claimsObj = unObject $
|
|
[ "x-hasura-allowed-roles" .= (["user","editor"] :: [Text])
|
|
, "x-hasura-default-role" .= ("user" :: Text)
|
|
]
|
|
obj = unObject $ [ "hasura_claims" .= claimsObj ]
|
|
claimsSet = mkClaimsSetWithUnregisteredClaims obj
|
|
parseClaimsMap_ claimsSet (JCNamespace (ClaimNsPath (mkJSONPathE "$.claims")) defaultClaimsFormat)
|
|
`shouldReturn`
|
|
Left JWTInvalidClaims
|
|
|
|
describe "JWT configured with custom JWT claims" $ do
|
|
|
|
let rolesObj = unObject $
|
|
[ "allowed" .= (["user","editor"] :: [Text])
|
|
, "default" .= ("user" :: Text)
|
|
]
|
|
userId = unObject [ "id" .= ("1" :: Text)]
|
|
obj = unObject $ [ "roles" .= rolesObj
|
|
, "user" .= userId
|
|
]
|
|
claimsSet = mkClaimsSetWithUnregisteredClaims obj
|
|
userIdClaim = mkSessionVariable "x-hasura-user-id"
|
|
|
|
describe "custom claims with JSON paths to the claim location in the JWT token" $ do
|
|
|
|
it "parse custom claims values, with correct values" $ do
|
|
let customDefRoleClaim = mkCustomDefaultRoleClaim (Just "$.roles.default") Nothing
|
|
customAllowedRolesClaim = mkCustomAllowedRoleClaim (Just "$.roles.allowed") Nothing
|
|
otherClaims = Map.fromList
|
|
[(userIdClaim, mkCustomOtherClaim (Just "$.user.id") Nothing)]
|
|
customClaimsMap = JWTCustomClaimsMap customDefRoleClaim customAllowedRolesClaim otherClaims
|
|
|
|
parseClaimsMap_ claimsSet (JCMap customClaimsMap)
|
|
`shouldReturn`
|
|
Right (Map.fromList
|
|
[ (allowedRolesClaim, J.toJSON (map mkRoleNameE ["user","editor"]))
|
|
, (defaultRoleClaim, J.toJSON (mkRoleNameE "user"))
|
|
, (userIdClaim, J.String "1")
|
|
])
|
|
|
|
it "parse custom claims values with session variable mapped to a standard JWT claim (sub)" $ do
|
|
let customDefRoleClaim = mkCustomDefaultRoleClaim (Just "$.roles.default") Nothing
|
|
customAllowedRolesClaim = mkCustomAllowedRoleClaim (Just "$.roles.allowed") Nothing
|
|
otherClaims = Map.fromList
|
|
[(userIdClaim, mkCustomOtherClaim (Just "$.sub") Nothing)]
|
|
customClaimsMap = JWTCustomClaimsMap customDefRoleClaim customAllowedRolesClaim otherClaims
|
|
|
|
parseClaimsMap_ (claimsSet & JWT.claimSub .~ (Just "2")) (JCMap customClaimsMap)
|
|
`shouldReturn`
|
|
Right (Map.fromList
|
|
[ (allowedRolesClaim, J.toJSON (map mkRoleNameE ["user","editor"]))
|
|
, (defaultRoleClaim, J.toJSON (mkRoleNameE "user"))
|
|
, (userIdClaim, J.String "2")
|
|
])
|
|
|
|
it "throws error when a specified custom claim value is missing" $ do
|
|
|
|
let customDefRoleClaim = mkCustomDefaultRoleClaim (Just "$.roles.wrong_default") Nothing -- wrong path provided
|
|
customAllowedRolesClaim = mkCustomAllowedRoleClaim (Just "$.roles.allowed") Nothing
|
|
customClaimsMap = JWTCustomClaimsMap customDefRoleClaim customAllowedRolesClaim mempty
|
|
parseClaimsMap_ claimsSet (JCMap customClaimsMap)
|
|
`shouldReturn`
|
|
Left JWTRoleClaimMissing
|
|
|
|
it "doesn't throw an error when the specified custom claim is missing, but the default value is provided" $ do
|
|
|
|
let customDefRoleClaim = mkCustomDefaultRoleClaim (Just "$.roles.wrong_default") (Just "editor")
|
|
customAllowedRolesClaim = mkCustomAllowedRoleClaim (Just "$.roles.allowed") Nothing
|
|
customClaimsMap = JWTCustomClaimsMap customDefRoleClaim customAllowedRolesClaim mempty
|
|
parseClaimsMap_ claimsSet (JCMap customClaimsMap)
|
|
`shouldReturn`
|
|
Right (Map.fromList
|
|
[ (allowedRolesClaim, J.toJSON (map mkRoleNameE ["user","editor"]))
|
|
, (defaultRoleClaim, J.toJSON (mkRoleNameE "editor"))
|
|
])
|
|
|
|
describe "custom claims with literal values" $ do
|
|
|
|
it "uses the literal custom claim value" $ do
|
|
|
|
let customDefRoleClaim = mkCustomDefaultRoleClaim Nothing (Just "editor")
|
|
customAllowedRolesClaim = mkCustomAllowedRoleClaim Nothing (Just ["user", "editor"])
|
|
customClaimsMap = JWTCustomClaimsMap customDefRoleClaim customAllowedRolesClaim mempty
|
|
parseClaimsMap_ JWT.emptyClaimsSet (JCMap customClaimsMap)
|
|
`shouldReturn`
|
|
Right (Map.fromList
|
|
[ (allowedRolesClaim, J.toJSON (map mkRoleNameE ["user","editor"]))
|
|
, (defaultRoleClaim, J.toJSON (mkRoleNameE "editor"))
|
|
])
|
|
|
|
mkCustomDefaultRoleClaim :: Maybe Text -> Maybe Text -> JWTCustomClaimsMapDefaultRole
|
|
mkCustomDefaultRoleClaim claimPath defVal =
|
|
-- check if claimPath is provided, if not then use the default value
|
|
-- as the literal value by removing the `Maybe` of defVal
|
|
case claimPath of
|
|
Just path -> JWTCustomClaimsMapJSONPath (mkJSONPathE path) $ defRoleName
|
|
Nothing -> JWTCustomClaimsMapStatic $ fromMaybe (mkRoleNameE "user") defRoleName
|
|
where
|
|
defRoleName = mkRoleNameE <$> defVal
|
|
|
|
mkCustomAllowedRoleClaim :: Maybe Text -> Maybe [Text] -> JWTCustomClaimsMapAllowedRoles
|
|
mkCustomAllowedRoleClaim claimPath defVal =
|
|
-- check if claimPath is provided, if not then use the default value
|
|
-- as the literal value by removing the `Maybe` of defVal
|
|
case claimPath of
|
|
Just path -> JWTCustomClaimsMapJSONPath (mkJSONPathE path) $ defAllowedRoles
|
|
Nothing ->
|
|
JWTCustomClaimsMapStatic $
|
|
fromMaybe (mkRoleNameE <$> ["user", "editor"]) defAllowedRoles
|
|
where
|
|
defAllowedRoles = fmap mkRoleNameE <$> defVal
|
|
|
|
-- use for claims other than `x-hasura-default-role` and `x-hasura-allowed-roles`
|
|
mkCustomOtherClaim :: Maybe Text -> Maybe Text -> JWTCustomClaimsMapValue
|
|
mkCustomOtherClaim claimPath defVal =
|
|
-- check if claimPath is provided, if not then use the default value
|
|
-- as the literal value by removing the `Maybe` of defVal
|
|
case claimPath of
|
|
Just path -> JWTCustomClaimsMapJSONPath (mkJSONPathE path) $ defVal
|
|
Nothing -> JWTCustomClaimsMapStatic $ fromMaybe "default claim value" defVal
|
|
|
|
fakeJWTConfig :: JWTConfig
|
|
fakeJWTConfig =
|
|
let jcKeyOrUrl = Left (Jose.fromOctets [])
|
|
jcAudience = Nothing
|
|
jcIssuer = Nothing
|
|
jcClaims = JCNamespace (ClaimNs "") JCFJson
|
|
jcAllowedSkew = Nothing
|
|
jcHeader = Nothing
|
|
in JWTConfig{..}
|
|
|
|
fakeAuthHook :: AuthHook
|
|
fakeAuthHook = AuthHookG "http://fake" AHTGet
|
|
|
|
mkRoleNameE :: Text -> RoleName
|
|
mkRoleNameE = fromMaybe (error "fixme") . mkRoleName
|
|
|
|
mkJSONPathE :: Text -> JSONPath
|
|
mkJSONPathE = either error id . parseJSONPath
|
|
|
|
newtype NoReporter a = NoReporter { runNoReporter :: IO a }
|
|
deriving newtype (Functor, Applicative, Monad, MonadIO, MonadBase IO, MonadBaseControl IO)
|
|
|
|
instance Tracing.HasReporter NoReporter
|
|
|
|
setupAuthMode'
|
|
:: Maybe AdminSecretHash
|
|
-> Maybe AuthHook
|
|
-> Maybe JWTConfig
|
|
-> Maybe RoleName
|
|
-> IO (Either () AuthMode)
|
|
setupAuthMode' mAdminSecretHash mWebHook mJwtSecret mUnAuthRole =
|
|
withVersion (VersionDev "fake") $
|
|
-- just throw away the error message for ease of testing:
|
|
fmap (either (const $ Left ()) Right)
|
|
$ runNoReporter
|
|
$ lowerManagedT
|
|
$ runExceptT
|
|
$ setupAuthMode mAdminSecretHash mWebHook mJwtSecret mUnAuthRole
|
|
-- NOTE: this won't do any http or launch threads if we don't specify JWT URL:
|
|
(error "H.Manager") (Logger $ void . return)
|
|
|
|
mkClaimsSetWithUnregisteredClaims :: HashMap Text J.Value -> JWT.ClaimsSet
|
|
mkClaimsSetWithUnregisteredClaims unregisteredClaims
|
|
= JWT.emptyClaimsSet & JWT.unregisteredClaims .~ unregisteredClaims
|