graphql-engine/server/src-lib/Hasura/Server/App.hs

437 lines
15 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
2018-06-27 16:11:32 +03:00
module Hasura.Server.App where
import Control.Arrow ((***))
2018-06-27 16:11:32 +03:00
import Control.Concurrent.MVar
import Data.Aeson hiding (json)
import Data.IORef
import Data.Time.Clock (UTCTime,
getCurrentTime)
import Network.Wai (requestHeaders,
strictRequestBody)
2018-06-27 16:11:32 +03:00
import Web.Spock.Core
import qualified Data.ByteString.Lazy as BL
#ifdef LocalConsole
import qualified Data.FileEmbed as FE
#endif
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S
import qualified Data.Text as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as N
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import qualified Text.Mustache as M
import qualified Text.Mustache.Compile as M
2018-06-27 16:11:32 +03:00
import qualified Database.PG.Query as Q
import qualified Hasura.GraphQL.Explain as GE
import qualified Hasura.GraphQL.Schema as GS
import qualified Hasura.GraphQL.Transport.HTTP as GH
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Transport.WebSocket as WS
add support for jwt authorization (close #186) (#255) The API: 1. HGE has `--jwt-secret` flag or `HASURA_GRAPHQL_JWT_SECRET` env var. The value of which is a JSON. 2. The structure of this JSON is: `{"type": "<standard-JWT-algorithms>", "key": "<the-key>"}` `type` : Standard JWT algos : `HS256`, `RS256`, `RS512` etc. (see jwt.io). `key`: i. Incase of symmetric key, the key as it is. ii. Incase of asymmetric keys, only the public key, in a PEM encoded string or as a X509 certificate. 3. The claims in the JWT token must contain the following: i. `x-hasura-default-role` field: default role of that user ii. `x-hasura-allowed-roles` : A list of allowed roles for the user. The default role is overriden by `x-hasura-role` header. 4. The claims in the JWT token, can have other `x-hasura-*` fields where their values can only be strings. 5. The JWT tokens are sent as `Authorization: Bearer <token>` headers. --- To test: 1. Generate a shared secret (for HMAC-SHA256) or RSA key pair. 2. Goto https://jwt.io/ , add the keys 3. Edit the claims to have `x-hasura-role` (mandatory) and other `x-hasura-*` fields. Add permissions related to the claims to test permissions. 4. Start HGE with `--jwt-secret` flag or `HASURA_GRAPHQL_JWT_SECRET` env var, which takes a JSON string: `{"type": "HS256", "key": "mylongsharedsecret"}` or `{"type":"RS256", "key": "<PEM-encoded-public-key>"}` 5. Copy the JWT token from jwt.io and use it in the `Authorization: Bearer <token>` header. --- TODO: Support EC public keys. It is blocked on frasertweedale/hs-jose#61
2018-08-30 13:32:09 +03:00
import qualified Hasura.Logging as L
2018-06-27 16:11:32 +03:00
import Hasura.EncJSON
import Hasura.GraphQL.RemoteServer
import Hasura.Prelude hiding (get, put)
2018-06-27 16:11:32 +03:00
import Hasura.RQL.DDL.Schema.Table
import Hasura.RQL.DML.QueryTemplate
import Hasura.RQL.Types
import Hasura.Server.Auth (AuthMode (..),
getUserInfo)
import Hasura.Server.Cors
2018-06-27 16:11:32 +03:00
import Hasura.Server.Init
import Hasura.Server.Logging
import Hasura.Server.Middleware (corsMiddleware)
2018-06-27 16:11:32 +03:00
import Hasura.Server.Query
import Hasura.Server.Utils
import Hasura.Server.Version
2018-06-27 16:11:32 +03:00
import Hasura.SQL.Types
consoleTmplt :: M.Template
consoleTmplt = $(M.embedSingleTemplate "src-rsr/console.html")
2019-01-28 16:55:28 +03:00
boolToText :: Bool -> T.Text
boolToText = bool "false" "true"
isAdminSecretSet :: AuthMode -> T.Text
isAdminSecretSet AMNoAuth = boolToText False
isAdminSecretSet _ = boolToText True
#ifdef LocalConsole
consoleAssetsLoc :: Text
consoleAssetsLoc = "/static"
#else
consoleAssetsLoc :: Text
consoleAssetsLoc =
"https://storage.googleapis.com/hasura-graphql-engine/console/" <> consoleVersion
#endif
2019-01-28 16:55:28 +03:00
mkConsoleHTML :: T.Text -> AuthMode -> Bool -> Either String T.Text
mkConsoleHTML path authMode enableTelemetry =
bool (Left errMsg) (Right res) $ null errs
where
(errs, res) = M.checkedSubstitute consoleTmplt $
object [ "consoleAssetsLoc" .= consoleAssetsLoc
, "isAdminSecretSet" .= isAdminSecretSet authMode
, "consolePath" .= consolePath
2019-01-28 16:55:28 +03:00
, "enableTelemetry" .= boolToText enableTelemetry
]
consolePath = case path of
"" -> "/console"
r -> "/console/" <> r
errMsg = "console template rendering failed: " ++ show errs
data SchemaCacheRef
= SchemaCacheRef
{ _scrLock :: MVar ()
, _scrCache :: IORef SchemaCache
}
withSCUpdate
:: (MonadIO m, MonadError e m)
=> SchemaCacheRef -> m (a, SchemaCache) -> m a
withSCUpdate scr action = do
acquireLock
(res, newSC) <- action `catchError` onError
-- update schemacache in IO reference
liftIO $ writeIORef cacheRef newSC
releaseLock
return res
where
SchemaCacheRef lk cacheRef = scr
onError e = releaseLock >> throwError e
acquireLock = liftIO $ takeMVar lk
releaseLock = liftIO $ putMVar lk ()
2018-06-27 16:11:32 +03:00
data ServerCtx
= ServerCtx
{ scIsolation :: Q.TxIsolation
, scPGPool :: Q.PGPool
, scLogger :: L.Logger
, scCacheRef :: SchemaCacheRef
, scAuthMode :: AuthMode
, scManager :: HTTP.Manager
, scStringifyNum :: Bool
, scEnabledAPIs :: S.HashSet API
, scInstanceId :: InstanceId
2018-06-27 16:11:32 +03:00
}
data HandlerCtx
= HandlerCtx
{ hcServerCtx :: ServerCtx
, hcReqBody :: BL.ByteString
, hcUser :: UserInfo
, hcReqHeaders :: [N.Header]
2018-06-27 16:11:32 +03:00
}
type Handler = ExceptT QErr (ReaderT HandlerCtx IO)
isMetadataEnabled :: ServerCtx -> Bool
isMetadataEnabled sc = S.member METADATA $ scEnabledAPIs sc
isGraphQLEnabled :: ServerCtx -> Bool
isGraphQLEnabled sc = S.member GRAPHQL $ scEnabledAPIs sc
-- {-# SCC parseBody #-}
2018-06-27 16:11:32 +03:00
parseBody :: (FromJSON a) => Handler a
parseBody = do
reqBody <- hcReqBody <$> ask
case decode' reqBody of
Just jVal -> decodeValue jVal
Nothing -> throw400 InvalidJSON "invalid json"
onlyAdmin :: Handler ()
onlyAdmin = do
uRole <- asks (userRole . hcUser)
2018-06-27 16:11:32 +03:00
when (uRole /= adminRole) $
throw400 AccessDenied "You have to be an admin to access this endpoint"
buildQCtx :: Handler QCtx
buildQCtx = do
scRef <- scCacheRef . hcServerCtx <$> ask
userInfo <- asks hcUser
cache <- liftIO $ readIORef $ _scrCache scRef
strfyNum <- scStringifyNum . hcServerCtx <$> ask
return $ QCtx userInfo cache $ SQLGenCtx strfyNum
2018-06-27 16:11:32 +03:00
logResult
:: (MonadIO m)
=> Maybe UserInfo -> Wai.Request -> BL.ByteString -> ServerCtx
-> Either QErr BL.ByteString -> Maybe (UTCTime, UTCTime)
-> m ()
logResult userInfoM req reqBody sc res qTime =
liftIO $ logger $ mkAccessLog userInfoM req (reqBody, res) qTime
where
logger = L.unLogger $ scLogger sc
logError
:: MonadIO m
=> Maybe UserInfo -> Wai.Request
-> BL.ByteString -> ServerCtx -> QErr -> m ()
logError userInfoM req reqBody sc qErr =
logResult userInfoM req reqBody sc (Left qErr) Nothing
2018-06-27 16:11:32 +03:00
mkSpockAction
:: (MonadIO m)
=> (Bool -> QErr -> Value)
2018-06-27 16:11:32 +03:00
-> ServerCtx
-> Handler EncJSON
2018-06-27 16:11:32 +03:00
-> ActionT m ()
mkSpockAction qErrEncoder serverCtx handler = do
req <- request
reqBody <- liftIO $ strictRequestBody req
let headers = requestHeaders req
authMode = scAuthMode serverCtx
manager = scManager serverCtx
2018-06-27 16:11:32 +03:00
userInfoE <- liftIO $ runExceptT $ getUserInfo logger manager headers authMode
userInfo <- either (logAndThrow req reqBody False) return userInfoE
2018-06-27 16:11:32 +03:00
let handlerState = HandlerCtx serverCtx reqBody userInfo headers
2018-06-27 16:11:32 +03:00
t1 <- liftIO getCurrentTime -- for measuring response time purposes
result <- liftIO $ runReaderT (runExceptT handler) handlerState
t2 <- liftIO getCurrentTime -- for measuring response time purposes
let resLBS = fmap encJToLBS result
-- log result
logResult (Just userInfo) req reqBody serverCtx resLBS $ Just (t1, t2)
either (qErrToResp $ userRole userInfo == adminRole) resToResp resLBS
2018-06-27 16:11:32 +03:00
where
logger = scLogger serverCtx
2018-06-27 16:11:32 +03:00
-- encode error response
qErrToResp :: (MonadIO m) => Bool -> QErr -> ActionCtxT ctx m b
qErrToResp includeInternal qErr = do
2018-06-27 16:11:32 +03:00
setStatus $ qeStatus qErr
json $ qErrEncoder includeInternal qErr
logAndThrow req reqBody includeInternal qErr = do
logError Nothing req reqBody serverCtx qErr
qErrToResp includeInternal qErr
2018-06-27 16:11:32 +03:00
resToResp resp = do
2018-06-27 16:11:32 +03:00
uncurry setHeader jsonHeader
lazyBytes resp
v1QueryHandler :: RQLQuery -> Handler EncJSON
2018-06-27 16:11:32 +03:00
v1QueryHandler query = do
scRef <- scCacheRef . hcServerCtx <$> ask
bool (fst <$> dbAction) (withSCUpdate scRef dbActionReload) $
2018-06-27 16:11:32 +03:00
queryNeedsReload query
where
-- Hit postgres
dbAction = do
userInfo <- asks hcUser
2018-06-27 16:11:32 +03:00
scRef <- scCacheRef . hcServerCtx <$> ask
schemaCache <- liftIO $ readIORef $ _scrCache scRef
httpMgr <- scManager . hcServerCtx <$> ask
strfyNum <- scStringifyNum . hcServerCtx <$> ask
2018-06-27 16:11:32 +03:00
pool <- scPGPool . hcServerCtx <$> ask
isoL <- scIsolation . hcServerCtx <$> ask
instanceId <- scInstanceId . hcServerCtx <$> ask
runQuery pool isoL instanceId userInfo schemaCache httpMgr strfyNum query
2018-06-27 16:11:32 +03:00
-- Also update the schema cache
dbActionReload = do
(resp, newSc) <- dbAction
httpMgr <- scManager . hcServerCtx <$> ask
--FIXME: should we be fetching the remote schema again? if not how do we get the remote schema?
newGCtxMap <- GS.mkGCtxMap (scTables newSc) (scFunctions newSc)
(mergedGCtxMap, defGCtx) <-
mergeSchemas (scRemoteResolvers newSc) newGCtxMap httpMgr
let newSc' =
newSc { scGCtxMap = mergedGCtxMap, scDefaultRemoteGCtx = defGCtx }
return (resp, newSc')
2018-06-27 16:11:32 +03:00
v1Alpha1GQHandler :: GH.GraphQLRequest -> Handler EncJSON
2018-06-27 16:11:32 +03:00
v1Alpha1GQHandler query = do
userInfo <- asks hcUser
reqBody <- asks hcReqBody
reqHeaders <- asks hcReqHeaders
manager <- scManager . hcServerCtx <$> ask
2018-06-27 16:11:32 +03:00
scRef <- scCacheRef . hcServerCtx <$> ask
sc <- liftIO $ readIORef $ _scrCache scRef
2018-06-27 16:11:32 +03:00
pool <- scPGPool . hcServerCtx <$> ask
isoL <- scIsolation . hcServerCtx <$> ask
strfyNum <- scStringifyNum . hcServerCtx <$> ask
GH.runGQ pool isoL userInfo (SQLGenCtx strfyNum) sc manager reqHeaders query reqBody
2018-06-27 16:11:32 +03:00
gqlExplainHandler :: GE.GQLExplain -> Handler EncJSON
gqlExplainHandler query = do
onlyAdmin
scRef <- scCacheRef . hcServerCtx <$> ask
sc <- liftIO $ readIORef $ _scrCache scRef
pool <- scPGPool . hcServerCtx <$> ask
isoL <- scIsolation . hcServerCtx <$> ask
strfyNum <- scStringifyNum . hcServerCtx <$> ask
GE.explainGQLQuery pool isoL sc (SQLGenCtx strfyNum) query
2018-06-27 16:11:32 +03:00
newtype QueryParser
= QueryParser { getQueryParser :: QualifiedTable -> Handler RQLQuery }
queryParsers :: M.HashMap T.Text QueryParser
queryParsers =
M.fromList
[ ("select", mkQueryParser RQSelect)
, ("insert", mkQueryParser RQInsert)
, ("update", mkQueryParser RQUpdate)
, ("delete", mkQueryParser RQDelete)
, ("count", mkQueryParser RQCount)
]
where
mkQueryParser f =
QueryParser $ \qt -> do
obj <- parseBody
let val = Object $ M.insert "table" (toJSON qt) obj
q <- decodeValue val
return $ f q
legacyQueryHandler :: TableName -> T.Text -> Handler EncJSON
2018-06-27 16:11:32 +03:00
legacyQueryHandler tn queryType =
case M.lookup queryType queryParsers of
Just queryParser -> getQueryParser queryParser qt >>= v1QueryHandler
Nothing -> throw404 "No such resource exists"
2018-06-27 16:11:32 +03:00
where
qt = QualifiedObject publicSchema tn
2018-06-27 16:11:32 +03:00
mkWaiApp
:: Q.TxIsolation -> L.LoggerCtx -> Bool
-> Q.PGPool -> HTTP.Manager -> AuthMode
-> CorsConfig -> Bool -> Bool
-> InstanceId -> S.HashSet API
-> IO (Wai.Application, SchemaCacheRef, Maybe UTCTime)
mkWaiApp isoLevel loggerCtx strfyNum pool httpManager mode corsCfg
enableConsole enableTelemetry instanceId apis = do
(cacheRef, cacheBuiltTime) <- do
pgResp <- runExceptT $ peelRun emptySchemaCache adminUserInfo
httpManager strfyNum pool Q.Serializable $ do
buildSchemaCache
liftTx fetchLastUpdate
(time, sc) <- either initErrExit return pgResp
scRef <- newIORef sc
return (scRef, snd <$> time)
2018-06-27 16:11:32 +03:00
cacheLock <- newMVar ()
let schemaCacheRef = SchemaCacheRef cacheLock cacheRef
serverCtx = ServerCtx isoLevel pool (L.mkLogger loggerCtx)
schemaCacheRef mode httpManager strfyNum apis instanceId
spockApp <- spockAsApp $ spockT id $
2019-01-28 16:55:28 +03:00
httpApp corsCfg serverCtx enableConsole enableTelemetry
let runTx tx = runExceptT $ runLazyTx pool isoLevel tx
corsPolicy = mkDefaultCorsPolicy corsCfg
sqlGenCtx = SQLGenCtx strfyNum
2018-06-27 16:11:32 +03:00
wsServerEnv <- WS.createWSServerEnv (scLogger serverCtx) httpManager sqlGenCtx
cacheRef runTx corsPolicy
let wsServerApp = WS.createWSServerApp mode wsServerEnv
return ( WS.websocketsOr WS.defaultConnectionOptions wsServerApp spockApp
, schemaCacheRef
, cacheBuiltTime
)
2018-06-27 16:11:32 +03:00
2019-01-28 16:55:28 +03:00
httpApp :: CorsConfig -> ServerCtx -> Bool -> Bool -> SpockT IO ()
httpApp corsCfg serverCtx enableConsole enableTelemetry = do
2018-06-27 16:11:32 +03:00
-- cors middleware
unless (isCorsDisabled corsCfg) $
middleware $ corsMiddleware (mkDefaultCorsPolicy corsCfg)
2018-06-27 16:11:32 +03:00
-- API Console and Root Dir
when (enableConsole && enableMetadata) serveApiConsole
get "v1/version" $ do
uncurry setHeader jsonHeader
lazyBytes $ encode $ object [ "version" .= currentVersion ]
when enableMetadata $ do
get ("v1/template" <//> var) tmpltGetOrDeleteH
post ("v1/template" <//> var) tmpltPutOrPostH
put ("v1/template" <//> var) tmpltPutOrPostH
delete ("v1/template" <//> var) tmpltGetOrDeleteH
2018-06-27 16:11:32 +03:00
post "v1/query" $ mkSpockAction encodeQErr serverCtx $ do
query <- parseBody
v1QueryHandler query
2018-06-27 16:11:32 +03:00
post ("api/1/table" <//> var <//> var) $ \tableName queryType ->
mkSpockAction encodeQErr serverCtx $
legacyQueryHandler (TableName tableName) queryType
2018-06-27 16:11:32 +03:00
when enableGraphQL $ do
post "v1alpha1/graphql/explain" $ mkSpockAction encodeQErr serverCtx $ do
expQuery <- parseBody
gqlExplainHandler expQuery
2018-06-27 16:11:32 +03:00
post "v1alpha1/graphql" $ mkSpockAction GH.encodeGQErr serverCtx $ do
query <- parseBody
v1Alpha1GQHandler query
2018-06-27 16:11:32 +03:00
-- get "v1alpha1/graphql/schema" $
-- mkSpockAction encodeQErr serverCtx v1Alpha1GQSchemaHandler
2018-06-27 16:11:32 +03:00
forM_ [GET,POST] $ \m -> hookAny m $ \_ -> do
let qErr = err404 NotFound "resource does not exist"
raiseGenericApiError qErr
2018-06-27 16:11:32 +03:00
where
enableGraphQL = isGraphQLEnabled serverCtx
enableMetadata = isMetadataEnabled serverCtx
tmpltGetOrDeleteH tmpltName = do
2018-06-27 16:11:32 +03:00
tmpltArgs <- tmpltArgsFromQueryParams
mkSpockAction encodeQErr serverCtx $ mkQTemplateAction tmpltName tmpltArgs
tmpltPutOrPostH tmpltName = do
2018-06-27 16:11:32 +03:00
tmpltArgs <- tmpltArgsFromQueryParams
mkSpockAction encodeQErr serverCtx $ do
bodyTmpltArgs <- parseBody
mkQTemplateAction tmpltName $ M.union bodyTmpltArgs tmpltArgs
tmpltArgsFromQueryParams = do
qparams <- params
return $ M.fromList $ flip map qparams $
TemplateParam *** String
2018-06-27 16:11:32 +03:00
mkQTemplateAction tmpltName tmpltArgs =
v1QueryHandler $ RQExecuteQueryTemplate $
ExecQueryTemplate (TQueryName tmpltName) tmpltArgs
raiseGenericApiError qErr = do
req <- request
reqBody <- liftIO $ strictRequestBody req
logError Nothing req reqBody serverCtx qErr
uncurry setHeader jsonHeader
setStatus $ qeStatus qErr
lazyBytes $ encode qErr
serveApiConsole = do
get root $ redirect "console"
get ("console" <//> wildcard) $ \path ->
either (raiseGenericApiError . err500 Unexpected . T.pack) html $
2019-01-28 16:55:28 +03:00
mkConsoleHTML path (scAuthMode serverCtx) enableTelemetry
#ifdef LocalConsole
get "static/main.js" $ do
setHeader "Content-Type" "text/javascript;charset=UTF-8"
bytes $(FE.embedFile "../console/static/dist/main.js")
get "static/main.css" $ do
setHeader "Content-Type" "text/css;charset=UTF-8"
bytes $(FE.embedFile "../console/static/dist/main.css")
get "static/vendor.js" $ do
setHeader "Content-Type" "text/javascript;charset=UTF-8"
bytes $(FE.embedFile "../console/static/dist/vendor.js")
#endif