hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-15 09:22:43 +03:00
Code Issues Projects Releases Wiki Activity

server: changes catalog initialization and logging for pro customization (#5139)

Browse Source 
* new typeclass to abstract the logic of QueryLog-ing

* abstract the logic of logging websocket-server logs

  introduce a MonadWSLog typeclass

* move catalog initialization to init step

  expose a helper function to migrate catalog
  create schema cache in initialiseCtx

* expose various modules and functions for pro
This commit is contained in:
Anon Ray 2020-06-19 12:12:32 +05:30 committed by GitHub
parent f2428e3984
commit a7a60c2dfe
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
15 changed files with 280 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
server/graphql-engine.cabal
View File

@ -252,11 +252,13 @@ library
-- exposed for Pro -- exposed for Pro
, Hasura.GraphQL.Execute , Hasura.GraphQL.Execute
, Hasura.GraphQL.Execute.Query
, Hasura.GraphQL.Execute.LiveQuery , Hasura.GraphQL.Execute.LiveQuery
, Hasura.GraphQL.Validate , Hasura.GraphQL.Validate
, Hasura.GraphQL.Transport.HTTP , Hasura.GraphQL.Transport.HTTP
, Hasura.GraphQL.Transport.WebSocket.Protocol , Hasura.GraphQL.Transport.WebSocket.Protocol
, Hasura.GraphQL.Transport.WebSocket.Server , Hasura.GraphQL.Transport.WebSocket.Server
, Hasura.GraphQL.Logging
, Hasura.RQL.Types , Hasura.RQL.Types
, Hasura.RQL.Types.Run , Hasura.RQL.Types.Run
@ -272,6 +274,9 @@ library
, Data.Aeson.Ordered , Data.Aeson.Ordered
, Data.TByteString , Data.TByteString
, Network.Wai.Extended
, Control.Concurrent.Extended
other-modules: Hasura.Incremental.Select other-modules: Hasura.Incremental.Select
, Hasura.Incremental.Internal.Cache , Hasura.Incremental.Internal.Cache
, Hasura.Incremental.Internal.Dependency , Hasura.Incremental.Internal.Dependency
@ -372,7 +377,6 @@ library
, Hasura.GraphQL.Validate.InputValue , Hasura.GraphQL.Validate.InputValue
, Hasura.GraphQL.Explain , Hasura.GraphQL.Explain
, Hasura.GraphQL.Execute.Plan , Hasura.GraphQL.Execute.Plan
, Hasura.GraphQL.Execute.Query
, Hasura.GraphQL.Execute.LiveQuery.Options , Hasura.GraphQL.Execute.LiveQuery.Options
, Hasura.GraphQL.Execute.LiveQuery.Plan , Hasura.GraphQL.Execute.LiveQuery.Plan
, Hasura.GraphQL.Execute.LiveQuery.Poll , Hasura.GraphQL.Execute.LiveQuery.Poll
@ -390,13 +394,11 @@ library
, Hasura.GraphQL.Resolve.Select , Hasura.GraphQL.Resolve.Select
, Hasura.GraphQL.RemoteServer , Hasura.GraphQL.RemoteServer
, Hasura.GraphQL.Context , Hasura.GraphQL.Context
, Hasura.GraphQL.Logging
, Hasura.Eventing.HTTP , Hasura.Eventing.HTTP
, Hasura.Eventing.EventTrigger , Hasura.Eventing.EventTrigger
, Hasura.Eventing.ScheduledTrigger , Hasura.Eventing.ScheduledTrigger
, Control.Concurrent.Extended
, Control.Lens.Extended , Control.Lens.Extended
, Data.Aeson.Extended , Data.Aeson.Extended
, Data.List.Extended , Data.List.Extended
@ -415,7 +417,6 @@ library
, Hasura.SQL.Value , Hasura.SQL.Value
, Network.URI.Extended , Network.URI.Extended
, Network.Wai.Extended
, Network.Wai.Handler.WebSockets.Custom , Network.Wai.Handler.WebSockets.Custom
executable graphql-engine executable graphql-engine

143
server/src-lib/Hasura/App.hs
View File

@ -2,63 +2,71 @@
module Hasura.App where module Hasura.App where
import Control.Concurrent.STM.TVar (readTVarIO) import Control.Concurrent.STM.TVar (readTVarIO)
import Control.Lens (view, _2)
import Control.Monad.Base import Control.Monad.Base
import Control.Monad.Catch (MonadCatch, MonadThrow, onException) import Control.Monad.Catch (MonadCatch, MonadThrow, onException)
import Control.Monad.Stateless import Control.Monad.Stateless
import Control.Monad.STM (atomically) import Control.Monad.STM (atomically)
import Control.Monad.Trans.Control (MonadBaseControl (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))
import Data.Aeson ((.=)) import Data.Aeson ((.=))
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import GHC.AssertNF import GHC.AssertNF
import Options.Applicative import Options.Applicative
import System.Environment (getEnvironment, lookupEnv) import System.Environment (getEnvironment, lookupEnv)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import qualified Control.Concurrent.Async as Async import qualified Control.Concurrent.Async as Async
import qualified Control.Concurrent.Async.Lifted.Safe as LA import qualified Control.Concurrent.Async.Lifted.Safe as LA
import qualified Control.Concurrent.Extended as C import qualified Control.Concurrent.Extended as C
import qualified Data.Aeson as A import qualified Data.Aeson as A
import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy.Char8 as BLC import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Time.Clock as Clock import qualified Data.Time.Clock as Clock
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP import qualified Network.HTTP.Client.TLS as HTTP
import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp as Warp
import qualified System.Log.FastLogger as FL import qualified System.Log.FastLogger as FL
import qualified Text.Mustache.Compile as M import qualified Text.Mustache.Compile as M
import Hasura.Db import Hasura.Db
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.Eventing.EventTrigger import Hasura.Eventing.EventTrigger
import Hasura.Eventing.ScheduledTrigger import Hasura.Eventing.ScheduledTrigger
import Hasura.GraphQL.Execute (MonadGQLExecutionCheck (..), import Hasura.GraphQL.Execute (MonadGQLExecutionCheck (..),
checkQueryInAllowlist) checkQueryInAllowlist)
import Hasura.GraphQL.Resolve.Action (asyncActionsProcessor) import Hasura.GraphQL.Logging (MonadQueryLog (..), QueryLog (..))
import Hasura.GraphQL.Transport.HTTP.Protocol (toParsed) import Hasura.GraphQL.Resolve.Action (asyncActionsProcessor)
import Hasura.GraphQL.Transport.HTTP.Protocol (toParsed)
import Hasura.Logging import Hasura.Logging
import Hasura.Prelude import Hasura.Prelude
import Hasura.RQL.Types (CacheRWM, Code (..), HasHttpManager, import Hasura.RQL.DDL.Schema.Cache
HasSQLGenCtx, HasSystemDefined, QErr (..), import Hasura.RQL.Types (CacheRWM, Code (..), HasHttpManager,
SQLGenCtx (..), SchemaCache (..), HasSQLGenCtx, HasSystemDefined,
UserInfoM, buildSchemaCacheStrict, QErr (..), SQLGenCtx (..),
decodeValue, throw400, withPathK) SchemaCache (..), UserInfoM,
buildSchemaCacheStrict, decodeValue,
throw400, withPathK)
import Hasura.RQL.Types.Run import Hasura.RQL.Types.Run
import Hasura.Server.API.Query (requiresAdmin, runQueryM) import Hasura.Server.API.Query (fetchLastUpdate, requiresAdmin,
runQueryM)
import Hasura.Server.App import Hasura.Server.App
import Hasura.Server.Auth import Hasura.Server.Auth
import Hasura.Server.CheckUpdates (checkForUpdates) import Hasura.Server.CheckUpdates (checkForUpdates)
import Hasura.Server.Init import Hasura.Server.Init
import Hasura.Server.Logging import Hasura.Server.Logging
import Hasura.Server.Migrate (migrateCatalog)
import Hasura.Server.SchemaUpdate import Hasura.Server.SchemaUpdate
import Hasura.Server.Telemetry import Hasura.Server.Telemetry
import Hasura.Server.Version import Hasura.Server.Version
import Hasura.Session import Hasura.Session
import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS
printErrExit :: (MonadIO m) => forall a . String -> m a printErrExit :: (MonadIO m) => forall a . String -> m a
printErrExit = liftIO . (>> exitFailure) . putStrLn printErrExit = liftIO . (>> exitFailure) . putStrLn
@ -118,6 +126,7 @@ data InitCtx
, _icConnInfo :: !Q.ConnInfo , _icConnInfo :: !Q.ConnInfo
, _icPgPool :: !Q.PGPool , _icPgPool :: !Q.PGPool
, _icShutdownLatch :: !ShutdownLatch , _icShutdownLatch :: !ShutdownLatch
, _icSchemaCache :: !(RebuildableSchemaCache Run, Maybe UTCTime)
} }
-- | Collection of the LoggerCtx, the regular Logger and the PGLogger -- | Collection of the LoggerCtx, the regular Logger and the PGLogger
@ -138,7 +147,7 @@ newtype AppM a = AppM { unAppM :: IO a }
-- this exists as a separate function because the context (logger, http manager, pg pool) can be -- this exists as a separate function because the context (logger, http manager, pg pool) can be
-- used by other functions as well -- used by other functions as well
initialiseCtx initialiseCtx
:: MonadIO m :: (HasVersion, MonadIO m, MonadCatch m)
=> HGECommand Hasura => HGECommand Hasura
-> RawConnInfo -> RawConnInfo
-> m (InitCtx, UTCTime) -> m (InitCtx, UTCTime)
@ -149,8 +158,8 @@ initialiseCtx hgeCmd rci = do
instanceId <- liftIO generateInstanceId instanceId <- liftIO generateInstanceId
connInfo <- liftIO procConnInfo connInfo <- liftIO procConnInfo
latch <- liftIO newShutdownLatch latch <- liftIO newShutdownLatch
(loggers, pool) <- case hgeCmd of (loggers, pool, sqlGenCtx) <- case hgeCmd of
-- for server command generate a proper pool -- for the @serve@ command generate a regular PG pool
HCServe so@ServeOptions{..} -> do HCServe so@ServeOptions{..} -> do
l@(Loggers _ logger pgLogger) <- mkLoggers soEnabledLogTypes soLogLevel l@(Loggers _ logger pgLogger) <- mkLoggers soEnabledLogTypes soLogLevel
-- log serve options -- log serve options
@ -158,15 +167,17 @@ initialiseCtx hgeCmd rci = do
-- log postgres connection info -- log postgres connection info
unLogger logger $ connInfoToLog connInfo unLogger logger $ connInfoToLog connInfo
pool <- liftIO $ Q.initPGPool connInfo soConnParams pgLogger pool <- liftIO $ Q.initPGPool connInfo soConnParams pgLogger
pure (l, pool) pure (l, pool, SQLGenCtx soStringifyNum)
-- for other commands generate a minimal pool -- for other commands generate a minimal PG pool
_ -> do _ -> do
l@(Loggers _ _ pgLogger) <- mkLoggers defaultEnabledLogTypes LevelInfo l@(Loggers _ _ pgLogger) <- mkLoggers defaultEnabledLogTypes LevelInfo
pool <- getMinimalPool pgLogger connInfo pool <- getMinimalPool pgLogger connInfo
pure (l, pool) pure (l, pool, SQLGenCtx False)
pure (InitCtx httpManager instanceId loggers connInfo pool latch, initTime) res <- flip onException (flushLogger (_lsLoggerCtx loggers)) $
migrateCatalogSchema (_lsLogger loggers) pool httpManager sqlGenCtx
pure (InitCtx httpManager instanceId loggers connInfo pool latch res, initTime)
where where
procConnInfo = procConnInfo =
either (printErrExit . ("Fatal Error : " <>)) return $ mkConnInfo rci either (printErrExit . ("Fatal Error : " <>)) return $ mkConnInfo rci
@ -181,6 +192,29 @@ initialiseCtx hgeCmd rci = do
pgLogger = mkPGLogger logger pgLogger = mkPGLogger logger
return $ Loggers loggerCtx logger pgLogger return $ Loggers loggerCtx logger pgLogger
-- | helper function to initialize or migrate the @hdb_catalog@ schema (used by pro as well)
migrateCatalogSchema
:: (HasVersion, MonadIO m)
=> Logger Hasura -> Q.PGPool -> HTTP.Manager -> SQLGenCtx
-> m (RebuildableSchemaCache Run, Maybe UTCTime)
migrateCatalogSchema logger pool httpManager sqlGenCtx = do
let pgExecCtx = mkPGExecCtx Q.Serializable pool
adminRunCtx = RunCtx adminUserInfo httpManager sqlGenCtx
currentTime <- liftIO Clock.getCurrentTime
initialiseResult <- runExceptT $ peelRun adminRunCtx pgExecCtx Q.ReadWrite $
(,) <$> migrateCatalog currentTime <*> liftTx fetchLastUpdate
((migrationResult, schemaCache), lastUpdateEvent) <-
initialiseResult `onLeft` \err -> do
unLogger logger StartupLog
{ slLogLevel = LevelError
, slKind = "db_migrate"
, slInfo = A.toJSON err
}
liftIO exitFailure
unLogger logger migrationResult
return (schemaCache, view _2 <$> lastUpdateEvent)
-- | Run a transaction and if an error is encountered, log the error and abort the program -- | Run a transaction and if an error is encountered, log the error and abort the program
runTxIO :: Q.PGPool -> Q.TxMode -> Q.TxE QErr a -> IO a runTxIO :: Q.PGPool -> Q.TxMode -> Q.TxE QErr a -> IO a
runTxIO pool isoLevel tx = do runTxIO pool isoLevel tx = do
@ -202,6 +236,13 @@ waitForShutdown = C.takeMVar . unShutdownLatch
shutdownGracefully :: InitCtx -> IO () shutdownGracefully :: InitCtx -> IO ()
shutdownGracefully = flip C.putMVar () . unShutdownLatch . _icShutdownLatch shutdownGracefully = flip C.putMVar () . unShutdownLatch . _icShutdownLatch
-- | If an exception is encountered , flush the log buffer and
-- rethrow If we do not flush the log buffer on exception, then log lines
-- may be missed
-- See: https://github.com/hasura/graphql-engine/issues/4772
flushLogger :: (MonadIO m) => LoggerCtx impl -> m ()
flushLogger loggerCtx = liftIO $ FL.flushLogStr $ _lcLoggerSet loggerCtx
runHGEServer runHGEServer
:: ( HasVersion :: ( HasVersion
, MonadIO m , MonadIO m
@ -211,9 +252,11 @@ runHGEServer
, UserAuthentication m , UserAuthentication m
, MetadataApiAuthorization m , MetadataApiAuthorization m
, HttpLog m , HttpLog m
, MonadQueryLog m
, ConsoleRenderer m , ConsoleRenderer m
, MonadGQLExecutionCheck m , MonadGQLExecutionCheck m
, MonadConfigApiHandler m , MonadConfigApiHandler m
, WS.MonadWSLog m
) )
=> ServeOptions impl => ServeOptions impl
-> InitCtx -> InitCtx
@ -240,12 +283,7 @@ runHGEServer ServeOptions{..} InitCtx{..} pgExecCtx initTime = do
authMode <- either (printErrExit . T.unpack) return authModeRes authMode <- either (printErrExit . T.unpack) return authModeRes
-- If an exception is encountered in 'mkWaiApp', flush the log buffer and HasuraApp app cacheRef cacheInitTime shutdownApp <- flip onException (flushLogger loggerCtx) $
-- rethrow If we do not flush the log buffer on exception, then log lines
-- written in 'mkWaiApp' may be missed
-- See: https://github.com/hasura/graphql-engine/issues/4772
let flushLogger = liftIO $ FL.flushLogStr $ _lcLoggerSet loggerCtx
HasuraApp app cacheRef cacheInitTime shutdownApp <- flip onException flushLogger $
mkWaiApp soTxIso mkWaiApp soTxIso
logger logger
sqlGenCtx sqlGenCtx
@ -264,6 +302,7 @@ runHGEServer ServeOptions{..} InitCtx{..} pgExecCtx initTime = do
soLiveQueryOpts soLiveQueryOpts
soPlanCacheOptions soPlanCacheOptions
soResponseInternalErrorsConfig soResponseInternalErrorsConfig
_icSchemaCache
-- log inconsistent schema objects -- log inconsistent schema objects
inconsObjs <- scInconsistentObjs <$> liftIO (getSCFromRef cacheRef) inconsObjs <- scInconsistentObjs <$> liftIO (getSCFromRef cacheRef)
@ -451,6 +490,14 @@ instance MonadConfigApiHandler AppM where
runConfigApiHandler = configApiGetHandler runConfigApiHandler = configApiGetHandler
instance MonadQueryLog AppM where
logQueryLog logger query genSqlM reqId =
unLogger logger $ QueryLog query genSqlM reqId
instance WS.MonadWSLog AppM where
logWSLog = unLogger
--- helper functions --- --- helper functions ---
mkConsoleHTML :: HasVersion => Text -> AuthMode -> Bool -> Maybe Text -> Either String Text mkConsoleHTML :: HasVersion => Text -> AuthMode -> Bool -> Maybe Text -> Either String Text

