mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
c52bfc540d
This is the result of a general audit of how we fork threads, with a detour into how we're using mutable state especially in websocket codepaths, making more robust to async exceptions and exceptions resulting from bugs. Some highlights: - use a wrapper around 'immortal' so threads that die due to bugs are restarted, and log the error - use 'withAsync' some places - use bracket a few places where we might break invariants - log some codepaths that represent bugs - export UnstructuredLog for ad hoc logging (the alternative is we continue not logging useful stuff) I had to timebox this. There are a few TODOs I didn't want to address. And we'll wait until this is merged to attempt #3705 for Control.Concurrent.Extended
306 lines
9.7 KiB
Haskell
306 lines
9.7 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
module Hasura.Server.Auth
|
|
( getUserInfo
|
|
, getUserInfoWithExpTime
|
|
, AuthMode(..)
|
|
, mkAuthMode
|
|
, AdminSecret (..)
|
|
, AuthHookType(..)
|
|
, AuthHookG (..)
|
|
, AuthHook
|
|
-- JWT related
|
|
, RawJWT
|
|
, JWTConfig (..)
|
|
, JWTCtx (..)
|
|
, JWKSet (..)
|
|
, processJwt
|
|
, updateJwkRef
|
|
, UserAuthentication (..)
|
|
) where
|
|
|
|
import Control.Concurrent.Extended (forkImmortal)
|
|
import Control.Exception (try)
|
|
import Control.Lens
|
|
import Data.Aeson
|
|
import Data.IORef (newIORef)
|
|
import Data.Time.Clock (UTCTime)
|
|
import Hasura.Server.Version (HasVersion)
|
|
|
|
import qualified Data.Aeson as J
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.HashMap.Strict as Map
|
|
import qualified Data.Text as T
|
|
import qualified Network.HTTP.Client as H
|
|
import qualified Network.HTTP.Types as N
|
|
import qualified Network.Wreq as Wreq
|
|
|
|
import Hasura.HTTP
|
|
import Hasura.Logging
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types
|
|
import Hasura.Server.Auth.JWT
|
|
import Hasura.Server.Logging
|
|
import Hasura.Server.Utils
|
|
|
|
-- | Typeclass representing the @UserInfo@ authorization and resolving effect
|
|
class (Monad m) => UserAuthentication m where
|
|
resolveUserInfo
|
|
:: (HasVersion)
|
|
=> Logger Hasura
|
|
-> H.Manager
|
|
-> [N.Header]
|
|
-- ^ request headers
|
|
-> AuthMode
|
|
-> m (Either QErr (UserInfo, Maybe UTCTime))
|
|
|
|
newtype AdminSecret
|
|
= AdminSecret { getAdminSecret :: T.Text }
|
|
deriving (Show, Eq)
|
|
|
|
data AuthHookType
|
|
= AHTGet
|
|
| AHTPost
|
|
deriving (Eq)
|
|
|
|
instance Show AuthHookType where
|
|
show AHTGet = "GET"
|
|
show AHTPost = "POST"
|
|
|
|
data AuthHookG a b
|
|
= AuthHookG
|
|
{ ahUrl :: !a
|
|
, ahType :: !b
|
|
} deriving (Show, Eq)
|
|
|
|
type AuthHook = AuthHookG T.Text AuthHookType
|
|
|
|
data AuthMode
|
|
= AMNoAuth
|
|
| AMAdminSecret !AdminSecret !(Maybe RoleName)
|
|
| AMAdminSecretAndHook !AdminSecret !AuthHook
|
|
| AMAdminSecretAndJWT !AdminSecret !JWTCtx !(Maybe RoleName)
|
|
deriving (Show, Eq)
|
|
|
|
mkAuthMode
|
|
:: ( HasVersion
|
|
, MonadIO m
|
|
, MonadError T.Text m
|
|
)
|
|
=> Maybe AdminSecret
|
|
-> Maybe AuthHook
|
|
-> Maybe JWTConfig
|
|
-> Maybe RoleName
|
|
-> H.Manager
|
|
-> Logger Hasura
|
|
-> m AuthMode
|
|
mkAuthMode mAdminSecret mWebHook mJwtSecret mUnAuthRole httpManager logger =
|
|
case (mAdminSecret, mWebHook, mJwtSecret) of
|
|
(Nothing, Nothing, Nothing) -> return AMNoAuth
|
|
(Just key, Nothing, Nothing) -> return $ AMAdminSecret key mUnAuthRole
|
|
(Just key, Just hook, Nothing) -> unAuthRoleNotReqForWebHook >>
|
|
return (AMAdminSecretAndHook key hook)
|
|
(Just key, Nothing, Just jwtConf) -> do
|
|
jwtCtx <- mkJwtCtx jwtConf httpManager logger
|
|
return $ AMAdminSecretAndJWT key jwtCtx mUnAuthRole
|
|
|
|
(Nothing, Just _, Nothing) -> throwError $
|
|
"Fatal Error : --auth-hook (HASURA_GRAPHQL_AUTH_HOOK)" <> requiresAdminScrtMsg
|
|
(Nothing, Nothing, Just _) -> throwError $
|
|
"Fatal Error : --jwt-secret (HASURA_GRAPHQL_JWT_SECRET)" <> requiresAdminScrtMsg
|
|
(Nothing, Just _, Just _) -> throwError
|
|
"Fatal Error: Both webhook and JWT mode cannot be enabled at the same time"
|
|
(Just _, Just _, Just _) -> throwError
|
|
"Fatal Error: Both webhook and JWT mode cannot be enabled at the same time"
|
|
where
|
|
requiresAdminScrtMsg =
|
|
" requires --admin-secret (HASURA_GRAPHQL_ADMIN_SECRET) or "
|
|
<> " --access-key (HASURA_GRAPHQL_ACCESS_KEY) to be set"
|
|
unAuthRoleNotReqForWebHook =
|
|
when (isJust mUnAuthRole) $ throwError $
|
|
"Fatal Error: --unauthorized-role (HASURA_GRAPHQL_UNAUTHORIZED_ROLE) is not allowed"
|
|
<> " when --auth-hook (HASURA_GRAPHQL_AUTH_HOOK) is set"
|
|
|
|
-- | Given the 'JWTConfig' (the user input of JWT configuration), create the 'JWTCtx' (the runtime JWT config used)
|
|
mkJwtCtx
|
|
:: ( HasVersion
|
|
, MonadIO m
|
|
, MonadError T.Text m
|
|
)
|
|
=> JWTConfig
|
|
-> H.Manager
|
|
-> Logger Hasura
|
|
-> m JWTCtx
|
|
mkJwtCtx JWTConfig{..} httpManager logger = do
|
|
jwkRef <- case jcKeyOrUrl of
|
|
Left jwk -> liftIO $ newIORef (JWKSet [jwk])
|
|
Right url -> getJwkFromUrl url
|
|
let claimsFmt = fromMaybe JCFJson jcClaimsFormat
|
|
return $ JWTCtx jwkRef jcClaimNs jcAudience claimsFmt jcIssuer
|
|
where
|
|
-- if we can't find any expiry time for the JWK (either in @Expires@ header or @Cache-Control@
|
|
-- header), do not start a background thread for refreshing the JWK
|
|
getJwkFromUrl url = do
|
|
ref <- liftIO $ newIORef $ JWKSet []
|
|
maybeExpiry <- withJwkError $ updateJwkRef logger httpManager url ref
|
|
case maybeExpiry of
|
|
Nothing -> return ref
|
|
Just time -> do
|
|
void $ liftIO $ forkImmortal "jwkRefreshCtrl" logger $
|
|
jwkRefreshCtrl logger httpManager url ref (fromUnits time)
|
|
return ref
|
|
|
|
withJwkError act = do
|
|
res <- runExceptT act
|
|
case res of
|
|
Right r -> return r
|
|
Left err -> case err of
|
|
-- when fetching JWK initially, except expiry parsing error, all errors are critical
|
|
JFEHttpException _ msg -> throwError msg
|
|
JFEHttpError _ _ _ e -> throwError e
|
|
JFEJwkParseError _ e -> throwError e
|
|
JFEExpiryParseError _ _ -> return Nothing
|
|
|
|
|
|
-- | Form the 'UserInfo' from the response from webhook
|
|
mkUserInfoFromResp
|
|
:: (MonadIO m, MonadError QErr m)
|
|
=> Logger Hasura
|
|
-> T.Text
|
|
-> N.StdMethod
|
|
-> N.Status
|
|
-> BL.ByteString
|
|
-> m UserInfo
|
|
mkUserInfoFromResp logger url method statusCode respBody
|
|
| statusCode == N.status200 =
|
|
case eitherDecode respBody of
|
|
Left e -> do
|
|
logError
|
|
throw500 $ "Invalid response from authorization hook: " <> T.pack e
|
|
Right rawHeaders -> getUserInfoFromHdrs rawHeaders
|
|
|
|
| statusCode == N.status401 = do
|
|
logError
|
|
throw401 "Authentication hook unauthorized this request"
|
|
|
|
| otherwise = do
|
|
logError
|
|
throw500 "Invalid response from authorization hook"
|
|
where
|
|
getUserInfoFromHdrs rawHeaders = do
|
|
let usrVars = mkUserVars $ Map.toList rawHeaders
|
|
case roleFromVars usrVars of
|
|
Nothing -> do
|
|
logError
|
|
throw500 "missing x-hasura-role key in webhook response"
|
|
Just rn -> do
|
|
logWebHookResp LevelInfo Nothing
|
|
return $ mkUserInfo rn usrVars
|
|
|
|
logError =
|
|
logWebHookResp LevelError $ Just respBody
|
|
|
|
logWebHookResp logLevel mResp =
|
|
unLogger logger $ WebHookLog logLevel (Just statusCode)
|
|
url method Nothing $ fmap (bsToTxt . BL.toStrict) mResp
|
|
|
|
userInfoFromAuthHook
|
|
:: (HasVersion, MonadIO m, MonadError QErr m)
|
|
=> Logger Hasura
|
|
-> H.Manager
|
|
-> AuthHook
|
|
-> [N.Header]
|
|
-> m UserInfo
|
|
userInfoFromAuthHook logger manager hook reqHeaders = do
|
|
res <- liftIO $ try $ bool withGET withPOST isPost
|
|
resp <- either logAndThrow return res
|
|
let status = resp ^. Wreq.responseStatus
|
|
respBody = resp ^. Wreq.responseBody
|
|
|
|
mkUserInfoFromResp logger urlT method status respBody
|
|
where
|
|
mkOptions = wreqOptions manager
|
|
AuthHookG urlT ty = hook
|
|
isPost = case ty of
|
|
AHTPost -> True
|
|
AHTGet -> False
|
|
method = bool N.GET N.POST isPost
|
|
|
|
withGET = Wreq.getWith (mkOptions filteredHeaders) $
|
|
T.unpack urlT
|
|
|
|
contentType = ("Content-Type", "application/json")
|
|
postHdrsPayload = J.toJSON $ Map.fromList $ hdrsToText reqHeaders
|
|
withPOST = Wreq.postWith (mkOptions [contentType]) (T.unpack urlT) $
|
|
object ["headers" J..= postHdrsPayload]
|
|
|
|
logAndThrow err = do
|
|
unLogger logger $
|
|
WebHookLog LevelError Nothing urlT method
|
|
(Just $ HttpException err) Nothing
|
|
throw500 "Internal Server Error"
|
|
|
|
filteredHeaders = flip filter reqHeaders $ \(n, _) ->
|
|
n `notElem` commonClientHeadersIgnored
|
|
|
|
getUserInfo
|
|
:: (HasVersion, MonadIO m, MonadError QErr m)
|
|
=> Logger Hasura
|
|
-> H.Manager
|
|
-> [N.Header]
|
|
-> AuthMode
|
|
-> m UserInfo
|
|
getUserInfo l m r a = fst <$> getUserInfoWithExpTime l m r a
|
|
|
|
getUserInfoWithExpTime
|
|
:: (HasVersion, MonadIO m, MonadError QErr m)
|
|
=> Logger Hasura
|
|
-> H.Manager
|
|
-> [N.Header]
|
|
-> AuthMode
|
|
-> m (UserInfo, Maybe UTCTime)
|
|
getUserInfoWithExpTime logger manager rawHeaders = \case
|
|
|
|
AMNoAuth -> return (userInfoFromHeaders, Nothing)
|
|
|
|
AMAdminSecret adminScrt unAuthRole ->
|
|
case adminSecretM of
|
|
Just givenAdminScrt ->
|
|
withNoExpTime $ userInfoWhenAdminSecret adminScrt givenAdminScrt
|
|
Nothing ->
|
|
withNoExpTime $ userInfoWhenNoAdminSecret unAuthRole
|
|
|
|
AMAdminSecretAndHook accKey hook ->
|
|
whenAdminSecretAbsent accKey $
|
|
withNoExpTime $ userInfoFromAuthHook logger manager hook rawHeaders
|
|
|
|
AMAdminSecretAndJWT accKey jwtSecret unAuthRole ->
|
|
whenAdminSecretAbsent accKey (processJwt jwtSecret rawHeaders unAuthRole)
|
|
|
|
where
|
|
-- when admin secret is absent, run the action to retrieve UserInfo, otherwise
|
|
-- adminsecret override
|
|
whenAdminSecretAbsent ak action =
|
|
maybe action (withNoExpTime . userInfoWhenAdminSecret ak) adminSecretM
|
|
|
|
adminSecretM= foldl1 (<|>) $
|
|
map (`getVarVal` usrVars) [adminSecretHeader, deprecatedAccessKeyHeader]
|
|
|
|
usrVars = mkUserVars $ hdrsToText rawHeaders
|
|
|
|
userInfoWhenAdminSecret key reqKey = do
|
|
when (reqKey /= getAdminSecret key) $ throw401 $
|
|
"invalid " <> adminSecretHeader <> "/" <> deprecatedAccessKeyHeader
|
|
return userInfoFromHeaders
|
|
|
|
userInfoWhenNoAdminSecret = \case
|
|
Nothing -> throw401 $ adminSecretHeader <> "/"
|
|
<> deprecatedAccessKeyHeader <> " required, but not found"
|
|
Just role -> return $ mkUserInfo role usrVars
|
|
|
|
withNoExpTime a = (, Nothing) <$> a
|
|
|
|
userInfoFromHeaders =
|
|
case roleFromVars usrVars of
|
|
Just rn -> mkUserInfo rn usrVars
|
|
Nothing -> mkUserInfo adminRole usrVars
|