mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
135 lines
4.0 KiB
Haskell
135 lines
4.0 KiB
Haskell
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE LambdaCase #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Hasura.Server.Auth
|
|
( getUserInfo
|
|
, AuthMode(..)
|
|
) where
|
|
|
|
import Control.Exception (try)
|
|
import Control.Lens
|
|
import Data.Aeson
|
|
import Data.CaseInsensitive (CI (..), original)
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.HashMap.Strict as M
|
|
import qualified Data.Text as T
|
|
import qualified Data.Text.Encoding as TE
|
|
import qualified Data.Text.Encoding.Error as TE
|
|
import qualified Network.HTTP.Client as H
|
|
import qualified Network.HTTP.Types as N
|
|
import qualified Network.Wreq as Wreq
|
|
|
|
import Hasura.Prelude
|
|
import Hasura.RQL.Types
|
|
|
|
bsToTxt :: B.ByteString -> T.Text
|
|
bsToTxt = TE.decodeUtf8With TE.lenientDecode
|
|
|
|
data AuthMode
|
|
= AMNoAuth
|
|
| AMAccessKey !T.Text
|
|
| AMAccessKeyAndHook !T.Text !T.Text
|
|
deriving (Show, Eq)
|
|
|
|
httpToQErr :: H.HttpException -> QErr
|
|
httpToQErr e = case e of
|
|
H.InvalidUrlException _ _ -> err500 Unexpected "Invalid Webhook Url"
|
|
H.HttpExceptionRequest _ H.ConnectionTimeout -> err500 Unexpected
|
|
"Webhook : Connection timeout"
|
|
H.HttpExceptionRequest _ H.ResponseTimeout -> err500 Unexpected
|
|
"Webhook : Response timeout"
|
|
_ -> err500 Unexpected "HTTP Exception from Webhook"
|
|
|
|
userRoleHeader :: T.Text
|
|
userRoleHeader = "x-hasura-role"
|
|
|
|
userInfoFromWebhook
|
|
:: (MonadIO m, MonadError QErr m)
|
|
=> H.Manager
|
|
-> T.Text
|
|
-> [N.Header]
|
|
-> m UserInfo
|
|
userInfoFromWebhook manager urlT reqHeaders = do
|
|
let options =
|
|
Wreq.defaults
|
|
& Wreq.headers .~ filteredHeaders
|
|
& Wreq.checkResponse ?~ (\_ _ -> return ())
|
|
& Wreq.manager .~ Right manager
|
|
|
|
res <- liftIO $ try $ Wreq.getWith options $ T.unpack urlT
|
|
resp <- either (throwError . httpToQErr) return res
|
|
let status = resp ^. Wreq.responseStatus
|
|
|
|
validateStatus status
|
|
rawHeaders <- decodeResp $ resp ^. Wreq.responseBody
|
|
|
|
let headers = M.fromList [(T.toLower k, v) | (k, v) <- M.toList rawHeaders]
|
|
|
|
case M.lookup userRoleHeader headers of
|
|
Nothing -> throw500 "missing x-hasura-role key in webhook response: "
|
|
Just v -> return $ UserInfo (RoleName v) headers
|
|
|
|
where
|
|
filteredHeaders = flip filter reqHeaders $ \(n, _) ->
|
|
n `notElem` ["Content-Length", "User-Agent", "Host", "Origin", "Referer"]
|
|
|
|
validateStatus statusCode
|
|
| statusCode == N.status200 = return ()
|
|
| statusCode == N.status401 =
|
|
throw401 "Authentication hook unauthorized this request"
|
|
| otherwise =
|
|
throw500 "Invalid response from authorization hook"
|
|
|
|
decodeResp bs = case eitherDecode bs of
|
|
Left e -> throw500 $
|
|
"Invalid response from authorization hook: " <> T.pack e
|
|
Right a -> return a
|
|
|
|
accessKeyHeader :: T.Text
|
|
accessKeyHeader = "x-hasura-access-key"
|
|
|
|
getUserInfo
|
|
:: (MonadIO m, MonadError QErr m)
|
|
=> H.Manager
|
|
-> [N.Header]
|
|
-> AuthMode
|
|
-> m UserInfo
|
|
getUserInfo manager rawHeaders = \case
|
|
|
|
AMNoAuth -> return userInfoFromHeaders
|
|
|
|
AMAccessKey accKey ->
|
|
case getHeader accessKeyHeader of
|
|
Just givenAccKey -> userInfoWhenAccessKey accKey givenAccKey
|
|
Nothing -> throw401 "x-hasura-access-key required, but not found"
|
|
|
|
AMAccessKeyAndHook accKey hook ->
|
|
maybe
|
|
(userInfoFromWebhook manager hook rawHeaders)
|
|
(userInfoWhenAccessKey accKey) $
|
|
getHeader accessKeyHeader
|
|
|
|
where
|
|
|
|
headers =
|
|
M.fromList $ filter (T.isPrefixOf "x-hasura-" . fst) $
|
|
flip map rawHeaders $
|
|
\(hdrName, hdrVal) ->
|
|
(T.toLower $ bsToTxt $ original hdrName, bsToTxt hdrVal)
|
|
|
|
getHeader h = M.lookup h headers
|
|
|
|
userInfoFromHeaders =
|
|
case M.lookup "x-hasura-role" headers of
|
|
Just v -> UserInfo (RoleName v) headers
|
|
Nothing -> UserInfo adminRole M.empty
|
|
|
|
userInfoWhenAccessKey key reqKey = do
|
|
when (reqKey /= key) $ throw401 "invalid x-hasura-access-key"
|
|
return userInfoFromHeaders
|