4
server/src-lib/Hasura/GraphQL/Execute.hs
View File

@ -390,6 +390,7 @@ execRemoteGQ
, MonadIO m , MonadIO m
, MonadError QErr m , MonadError QErr m
, MonadReader ExecutionCtx m , MonadReader ExecutionCtx m
, MonadQueryLog m
) )
=> RequestId => RequestId
-> UserInfo -> UserInfo
@ -403,7 +404,8 @@ execRemoteGQ reqId userInfo reqHdrs q rsi opType = do
execCtx <- ask execCtx <- ask
let logger = _ecxLogger execCtx let logger = _ecxLogger execCtx
manager = _ecxHttpManager execCtx manager = _ecxHttpManager execCtx
L.unLogger logger $ QueryLog q Nothing reqId -- L.unLogger logger $ QueryLog q Nothing reqId
logQueryLog logger q Nothing reqId
(time, respHdrs, resp) <- execRemoteGQ' manager userInfo reqHdrs q rsi opType (time, respHdrs, resp) <- execRemoteGQ' manager userInfo reqHdrs q rsi opType
let !httpResp = HttpResponse (encJFromLBS resp) respHdrs let !httpResp = HttpResponse (encJFromLBS resp) respHdrs
return (time, httpResp) return (time, httpResp)

18
server/src-lib/Hasura/GraphQL/Logging.hs
View File

@ -5,6 +5,7 @@ layer. In contrast with, logging at the HTTP server layer.
module Hasura.GraphQL.Logging module Hasura.GraphQL.Logging
( QueryLog(..) ( QueryLog(..)
, MonadQueryLog (..)
) where ) where
import qualified Data.Aeson as J import qualified Data.Aeson as J
@ -45,3 +46,20 @@ encodeSql sql =
where where
alName = G.unName . G.unAlias alName = G.unName . G.unAlias
jValFromAssocList xs = J.object $ map (uncurry (J..=)) xs jValFromAssocList xs = J.object $ map (uncurry (J..=)) xs
class Monad m => MonadQueryLog m where
logQueryLog
:: L.Logger L.Hasura
-- ^ logger
-> GQLReqUnparsed
-- ^ GraphQL request
-> (Maybe EQ.GeneratedSqlMap)
-- ^ Generated SQL if any
-> RequestId
-> m ()
instance MonadQueryLog m => MonadQueryLog (ExceptT e m) where
logQueryLog l req sqlMap reqId = lift $ logQueryLog l req sqlMap reqId
instance MonadQueryLog m => MonadQueryLog (ReaderT r m) where
logQueryLog l req sqlMap reqId = lift $ logQueryLog l req sqlMap reqId

23
server/src-lib/Hasura/GraphQL/Transport/HTTP.hs
View File

@ -1,4 +1,5 @@
-- | Execution of GraphQL queries over HTTP transport -- | Execution of GraphQL queries over HTTP transport
{-# LANGUAGE RecordWildCards #-}
module Hasura.GraphQL.Transport.HTTP module Hasura.GraphQL.Transport.HTTP
( runGQ ( runGQ
, runGQBatched , runGQBatched
@ -12,7 +13,7 @@ module Hasura.GraphQL.Transport.HTTP
) where ) where
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Logging import Hasura.GraphQL.Logging (MonadQueryLog (..))
import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.HTTP import Hasura.HTTP
import Hasura.Prelude import Hasura.Prelude
@ -24,7 +25,6 @@ import Hasura.Session
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Hasura.GraphQL.Execute as E import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.Logging as L
import qualified Hasura.Server.Telemetry.Counters as Telem import qualified Hasura.Server.Telemetry.Counters as Telem
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
@ -38,6 +38,7 @@ runGQ
, MonadError QErr m , MonadError QErr m
, MonadReader E.ExecutionCtx m , MonadReader E.ExecutionCtx m
, E.MonadGQLExecutionCheck m , E.MonadGQLExecutionCheck m
, MonadQueryLog m
) )
=> RequestId => RequestId
-> UserInfo -> UserInfo
@ -82,6 +83,7 @@ runGQBatched
, MonadError QErr m , MonadError QErr m
, MonadReader E.ExecutionCtx m , MonadReader E.ExecutionCtx m
, E.MonadGQLExecutionCheck m , E.MonadGQLExecutionCheck m
, MonadQueryLog m
) )
=> RequestId => RequestId
-> ResponseInternalErrorsConfig -> ResponseInternalErrorsConfig
@ -115,6 +117,7 @@ runHasuraGQ
:: ( MonadIO m :: ( MonadIO m
, MonadError QErr m , MonadError QErr m
, MonadReader E.ExecutionCtx m , MonadReader E.ExecutionCtx m
, MonadQueryLog m
) )
=> RequestId => RequestId
-> GQLReqUnparsed -> GQLReqUnparsed
@ -125,21 +128,29 @@ runHasuraGQ
-- spent in the PG query; for telemetry. -- spent in the PG query; for telemetry.
runHasuraGQ reqId query userInfo resolvedOp = do runHasuraGQ reqId query userInfo resolvedOp = do
(E.ExecutionCtx logger _ pgExecCtx _ _ _ _ _) <- ask (E.ExecutionCtx logger _ pgExecCtx _ _ _ _ _) <- ask
logQuery' logger
(telemTimeIO, respE) <- withElapsedTime $ liftIO $ runExceptT $ case resolvedOp of (telemTimeIO, respE) <- withElapsedTime $ liftIO $ runExceptT $ case resolvedOp of
E.ExOpQuery tx genSql -> do E.ExOpQuery tx _genSql -> do
-- log the generated SQL and the graphql query -- log the generated SQL and the graphql query
L.unLogger logger $ QueryLog query genSql reqId -- L.unLogger logger $ QueryLog query genSql reqId
([],) <$> runQueryTx pgExecCtx tx ([],) <$> runQueryTx pgExecCtx tx
E.ExOpMutation respHeaders tx -> do E.ExOpMutation respHeaders tx -> do
-- log the graphql query
L.unLogger logger $ QueryLog query Nothing reqId
(respHeaders,) <$> runLazyTx pgExecCtx Q.ReadWrite (withUserInfo userInfo tx) (respHeaders,) <$> runLazyTx pgExecCtx Q.ReadWrite (withUserInfo userInfo tx)
E.ExOpSubs _ -> E.ExOpSubs _ ->
throw400 UnexpectedPayload throw400 UnexpectedPayload
"subscriptions are not supported over HTTP, use websockets instead" "subscriptions are not supported over HTTP, use websockets instead"
(respHdrs, resp) <- liftEither respE (respHdrs, resp) <- liftEither respE
let !json = encodeGQResp $ GQSuccess $ encJToLBS resp let !json = encodeGQResp $ GQSuccess $ encJToLBS resp
telemQueryType = case resolvedOp of E.ExOpMutation{} -> Telem.Mutation ; _ -> Telem.Query telemQueryType = case resolvedOp of E.ExOpMutation{} -> Telem.Mutation ; _ -> Telem.Query
return (telemTimeIO, telemQueryType, respHdrs, json) return (telemTimeIO, telemQueryType, respHdrs, json)
where
logQuery' logger = case resolvedOp of
-- log the generated SQL and the graphql query
E.ExOpQuery _ genSql -> logQueryLog logger query genSql reqId
-- log the graphql query
E.ExOpMutation _ _ -> logQueryLog logger query Nothing reqId
E.ExOpSubs _ -> return ()

31
server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs
View File

@ -27,21 +27,20 @@ import qualified Data.Text.Encoding as TE
import qualified Data.Time.Clock as TC import qualified Data.Time.Clock as TC
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Language.GraphQL.Draft.Syntax as G import qualified Language.GraphQL.Draft.Syntax as G
import qualified ListT
import qualified Network.HTTP.Client as H import qualified Network.HTTP.Client as H
import qualified Network.HTTP.Types as H import qualified Network.HTTP.Types as H
import qualified Network.WebSockets as WS
import qualified Network.Wai.Extended as Wai import qualified Network.Wai.Extended as Wai
import qualified Network.WebSockets as WS
import qualified StmContainers.Map as STMMap import qualified StmContainers.Map as STMMap
import Control.Concurrent.Extended (sleep) import Control.Concurrent.Extended (sleep)
import Control.Exception.Lifted import Control.Exception.Lifted
import Data.String import Data.String
import GHC.AssertNF import GHC.AssertNF
import qualified ListT
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Logging import Hasura.GraphQL.Logging (MonadQueryLog (..))
import Hasura.GraphQL.Transport.HTTP.Protocol import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.GraphQL.Transport.WebSocket.Protocol import Hasura.GraphQL.Transport.WebSocket.Protocol
import Hasura.HTTP import Hasura.HTTP
@ -122,8 +121,13 @@ sendMsgWithMetadata wsConn msg (LQ.LiveQueryMetadata execTime) =
liftIO $ WS.sendMsg wsConn $ WS.WSQueueResponse bs wsInfo liftIO $ WS.sendMsg wsConn $ WS.WSQueueResponse bs wsInfo
where where
bs = encodeServerMsg msg bs = encodeServerMsg msg
(msgType, operationId) = case msg of
(SMData (DataMsg opId _)) -> (Just SMT_GQL_DATA, Just opId)
_ -> (Nothing, Nothing)
wsInfo = Just $! WS.WSEventInfo wsInfo = Just $! WS.WSEventInfo
{ WS._wseiQueryExecutionTime = Just $! realToFrac execTime { WS._wseiEventType = msgType
, WS._wseiOperationId = operationId
, WS._wseiQueryExecutionTime = Just $! realToFrac execTime
, WS._wseiResponseSize = Just $! BL.length bs , WS._wseiResponseSize = Just $! BL.length bs
} }
@ -297,7 +301,7 @@ onConn (L.Logger logger) corsPolicy wsId requestHead ipAdress = do
<> "HASURA_GRAPHQL_WS_READ_COOKIE to force read cookie when CORS is disabled." <> "HASURA_GRAPHQL_WS_READ_COOKIE to force read cookie when CORS is disabled."
onStart onStart
:: forall m. (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m) :: forall m. (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m, MonadQueryLog m)
=> WSServerEnv -> WSConn -> StartMsg -> m () => WSServerEnv -> WSConn -> StartMsg -> m ()
onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
timerTot <- startTimer timerTot <- startTimer
@ -327,8 +331,7 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
planCache userInfo sqlGenCtx sc scVer queryType httpMgr reqHdrs (q, reqParsed) planCache userInfo sqlGenCtx sc scVer queryType httpMgr reqHdrs (q, reqParsed)
(telemCacheHit, execPlan) <- either (withComplete . preExecErr requestId) return execPlanE (telemCacheHit, execPlan) <- either (withComplete . preExecErr requestId) return execPlanE
let execCtx = E.ExecutionCtx logger sqlGenCtx pgExecCtx let execCtx = E.ExecutionCtx logger sqlGenCtx pgExecCtx planCache sc scVer httpMgr enableAL
planCache sc scVer httpMgr enableAL
case execPlan of case execPlan of
E.GExPHasura resolvedOp -> E.GExPHasura resolvedOp ->
@ -349,7 +352,8 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
runLazyTx pgExecCtx Q.ReadWrite $ withUserInfo userInfo opTx runLazyTx pgExecCtx Q.ReadWrite $ withUserInfo userInfo opTx
E.ExOpSubs lqOp -> do E.ExOpSubs lqOp -> do
-- log the graphql query -- log the graphql query
L.unLogger logger $ QueryLog query Nothing reqId -- L.unLogger logger $ QueryLog query Nothing reqId
logQueryLog logger query Nothing reqId
let subscriberMetadata = LQ.mkSubscriberMetadata $ J.object let subscriberMetadata = LQ.mkSubscriberMetadata $ J.object
[ "websocket_id" J..= WS.getWSId wsConn [ "websocket_id" J..= WS.getWSId wsConn
, "operation_id" J..= opId , "operation_id" J..= opId
@ -370,8 +374,8 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
execQueryOrMut telemQueryType genSql action = do execQueryOrMut telemQueryType genSql action = do
logOpEv ODStarted (Just reqId) logOpEv ODStarted (Just reqId)
-- log the generated SQL and the graphql query -- log the generated SQL and the graphql query
L.unLogger logger $ QueryLog query genSql reqId logQueryLog logger query genSql reqId
(withElapsedTime $ liftIO $ runExceptT action) >>= \case (withElapsedTime $ runExceptT action) >>= \case
(_, Left err) -> postExecErr reqId err (_, Left err) -> postExecErr reqId err
(telemTimeIO_DT, Right encJson) -> do (telemTimeIO_DT, Right encJson) -> do
-- Telemetry. NOTE: don't time network IO: -- Telemetry. NOTE: don't time network IO:
@ -459,6 +463,7 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
ERTGraphqlCompliant -> J.object ["errors" J..= [errFn False qErr]] ERTGraphqlCompliant -> J.object ["errors" J..= [errFn False qErr]]
sendMsg wsConn (SMErr $ ErrorMsg opId err) sendMsg wsConn (SMErr $ ErrorMsg opId err)
-- sendSuccResp :: _
sendSuccResp encJson = sendSuccResp encJson =
sendMsgWithMetadata wsConn sendMsgWithMetadata wsConn
(SMData $ DataMsg opId $ GRHasura $ GQSuccess $ encJToLBS encJson) (SMData $ DataMsg opId $ GRHasura $ GQSuccess $ encJToLBS encJson)
@ -483,7 +488,7 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
catchAndIgnore m = void $ runExceptT m catchAndIgnore m = void $ runExceptT m
onMessage onMessage
:: (HasVersion, MonadIO m, UserAuthentication m, E.MonadGQLExecutionCheck m) :: (HasVersion, MonadIO m, UserAuthentication m, E.MonadGQLExecutionCheck m, MonadQueryLog m)
=> AuthMode => AuthMode
-> WSServerEnv -> WSServerEnv
-> WSConn -> BL.ByteString -> m () -> WSConn -> BL.ByteString -> m ()
@ -660,7 +665,9 @@ createWSServerApp
, MC.MonadBaseControl IO m , MC.MonadBaseControl IO m
, LA.Forall (LA.Pure m) , LA.Forall (LA.Pure m)
, UserAuthentication m , UserAuthentication m
, WS.MonadWSLog m
, E.MonadGQLExecutionCheck m , E.MonadGQLExecutionCheck m
, MonadQueryLog m
) )
=> AuthMode => AuthMode
-> WSServerEnv -> WSServerEnv

1
server/src-lib/Hasura/GraphQL/Transport/WebSocket/Protocol.hs
View File

@ -6,6 +6,7 @@ module Hasura.GraphQL.Transport.WebSocket.Protocol
, StopMsg(..) , StopMsg(..)
, ClientMsg(..) , ClientMsg(..)
, ServerMsg(..) , ServerMsg(..)
, ServerMsgType(..)
, encodeServerMsg , encodeServerMsg
, DataMsg(..) , DataMsg(..)
, ErrorMsg(..) , ErrorMsg(..)

75
server/src-lib/Hasura/GraphQL/Transport/WebSocket/Server.hs
View File

@ -19,38 +19,43 @@ module Hasura.GraphQL.Transport.WebSocket.Server
, WSServer , WSServer
, WSEventInfo(..) , WSEventInfo(..)
, WSQueueResponse(..) , WSQueueResponse(..)
, ServerMsgType(..)
, createWSServer , createWSServer
, closeAll , closeAll
, createServerApp , createServerApp
, shutdown , shutdown
, MonadWSLog (..)
, HasuraServerApp , HasuraServerApp
, WSEvent(..)
, WSLog(..)
) where ) where
import qualified Control.Concurrent.Async as A import qualified Control.Concurrent.Async as A
import qualified Control.Concurrent.Async.Lifted.Safe as LA import qualified Control.Concurrent.Async.Lifted.Safe as LA
import qualified Control.Concurrent.STM as STM import qualified Control.Concurrent.STM as STM
import Control.Exception.Lifted import Control.Exception.Lifted
import qualified Control.Monad.Trans.Control as MC import qualified Control.Monad.Trans.Control as MC
import qualified Data.Aeson as J import qualified Data.Aeson as J
import qualified Data.Aeson.Casing as J import qualified Data.Aeson.Casing as J
import qualified Data.Aeson.TH as J import qualified Data.Aeson.TH as J
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import Data.String import Data.String
import qualified Data.TByteString as TBS import qualified Data.TByteString as TBS
import qualified Data.UUID as UUID import qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID import qualified Data.UUID.V4 as UUID
import Data.Word (Word16) import Data.Word (Word16)
import GHC.AssertNF import GHC.AssertNF
import GHC.Int (Int64) import GHC.Int (Int64)
import Hasura.Prelude import Hasura.Prelude
import Network.Wai.Extended (IpAddress)
import qualified ListT import qualified ListT
import qualified Network.WebSockets as WS import Network.Wai.Extended (IpAddress)
import qualified StmContainers.Map as STMMap import qualified Network.WebSockets as WS
import qualified System.IO.Error as E import qualified StmContainers.Map as STMMap
import qualified System.IO.Error as E
import qualified Hasura.Logging as L import Hasura.GraphQL.Transport.WebSocket.Protocol (OperationId, ServerMsgType (..))
import qualified Hasura.Logging as L
newtype WSId newtype WSId
= WSId { unWSId :: UUID.UUID } = WSId { unWSId :: UUID.UUID }
@ -80,7 +85,9 @@ $(J.deriveToJSON
-- extra websocket event info -- extra websocket event info
data WSEventInfo data WSEventInfo
= WSEventInfo = WSEventInfo
{ _wseiQueryExecutionTime :: !(Maybe Double) { _wseiEventType :: !(Maybe ServerMsgType)
, _wseiOperationId :: !(Maybe OperationId)
, _wseiQueryExecutionTime :: !(Maybe Double)
, _wseiResponseSize :: !(Maybe Int64) , _wseiResponseSize :: !(Maybe Int64)
} deriving (Show, Eq) } deriving (Show, Eq)
$(J.deriveToJSON $(J.deriveToJSON
@ -89,7 +96,6 @@ $(J.deriveToJSON
} }
''WSEventInfo) ''WSEventInfo)
data WSLog data WSLog
= WSLog = WSLog
{ _wslWebsocketId :: !WSId { _wslWebsocketId :: !WSId
@ -106,6 +112,17 @@ instance L.ToEngineLog WSLog L.Hasura where
toEngineLog wsLog = toEngineLog wsLog =
(L.LevelDebug, L.ELTInternal L.ILTWsServer, J.toJSON wsLog) (L.LevelDebug, L.ELTInternal L.ILTWsServer, J.toJSON wsLog)
class Monad m => MonadWSLog m where
-- | Takes WS server log data and logs it
-- logWSServer
logWSLog :: L.Logger L.Hasura -> WSLog -> m ()
instance MonadWSLog m => MonadWSLog (ExceptT e m) where
logWSLog l ws = lift $ logWSLog l ws
instance MonadWSLog m => MonadWSLog (ReaderT r m) where
logWSLog l ws = lift $ logWSLog l ws
data WSQueueResponse data WSQueueResponse
= WSQueueResponse = WSQueueResponse
{ _wsqrMessage :: !BL.ByteString { _wsqrMessage :: !BL.ByteString
@ -219,7 +236,7 @@ data WSHandlers m a
type HasuraServerApp m = IpAddress -> WS.PendingConnection -> m () type HasuraServerApp m = IpAddress -> WS.PendingConnection -> m ()
createServerApp createServerApp
:: (MonadIO m, MC.MonadBaseControl IO m, LA.Forall (LA.Pure m)) :: (MonadIO m, MC.MonadBaseControl IO m, LA.Forall (LA.Pure m), MonadWSLog m)
=> WSServer a => WSServer a
-- user provided handlers -- user provided handlers
-> WSHandlers m a -> WSHandlers m a
@ -228,7 +245,7 @@ createServerApp
{-# INLINE createServerApp #-} {-# INLINE createServerApp #-}
createServerApp (WSServer logger@(L.Logger writeLog) serverStatus) wsHandlers !ipAddress !pendingConn = do createServerApp (WSServer logger@(L.Logger writeLog) serverStatus) wsHandlers !ipAddress !pendingConn = do
wsId <- WSId <$> liftIO UUID.nextRandom wsId <- WSId <$> liftIO UUID.nextRandom
writeLog $ WSLog wsId EConnectionRequest Nothing logWSLog logger $ WSLog wsId EConnectionRequest Nothing
status <- liftIO $ STM.readTVarIO serverStatus status <- liftIO $ STM.readTVarIO serverStatus
case status of case status of
AcceptingConns _ -> logUnexpectedExceptions $ do AcceptingConns _ -> logUnexpectedExceptions $ do
@ -255,11 +272,11 @@ createServerApp (WSServer logger@(L.Logger writeLog) serverStatus) wsHandlers !i
onReject wsId rejectRequest = do onReject wsId rejectRequest = do
liftIO $ WS.rejectRequestWith pendingConn rejectRequest liftIO $ WS.rejectRequestWith pendingConn rejectRequest
writeLog $ WSLog wsId ERejected Nothing logWSLog logger $ WSLog wsId ERejected Nothing
onAccept wsId (AcceptWith a acceptWithParams keepAlive onJwtExpiry) = do onAccept wsId (AcceptWith a acceptWithParams keepAlive onJwtExpiry) = do
conn <- liftIO $ WS.acceptRequestWith pendingConn acceptWithParams conn <- liftIO $ WS.acceptRequestWith pendingConn acceptWithParams
writeLog $ WSLog wsId EAccepted Nothing logWSLog logger $ WSLog wsId EAccepted Nothing
sendQ <- liftIO STM.newTQueueIO sendQ <- liftIO STM.newTQueueIO
let !wsConn = WSConn wsId logger conn sendQ a let !wsConn = WSConn wsId logger conn sendQ a
-- TODO there are many thunks here. Difficult to trace how much is retained, and -- TODO there are many thunks here. Difficult to trace how much is retained, and
@ -299,13 +316,13 @@ createServerApp (WSServer logger@(L.Logger writeLog) serverStatus) wsHandlers !i
-- Regardless this should be safe: -- Regardless this should be safe:
handleJust (guard . E.isResourceVanishedError) (\()-> throw WS.ConnectionClosed) $ handleJust (guard . E.isResourceVanishedError) (\()-> throw WS.ConnectionClosed) $
WS.receiveData conn WS.receiveData conn
writeLog $ WSLog wsId (EMessageReceived $ TBS.fromLBS msg) Nothing logWSLog logger $ WSLog wsId (EMessageReceived $ TBS.fromLBS msg) Nothing
_hOnMessage wsHandlers wsConn msg _hOnMessage wsHandlers wsConn msg
let send = forever $ do let send = forever $ do
WSQueueResponse msg wsInfo <- liftIO $ STM.atomically $ STM.readTQueue sendQ WSQueueResponse msg wsInfo <- liftIO $ STM.atomically $ STM.readTQueue sendQ
liftIO $ WS.sendTextData conn msg liftIO $ WS.sendTextData conn msg
writeLog $ WSLog wsId (EMessageSent $ TBS.fromLBS msg) wsInfo logWSLog logger $ WSLog wsId (EMessageSent $ TBS.fromLBS msg) wsInfo
-- withAsync lets us be very sure that if e.g. an async exception is raised while we're -- withAsync lets us be very sure that if e.g. an async exception is raised while we're
-- forking that the threads we launched will be cleaned up. See also below. -- forking that the threads we launched will be cleaned up. See also below.
@ -323,17 +340,17 @@ createServerApp (WSServer logger@(L.Logger writeLog) serverStatus) wsHandlers !i
-- exceptions; for now handle all ConnectionException by closing -- exceptions; for now handle all ConnectionException by closing
-- and cleaning up, see: https://github.com/jaspervdj/websockets/issues/48 -- and cleaning up, see: https://github.com/jaspervdj/websockets/issues/48
Left ( _ :: WS.ConnectionException) -> do Left ( _ :: WS.ConnectionException) -> do
writeLog $ WSLog (_wcConnId wsConn) ECloseReceived Nothing logWSLog logger $ WSLog (_wcConnId wsConn) ECloseReceived Nothing
-- this will happen when jwt is expired -- this will happen when jwt is expired
Right _ -> do Right _ -> do
writeLog $ WSLog (_wcConnId wsConn) EJwtExpired Nothing logWSLog logger $ WSLog (_wcConnId wsConn) EJwtExpired Nothing
onConnClose wsConn = \case onConnClose wsConn = \case
ShuttingDown -> pure () ShuttingDown -> pure ()
AcceptingConns connMap -> do AcceptingConns connMap -> do
liftIO $ STM.atomically $ STMMap.delete (_wcConnId wsConn) connMap liftIO $ STM.atomically $ STMMap.delete (_wcConnId wsConn) connMap
_hOnClose wsHandlers wsConn _hOnClose wsHandlers wsConn
writeLog $ WSLog (_wcConnId wsConn) EClosed Nothing logWSLog logger $ WSLog (_wcConnId wsConn) EClosed Nothing
shutdown :: WSServer a -> IO () shutdown :: WSServer a -> IO ()

6
server/src-lib/Hasura/Server/API/Config.hs
View File

@ -1,5 +1,9 @@
-- | API related to server configuration -- | API related to server configuration
module Hasura.Server.API.Config (runGetConfig) where module Hasura.Server.API.Config
-- required by pro
( ServerConfig(..)
, runGetConfig
) where
import Data.Aeson.Casing import Data.Aeson.Casing
import Data.Aeson.TH import Data.Aeson.TH

115
server/src-lib/Hasura/Server/App.hs
View File

@ -4,66 +4,66 @@
module Hasura.Server.App where module Hasura.Server.App where
import Control.Concurrent.MVar.Lifted import Control.Concurrent.MVar.Lifted
import Control.Exception (IOException, try) import Control.Exception (IOException, try)
import Control.Lens (view, _2)
import Control.Monad.Stateless import Control.Monad.Stateless
import Control.Monad.Trans.Control (MonadBaseControl) import Control.Monad.Trans.Control (MonadBaseControl)
import Data.Aeson hiding (json) import Data.Aeson hiding (json)
import Data.Int (Int64) import Data.Int (Int64)
import Data.IORef import Data.IORef
import Data.Time.Clock (UTCTime, getCurrentTime) import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (getPOSIXTime) import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.Mime (defaultMimeLookup) import Network.Mime (defaultMimeLookup)
import System.Exit (exitFailure) import System.Exit (exitFailure)
import System.FilePath (joinPath, takeFileName) import System.FilePath (joinPath, takeFileName)
import Web.Spock.Core ((<//>)) import Web.Spock.Core ((<//>))
import qualified Control.Concurrent.Async.Lifted.Safe as LA import qualified Control.Concurrent.Async.Lifted.Safe as LA
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import qualified Data.HashMap.Strict as M import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as S import qualified Data.HashSet as S
import qualified Data.Text as T import qualified Data.Text as T
import qualified Database.PG.Query as Q import qualified Database.PG.Query as Q
import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP import qualified Network.HTTP.Types as HTTP
import qualified Network.Wai.Extended as Wai import qualified Network.Wai.Extended as Wai
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import qualified System.Metrics as EKG import qualified System.Metrics as EKG
import qualified System.Metrics.Json as EKG import qualified System.Metrics.Json as EKG
import qualified Text.Mustache as M import qualified Text.Mustache as M
import qualified Web.Spock.Core as Spock import qualified Web.Spock.Core as Spock
import Hasura.Db import Hasura.Db
import Hasura.EncJSON import Hasura.EncJSON
import Hasura.GraphQL.Logging (MonadQueryLog (..))
import Hasura.GraphQL.Resolve.Action import Hasura.GraphQL.Resolve.Action
import Hasura.HTTP import Hasura.HTTP
import Hasura.Prelude hiding (get, put) import Hasura.Prelude hiding (get, put)
import Hasura.RQL.DDL.Schema import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.RQL.Types.Run import Hasura.RQL.Types.Run
import Hasura.Server.API.Config (runGetConfig) import Hasura.Server.API.Config (runGetConfig)
import Hasura.Server.API.Query import Hasura.Server.API.Query
import Hasura.Server.Auth (AuthMode (..), UserAuthentication (..)) import Hasura.Server.Auth (AuthMode (..), UserAuthentication (..))
import Hasura.Server.Compression import Hasura.Server.Compression
import Hasura.Server.Cors import Hasura.Server.Cors
import Hasura.Server.Init import Hasura.Server.Init
import Hasura.Server.Logging import Hasura.Server.Logging
import Hasura.Server.Middleware (corsMiddleware) import Hasura.Server.Middleware (corsMiddleware)
import Hasura.Server.Migrate (migrateCatalog)
import Hasura.Server.Utils import Hasura.Server.Utils
import Hasura.Server.Version import Hasura.Server.Version
import Hasura.Session import Hasura.Session
import Hasura.SQL.Types import Hasura.SQL.Types
import qualified Hasura.GraphQL.Execute as E import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.GraphQL.Execute.LiveQuery as EL import qualified Hasura.GraphQL.Execute.LiveQuery as EL
import qualified Hasura.GraphQL.Explain as GE import qualified Hasura.GraphQL.Explain as GE
import qualified Hasura.GraphQL.Transport.HTTP as GH import qualified Hasura.GraphQL.Transport.HTTP as GH
import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH import qualified Hasura.GraphQL.Transport.HTTP.Protocol as GH
import qualified Hasura.GraphQL.Transport.WebSocket as WS import qualified Hasura.GraphQL.Transport.WebSocket as WS
import qualified Hasura.Logging as L import qualified Hasura.GraphQL.Transport.WebSocket.Server as WS
import qualified Hasura.Server.API.PGDump as PGD import qualified Hasura.Logging as L
import qualified Hasura.Server.API.PGDump as PGD
import qualified Network.Wai.Handler.WebSockets.Custom as WSC import qualified Network.Wai.Handler.WebSockets.Custom as WSC
@ -329,7 +329,7 @@ v1QueryHandler query = do
runQuery pgExecCtx instanceId userInfo schemaCache httpMgr sqlGenCtx (SystemDefined False) query runQuery pgExecCtx instanceId userInfo schemaCache httpMgr sqlGenCtx (SystemDefined False) query
v1Alpha1GQHandler v1Alpha1GQHandler
:: (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m) :: (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m, MonadQueryLog m)
=> E.GraphQLQueryType -> GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON) => E.GraphQLQueryType -> GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON)
v1Alpha1GQHandler queryType query = do v1Alpha1GQHandler queryType query = do
userInfo <- asks hcUser userInfo <- asks hcUser
@ -351,13 +351,13 @@ v1Alpha1GQHandler queryType query = do
GH.runGQBatched requestId responseErrorsConfig userInfo ipAddress reqHeaders queryType query GH.runGQBatched requestId responseErrorsConfig userInfo ipAddress reqHeaders queryType query
v1GQHandler v1GQHandler
:: (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m) :: (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m, MonadQueryLog m)
=> GH.GQLBatchedReqs GH.GQLQueryText => GH.GQLBatchedReqs GH.GQLQueryText
-> Handler m (HttpResponse EncJSON) -> Handler m (HttpResponse EncJSON)
v1GQHandler = v1Alpha1GQHandler E.QueryHasura v1GQHandler = v1Alpha1GQHandler E.QueryHasura
v1GQRelayHandler v1GQRelayHandler
:: (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m) :: (HasVersion, MonadIO m, E.MonadGQLExecutionCheck m, MonadQueryLog m)
=> GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON) => GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON)
v1GQRelayHandler = v1Alpha1GQHandler E.QueryRelay v1GQRelayHandler = v1Alpha1GQHandler E.QueryRelay
@ -485,10 +485,12 @@ mkWaiApp
, LA.Forall (LA.Pure m) , LA.Forall (LA.Pure m)
, ConsoleRenderer m , ConsoleRenderer m
, HttpLog m , HttpLog m
, MonadQueryLog m
, UserAuthentication m , UserAuthentication m
, MetadataApiAuthorization m , MetadataApiAuthorization m
, E.MonadGQLExecutionCheck m , E.MonadGQLExecutionCheck m
, MonadConfigApiHandler m , MonadConfigApiHandler m
, WS.MonadWSLog m
) )
=> Q.TxIsolation => Q.TxIsolation
-> L.Logger L.Hasura -> L.Logger L.Hasura
@ -508,11 +510,12 @@ mkWaiApp
-> EL.LiveQueriesOptions -> EL.LiveQueriesOptions
-> E.PlanCacheOptions -> E.PlanCacheOptions
-> ResponseInternalErrorsConfig -> ResponseInternalErrorsConfig
-> (RebuildableSchemaCache Run, Maybe UTCTime)
-> m HasuraApp -> m HasuraApp
mkWaiApp isoLevel logger sqlGenCtx enableAL pool pgExecCtxCustom ci httpManager mode corsCfg enableConsole consoleAssetsDir mkWaiApp isoLevel logger sqlGenCtx enableAL pool pgExecCtxCustom ci httpManager mode corsCfg enableConsole consoleAssetsDir
enableTelemetry instanceId apis lqOpts planCacheOptions responseErrorsConfig = do enableTelemetry instanceId apis lqOpts planCacheOptions responseErrorsConfig (schemaCache, cacheBuiltTime) = do
(planCache, schemaCacheRef, cacheBuiltTime) <- migrateAndInitialiseSchemaCache (planCache, schemaCacheRef) <- initialiseCache
let getSchemaCache = first lastBuiltSchemaCache <$> readIORef (_scrCache schemaCacheRef) let getSchemaCache = first lastBuiltSchemaCache <$> readIORef (_scrCache schemaCacheRef)
let corsPolicy = mkDefaultCorsPolicy corsCfg let corsPolicy = mkDefaultCorsPolicy corsCfg
@ -560,30 +563,13 @@ mkWaiApp isoLevel logger sqlGenCtx enableAL pool pgExecCtxCustom ci httpManager
getTimeMs :: IO Int64 getTimeMs :: IO Int64
getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime getTimeMs = (round . (* 1000)) `fmap` getPOSIXTime
migrateAndInitialiseSchemaCache :: m (E.PlanCache, SchemaCacheRef, Maybe UTCTime) initialiseCache :: m (E.PlanCache, SchemaCacheRef)
migrateAndInitialiseSchemaCache = do initialiseCache = do
let pgExecCtx = mkPGExecCtx Q.Serializable pool
adminRunCtx = RunCtx adminUserInfo httpManager sqlGenCtx
currentTime <- liftIO getCurrentTime
initialiseResult <- runExceptT $ peelRun adminRunCtx pgExecCtx Q.ReadWrite do
(,) <$> migrateCatalog currentTime <*> liftTx fetchLastUpdate
((migrationResult, schemaCache), lastUpdateEvent) <-
initialiseResult `onLeft` \err -> do
L.unLogger logger StartupLog
{ slLogLevel = L.LevelError
, slKind = "db_migrate"
, slInfo = toJSON err
}
liftIO exitFailure
L.unLogger logger migrationResult
cacheLock <- liftIO $ newMVar () cacheLock <- liftIO $ newMVar ()
cacheCell <- liftIO $ newIORef (schemaCache, initSchemaCacheVer) cacheCell <- liftIO $ newIORef (schemaCache, initSchemaCacheVer)
planCache <- liftIO $ E.initPlanCache planCacheOptions planCache <- liftIO $ E.initPlanCache planCacheOptions
let cacheRef = SchemaCacheRef cacheLock cacheCell (E.clearPlanCache planCache) let cacheRef = SchemaCacheRef cacheLock cacheCell (E.clearPlanCache planCache)
pure (planCache, cacheRef)
pure (planCache, cacheRef, view _2 <$> lastUpdateEvent)
httpApp httpApp
:: ( HasVersion :: ( HasVersion
@ -595,6 +581,7 @@ httpApp
, MetadataApiAuthorization m , MetadataApiAuthorization m
, E.MonadGQLExecutionCheck m , E.MonadGQLExecutionCheck m
, MonadConfigApiHandler m , MonadConfigApiHandler m
, MonadQueryLog m
) )
=> CorsConfig => CorsConfig
-> ServerCtx -> ServerCtx

36
server/src-lib/Hasura/Server/Init.hs
View File

@ -1,40 +1,8 @@
-- | Types and functions related to the server initialisation -- | Types and functions related to the server initialisation
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -O0 #-} {-# OPTIONS_GHC -O0 #-}
module Hasura.Server.Init module Hasura.Server.Init
( DbUid(..) ( module Hasura.Server.Init
, getDbId
, PGVersion(..)
, getPgVersion
, InstanceId(..)
, generateInstanceId
, StartupTimeInfo(..)
-- * Server command related
, parseRawConnInfo
, mkRawConnInfo
, mkHGEOptions
, mkConnInfo
, serveOptionsParser
-- * Downgrade command related
, downgradeShortcuts
, downgradeOptionsParser
-- * Help footers
, mainCmdFooter
, serveCmdFooter
-- * Startup logs
, mkGenericStrLog
, mkGenericLog
, inconsistentMetadataLog
, serveOptsToLog
, connInfoToLog
, module Hasura.Server.Init.Config , module Hasura.Server.Init.Config
) where ) where

1
server/src-lib/Hasura/Server/Logging.hs
View File

@ -111,7 +111,6 @@ instance ToJSON WebHookLog where
, "message" .= whlMessage whl , "message" .= whlMessage whl
] ]
class (Monad m) => HttpLog m where class (Monad m) => HttpLog m where
logHttpError logHttpError
:: Logger Hasura :: Logger Hasura

7
server/src-lib/Hasura/Server/Migrate.hs
View File

@ -37,15 +37,14 @@ import qualified Language.Haskell.TH.Syntax as TH
import Control.Lens (view, _2) import Control.Lens (view, _2)
import Control.Monad.Unique import Control.Monad.Unique
import Data.Time.Clock (UTCTime) import Data.Time.Clock (UTCTime)
import Hasura.Logging (Hasura, LogLevel (..), ToEngineLog (..)) import Hasura.Logging (Hasura, LogLevel (..), ToEngineLog (..))
import Hasura.RQL.DDL.Relationship import Hasura.RQL.DDL.Relationship
import Hasura.RQL.DDL.Schema import Hasura.RQL.DDL.Schema
import Hasura.Server.Init (DowngradeOptions (..)) import Hasura.Server.Init (DowngradeOptions (..))
import Hasura.RQL.Types import Hasura.RQL.Types
import Hasura.Server.Logging (StartupLog (..)) import Hasura.Server.Logging (StartupLog (..))
import Hasura.Server.Version
import Hasura.Server.Migrate.Version (latestCatalogVersion, latestCatalogVersionString) import Hasura.Server.Migrate.Version (latestCatalogVersion, latestCatalogVersionString)
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types import Hasura.SQL.Types
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
@ -160,13 +159,13 @@ migrateCatalog migrationTime = do
where where
neededMigrations = dropWhile ((/= previousVersion) . fst) (migrations False) neededMigrations = dropWhile ((/= previousVersion) . fst) (migrations False)
updateCatalogVersion = setCatalogVersion latestCatalogVersionString migrationTime
buildCacheAndRecreateSystemMetadata :: m (RebuildableSchemaCache m) buildCacheAndRecreateSystemMetadata :: m (RebuildableSchemaCache m)
buildCacheAndRecreateSystemMetadata = do buildCacheAndRecreateSystemMetadata = do
schemaCache <- buildRebuildableSchemaCache schemaCache <- buildRebuildableSchemaCache
view _2 <$> runCacheRWT schemaCache recreateSystemMetadata view _2 <$> runCacheRWT schemaCache recreateSystemMetadata
updateCatalogVersion = setCatalogVersion latestCatalogVersionString migrationTime
doesSchemaExist schemaName = doesSchemaExist schemaName =
liftTx $ (runIdentity . Q.getRow) <$> Q.withQE defaultTxErrorHandler [Q.sql| liftTx $ (runIdentity . Q.getRow) <$> Q.withQE defaultTxErrorHandler [Q.sql|
SELECT EXISTS SELECT EXISTS

1
server/src-lib/Hasura/Session.hs
View File

@ -5,6 +5,7 @@ module Hasura.Session
, isAdmin , isAdmin
, roleNameToTxt , roleNameToTxt
, SessionVariable , SessionVariable
, SessionVariableValue
, mkSessionVariable , mkSessionVariable
, SessionVariables , SessionVariables
, sessionVariableToText , sessionVariableToText

28
server/src-lib/Network/Wai/Extended.hs
View File

@ -1,26 +1,26 @@
module Network.Wai.Extended module Network.Wai.Extended
( module Wai ( module Wai
, getSourceFromFallback , getSourceFromFallback
, IpAddress , IpAddress (..)
, showIPAddress , showIPAddress
) where ) where
import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Char8 as BS
import qualified Data.Text.Encoding as TE import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE import qualified Data.Text.Encoding.Error as TE
import Data.List (find)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Prelude import Prelude
import Data.Maybe (fromMaybe)
import Data.List (find)
import Data.Text (Text)
import Data.Bits (shift, (.&.)) import Data.Bits (shift, (.&.))
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import Data.Word (Word32) import Data.Word (Word32)
import Network.Socket (SockAddr (..)) import Network.Socket (SockAddr (..))
import Network.Wai as Wai import Network.Wai as Wai
import System.ByteOrder (ByteOrder (..), byteOrder) import System.ByteOrder (ByteOrder (..), byteOrder)
import Text.Printf (printf) import Text.Printf (printf)
-- | IP Address related code -- | IP Address related code