hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-14 17:02:49 +03:00
Code Issues Projects Releases Wiki Activity

server: Parameterize the graphql-engine library over the version (#3668)

Browse Source
This commit is contained in:
Alexis King 2020-01-22 15:55:55 -06:00 committed by GitHub
parent b344e7f39c
commit 5bd5a548fa
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
25 changed files with 244 additions and 167 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
server/cabal.project.freeze
View File

@ -307,6 +307,8 @@ constraints: any.Cabal ==2.4.0.1,
any.unliftio-core ==0.1.2.0,
any.unordered-containers ==0.2.9.0,
unordered-containers -debug,
any.uri-encode ==1.5.0.5,
uri-encode +network-uri -tools,
any.utf8-string ==1.0.1.1,
any.uuid ==1.3.13,
any.uuid-types ==1.0.3,

6
server/graphql-engine.cabal
View File

@ -122,6 +122,7 @@ library
-- URL parser related
, network-uri
, uri-encode
-- String related
, case-insensitive
@ -370,13 +371,14 @@ library
executable graphql-engine
import: common-all, common-exe
main-is: Main.hs
hs-source-dirs: src-exec
main-is: Main.hs
build-depends: base
, graphql-engine
, bytestring
, pg-client
, text
, bytestring
, text-conversions
test-suite graphql-engine-tests
import: common-all, common-exe

7
server/src-exec/Main.hs
View File

@ -2,6 +2,8 @@
module Main where
import Data.Text.Conversions (convertText)
import Hasura.App
import Hasura.Logging (Hasura)
import Hasura.Prelude
@ -14,7 +16,6 @@ import Hasura.Server.Version
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC
import qualified Data.Text as T
import qualified Database.PG.Query as Q
main :: IO ()
@ -22,7 +23,7 @@ main = parseArgs >>= unAppM . runApp
runApp :: HGEOptions Hasura -> AppM ()
runApp (HGEOptionsG rci hgeCmd) =
case hgeCmd of
withVersion $$(getVersionFromEnvironment) case hgeCmd of
HCServe serveOptions -> do
(initCtx, initTime) <- initialiseCtx hgeCmd rci
runHGEServer serveOptions initCtx initTime
@ -48,7 +49,7 @@ runApp (HGEOptionsG rci hgeCmd) =
& fmap fst
either printErrJExit (liftIO . BLC.putStrLn) res
HCVersion -> liftIO $ putStrLn $ "Hasura GraphQL Engine: " ++ T.unpack currentVersion
HCVersion -> liftIO $ putStrLn $ "Hasura GraphQL Engine: " ++ convertText currentVersion
where
runTx' initCtx tx =
liftIO $ runExceptT $ Q.runTx (_icPgPool initCtx) (Q.Serializable, Nothing) tx

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

@ -129,7 +129,7 @@ newtype AppM a = AppM { unAppM :: IO a }
-- this exists as a separate function because the context (logger, http manager, pg pool) can be
-- used by other functions as well
initialiseCtx
:: (MonadIO m)
:: (HasVersion, MonadIO m)
=> HGECommand Hasura
-> RawConnInfo
-> m (InitCtx, UTCTime)
@ -186,7 +186,8 @@ initialiseCtx hgeCmd rci = do
runHGEServer
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadStateless IO m
, UserAuthentication m
, MetadataApiAuthorization m
@ -313,7 +314,8 @@ runAsAdmin pool sqlGenCtx httpManager m = do
runExceptT $ peelRun runCtx pgCtx Q.ReadWrite m
execQuery
:: ( CacheRWM m
:: ( HasVersion
, CacheRWM m
, MonadTx m
, MonadIO m
, HasHttpManager m
@ -356,7 +358,7 @@ instance ConsoleRenderer AppM where
renderConsole path authMode enableTelemetry consoleAssetsDir =
return $ mkConsoleHTML path authMode enableTelemetry consoleAssetsDir
mkConsoleHTML :: Text -> AuthMode -> Bool -> Maybe Text -> Either String Text
mkConsoleHTML :: HasVersion => Text -> AuthMode -> Bool -> Maybe Text -> Either String Text
mkConsoleHTML path authMode enableTelemetry consoleAssetsDir =
renderHtmlTemplate consoleTmplt $
-- variables required to render the template
@ -364,7 +366,7 @@ mkConsoleHTML path authMode enableTelemetry consoleAssetsDir =
, "consolePath" .= consolePath
, "enableTelemetry" .= boolToText enableTelemetry
, "cdnAssets" .= boolToText (isNothing consoleAssetsDir)
, "assetsVersion" .= consoleVersion
, "assetsVersion" .= consoleAssetsVersion
, "serverVersion" .= currentVersion
]
where

15
server/src-lib/Hasura/Events/Lib.hs
View File

@ -23,6 +23,7 @@ import Hasura.HTTP
import Hasura.Prelude
import Hasura.RQL.DDL.Headers
import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types
import qualified Control.Concurrent.STM.TQueue as TQ
@ -167,9 +168,8 @@ initEventEngineCtx maxT fetchI = do
return $ EventEngineCtx q c maxT fetchI
processEventQueue
:: L.Logger L.Hasura -> LogEnvHeaders -> HTTP.Manager-> Q.PGPool
-> IO SchemaCache -> EventEngineCtx
-> IO ()
:: (HasVersion) => L.Logger L.Hasura -> LogEnvHeaders -> HTTP.Manager-> Q.PGPool
-> IO SchemaCache -> EventEngineCtx -> IO ()
processEventQueue logger logenv httpMgr pool getSchemaCache eectx = do
threads <- mapM async [fetchThread, consumeThread]
void $ waitAny threads
@ -188,16 +188,17 @@ pushEvents logger pool eectx = forever $ do
threadDelay (fetchI * 1000)
consumeEvents
:: L.Logger L.Hasura -> LogEnvHeaders -> HTTP.Manager -> Q.PGPool -> IO SchemaCache -> EventEngineCtx
-> IO ()
:: (HasVersion) => L.Logger L.Hasura -> LogEnvHeaders -> HTTP.Manager -> Q.PGPool -> IO SchemaCache
-> EventEngineCtx -> IO ()
consumeEvents logger logenv httpMgr pool getSchemaCache eectx = forever $ do
event <- atomically $ do
let EventEngineCtx q _ _ _ = eectx
TQ.readTQueue q
async $ runReaderT (processEvent logenv pool getSchemaCache event) (logger, httpMgr, eectx)
async $ runReaderT (processEvent logenv pool getSchemaCache event) (logger, httpMgr, eectx)
processEvent
:: ( MonadReader r m
:: ( HasVersion
, MonadReader r m
, Has HTTP.Manager r
, Has (L.Logger L.Hasura) r
, Has EventEngineCtx r

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

@ -48,6 +48,7 @@ import Hasura.RQL.DDL.Headers
import Hasura.RQL.Types
import Hasura.Server.Context
import Hasura.Server.Utils (RequestId, filterRequestHeaders)
import Hasura.Server.Version (HasVersion)
import qualified Hasura.GraphQL.Execute.LiveQuery as EL
import qualified Hasura.GraphQL.Execute.Plan as EP
@ -345,7 +346,8 @@ getSubsOp pgExecCtx gCtx sqlGenCtx userInfo queryReusability fld =
runE gCtx sqlGenCtx userInfo $ getSubsOpM pgExecCtx queryReusability fld
execRemoteGQ
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadError QErr m
, MonadReader ExecutionCtx m
)

3
server/src-lib/Hasura/GraphQL/RemoteServer.hs
View File

@ -23,6 +23,7 @@ import qualified Network.Wreq as Wreq
import Hasura.RQL.DDL.Headers (getHeadersFromConf)
import Hasura.RQL.Types
import Hasura.Server.Utils (httpExceptToJSON)
import Hasura.Server.Version (HasVersion)
import qualified Hasura.GraphQL.Context as GC
import qualified Hasura.GraphQL.Schema as GS
@ -32,7 +33,7 @@ introspectionQuery :: BL.ByteString
introspectionQuery = $(embedStringFile "src-rsr/introspection.json")
fetchRemoteSchema
:: (MonadIO m, MonadError QErr m)
:: (HasVersion, MonadIO m, MonadError QErr m)
=> HTTP.Manager
-> RemoteSchemaName
-> RemoteSchemaInfo

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

@ -12,13 +12,15 @@ import Hasura.Prelude
import Hasura.RQL.Types
import Hasura.Server.Context
import Hasura.Server.Utils (RequestId)
import Hasura.Server.Version (HasVersion)
import qualified Database.PG.Query as Q
import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.Logging as L
runGQ
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadError QErr m
, MonadReader E.ExecutionCtx m
)
@ -38,7 +40,8 @@ runGQ reqId userInfo reqHdrs req = do
E.execRemoteGQ reqId userInfo reqHdrs req rsi opDef
runGQBatched
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadError QErr m
, MonadReader E.ExecutionCtx m
)
@ -55,12 +58,12 @@ runGQBatched reqId userInfo reqHdrs reqs =
-- It's unclear what we should do if we receive multiple
-- responses with distinct headers, so just do the simplest thing
-- in this case, and don't forward any.
let removeHeaders =
flip HttpResponse Nothing
. encJFromList
let removeHeaders =
flip HttpResponse Nothing
. encJFromList
. map (either (encJFromJValue . encodeGQErr False) _hrBody)
try = flip catchError (pure . Left) . fmap Right
fmap removeHeaders $
fmap removeHeaders $
traverse (try . runGQ reqId userInfo reqHdrs) batch
runHasuraGQ

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

@ -43,6 +43,7 @@ import Hasura.Server.Context
import Hasura.Server.Cors
import Hasura.Server.Utils (RequestId, diffTimeToMicro,
getRequestId, withElapsedTime)
import Hasura.Server.Version (HasVersion)
import qualified Hasura.GraphQL.Execute as E
import qualified Hasura.GraphQL.Execute.LiveQuery as LQ
@ -270,7 +271,7 @@ onConn (L.Logger logger) corsPolicy wsId requestHead = do
<> "HASURA_GRAPHQL_WS_READ_COOKIE to force read cookie when CORS is disabled."
onStart :: WSServerEnv -> WSConn -> StartMsg -> IO ()
onStart :: HasVersion => WSServerEnv -> WSConn -> StartMsg -> IO ()
onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
opM <- liftIO $ STM.atomically $ STMMap.lookup opId opMap
@ -409,14 +410,14 @@ onStart serverEnv wsConn (StartMsg opId q) = catchAndIgnore $ do
liveQOnChange (GQSuccess (LQ.LiveQueryResponse bs dTime)) =
sendMsgWithMetadata wsConn (SMData $ DataMsg opId $ GRHasura $ GQSuccess bs) $
LQ.LiveQueryMetadata dTime
liveQOnChange resp = sendMsg wsConn $ SMData $ DataMsg opId $ GRHasura $
liveQOnChange resp = sendMsg wsConn $ SMData $ DataMsg opId $ GRHasura $
LQ._lqrPayload <$> resp
catchAndIgnore :: ExceptT () IO () -> IO ()
catchAndIgnore m = void $ runExceptT m
onMessage
:: (MonadIO m, UserAuthentication m)
:: (HasVersion, MonadIO m, UserAuthentication m)
=> AuthMode
-> WSServerEnv
-> WSConn -> BL.ByteString -> m ()
@ -481,7 +482,7 @@ logWSEvent (L.Logger logger) wsConn wsEv = do
ODStopped -> False
onConnInit
:: (MonadIO m, UserAuthentication m)
:: (HasVersion, MonadIO m, UserAuthentication m)
=> L.Logger L.Hasura -> H.Manager -> WSConn -> AuthMode -> Maybe ConnParams -> m ()
onConnInit logger manager wsConn authMode connParamsM = do
headers <- mkHeaders <$> liftIO (STM.readTVarIO (_wscUser $ WS.getData wsConn))
@ -547,7 +548,8 @@ createWSServerEnv logger pgExecCtx lqState getSchemaCache httpManager
sqlGenCtx planCache wsServer enableAL
createWSServerApp
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MC.MonadBaseControl IO m
, LA.Forall (LA.Pure m)
, UserAuthentication m

19
server/src-lib/Hasura/HTTP.hs
View File

@ -5,17 +5,18 @@ module Hasura.HTTP
, addDefaultHeaders
) where
import Control.Lens hiding ((.=))
import Hasura.Prelude
import Control.Lens hiding ((.=))
import Data.CaseInsensitive (original)
import Data.Text.Conversions (UTF8 (..), convertText)
import qualified Data.Aeson as J
import qualified Data.Text.Encoding as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wreq as Wreq
import Data.CaseInsensitive (original)
import Hasura.Server.Version (currentVersion)
import Hasura.Server.Version (HasVersion, currentVersion)
hdrsToText :: [HTTP.Header] -> [(Text, Text)]
hdrsToText hdrs =
@ -23,7 +24,7 @@ hdrsToText hdrs =
| (hdrName, hdrVal) <- hdrs
]
wreqOptions :: HTTP.Manager -> [HTTP.Header] -> Wreq.Options
wreqOptions :: HasVersion => HTTP.Manager -> [HTTP.Header] -> Wreq.Options
wreqOptions manager hdrs =
Wreq.defaults
& Wreq.headers .~ addDefaultHeaders hdrs
@ -31,20 +32,20 @@ wreqOptions manager hdrs =
& Wreq.manager .~ Right manager
-- Adds defaults headers overwriting any existing ones
addDefaultHeaders :: [HTTP.Header] -> [HTTP.Header]
addDefaultHeaders :: HasVersion => [HTTP.Header] -> [HTTP.Header]
addDefaultHeaders hdrs = defaultHeaders <> rmDefaultHeaders hdrs
where
rmDefaultHeaders = filter (not . isDefaultHeader)
isDefaultHeader :: HTTP.Header -> Bool
isDefaultHeader :: HasVersion => HTTP.Header -> Bool
isDefaultHeader (hdrName, _) = hdrName `elem` (map fst defaultHeaders)
defaultHeaders :: [HTTP.Header]
defaultHeaders :: HasVersion => [HTTP.Header]
defaultHeaders = [contentType, userAgent]
where
contentType = ("Content-Type", "application/json")
userAgent = ( "User-Agent"
, "hasura-graphql-engine/" <> T.encodeUtf8 currentVersion
, "hasura-graphql-engine/" <> unUTF8 (convertText currentVersion)
)
newtype HttpException

9
server/src-lib/Hasura/RQL/DDL/Metadata.hs
View File

@ -23,12 +23,13 @@ import qualified Data.Text as T
import Hasura.EncJSON
import Hasura.Prelude
import Hasura.RQL.DDL.ComputedField (dropComputedFieldFromCatalog)
import Hasura.RQL.DDL.Metadata.Types
import Hasura.RQL.DDL.EventTrigger (delEventTriggerFromCatalog, subTableP2)
import Hasura.RQL.DDL.Metadata.Types
import Hasura.RQL.DDL.Permission.Internal (dropPermFromCatalog)
import Hasura.RQL.DDL.RemoteSchema (addRemoteSchemaP2,
removeRemoteSchemaFromCatalog)
import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types
import qualified Database.PG.Query as Q
@ -116,7 +117,8 @@ applyQP1 (ReplaceMetadata _ tables functionsMeta schemas collections allowlist)
l L.\\ HS.toList (HS.fromList l)
applyQP2
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadTx m
, CacheRWM m
, HasSystemDefined m
@ -197,7 +199,8 @@ applyQP2 (ReplaceMetadata _ tables functionsMeta schemas collections allowlist)
processPerms tabInfo perms = indexedForM_ perms $ Permission.addPermP2 (_tciName tabInfo)
runReplaceMetadata
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadTx m
, CacheRWM m
, HasSystemDefined m

9
server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs
View File

@ -17,10 +17,12 @@ import qualified Database.PG.Query as Q
import Hasura.GraphQL.RemoteServer
import Hasura.RQL.Types
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types
runAddRemoteSchema
:: ( QErrM m
:: ( HasVersion
, QErrM m
, CacheRWM m
, MonadTx m
, MonadIO m
@ -45,7 +47,7 @@ addRemoteSchemaP1 name = do
<> name <<> " already exists"
addRemoteSchemaP2Setup
:: (QErrM m, MonadIO m, HasHttpManager m)
:: (HasVersion, QErrM m, MonadIO m, HasHttpManager m)
=> AddRemoteSchemaQuery -> m RemoteSchemaCtx
addRemoteSchemaP2Setup (AddRemoteSchemaQuery name def _) = do
httpMgr <- askHttpManager
@ -53,7 +55,8 @@ addRemoteSchemaP2Setup (AddRemoteSchemaQuery name def _) = do
gCtx <- fetchRemoteSchema httpMgr name rsi
pure $ RemoteSchemaCtx name gCtx rsi
addRemoteSchemaP2 :: (MonadTx m, MonadIO m, HasHttpManager m) => AddRemoteSchemaQuery -> m ()
addRemoteSchemaP2
:: (HasVersion, MonadTx m, MonadIO m, HasHttpManager m) => AddRemoteSchemaQuery -> m ()
addRemoteSchemaP2 q = do
void $ addRemoteSchemaP2Setup q
liftTx $ addRemoteSchemaToCatalog q

9
server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs
View File

@ -52,10 +52,11 @@ import Hasura.RQL.DDL.Utils
import Hasura.RQL.Types
import Hasura.RQL.Types.Catalog
import Hasura.RQL.Types.QueryCollection
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types
buildRebuildableSchemaCache
:: (MonadIO m, MonadUnique m, MonadTx m, HasHttpManager m, HasSQLGenCtx m)
:: (HasVersion, MonadIO m, MonadUnique m, MonadTx m, HasHttpManager m, HasSQLGenCtx m)
=> m (RebuildableSchemaCache m)
buildRebuildableSchemaCache = do
catalogMetadata <- liftTx fetchCatalogData
@ -97,7 +98,7 @@ instance (MonadIO m, MonadTx m, MonadUnique m) => CacheRWM (CacheRWT m) where
buildSchemaCacheRule
-- Note: by supplying BuildReason via MonadReader, it does not participate in caching, which is
-- what we want!
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
:: ( HasVersion, ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
, MonadIO m, MonadTx m, MonadReader BuildReason m, HasHttpManager m, HasSQLGenCtx m )
=> (CatalogMetadata, InvalidationMap) `arr` SchemaCache
buildSchemaCacheRule = proc inputs -> do
@ -117,7 +118,7 @@ buildSchemaCacheRule = proc inputs -> do
}
where
buildAndCollectInfo
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
:: ( HasVersion, ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
, ArrowWriter (Seq CollectedInfo) arr, MonadIO m, MonadTx m, MonadReader BuildReason m
, HasHttpManager m, HasSQLGenCtx m )
=> (CatalogMetadata, InvalidationMap) `arr` BuildOutputs
@ -267,7 +268,7 @@ buildSchemaCacheRule = proc inputs -> do
mkAllTriggersQ triggerName tableName (M.elems tableColumns) triggerDefinition
addRemoteSchema
:: ( ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr, ArrowKleisli m arr
:: ( HasVersion, ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr, ArrowKleisli m arr
, MonadIO m, HasHttpManager m )
=> ( (RemoteSchemaMap, GS.GCtxMap, GS.GCtx)
, (Maybe InvalidationKey, AddRemoteSchemaQuery)

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

@ -191,7 +191,7 @@ class MetadataApiAuthorization m where
authorizeMetadataApi :: RQLQuery -> UserInfo -> Handler m ()
mkSpockAction
:: (MonadIO m, FromJSON a, ToJSON a, UserAuthentication m, HttpLog m)
:: (HasVersion, MonadIO m, FromJSON a, ToJSON a, UserAuthentication m, HttpLog m)
=> ServerCtx
-> (Bool -> QErr -> Value)
-- ^ `QErr` JSON encoder function
@ -277,7 +277,7 @@ mkSpockAction serverCtx qErrEncoder qErrModifier apiHandler = do
mkHeaders = maybe [] (map unHeader)
v1QueryHandler :: (MonadIO m, MetadataApiAuthorization m) => RQLQuery -> Handler m (HttpResponse EncJSON)
v1QueryHandler :: (HasVersion, MonadIO m, MetadataApiAuthorization m) => RQLQuery -> Handler m (HttpResponse EncJSON)
v1QueryHandler query = do
userInfo <- asks hcUser
authorizeMetadataApi query userInfo
@ -298,7 +298,7 @@ v1QueryHandler query = do
instanceId <- scInstanceId . hcServerCtx <$> ask
runQuery pgExecCtx instanceId userInfo schemaCache httpMgr sqlGenCtx (SystemDefined False) query
v1Alpha1GQHandler :: (MonadIO m) => GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON)
v1Alpha1GQHandler :: (HasVersion, MonadIO m) => GH.GQLBatchedReqs GH.GQLQueryText -> Handler m (HttpResponse EncJSON)
v1Alpha1GQHandler query = do
userInfo <- asks hcUser
reqHeaders <- asks hcReqHeaders
@ -316,7 +316,7 @@ v1Alpha1GQHandler query = do
flip runReaderT execCtx $ GH.runGQBatched requestId userInfo reqHeaders query
v1GQHandler
:: (MonadIO m)
:: (HasVersion, MonadIO m)
=> GH.GQLBatchedReqs GH.GQLQueryText
-> Handler m (HttpResponse EncJSON)
v1GQHandler = v1Alpha1GQHandler
@ -368,7 +368,7 @@ consoleAssetsHandler logger dir path = do
headers = ("Content-Type", mimeType) : encHeader
class (Monad m) => ConsoleRenderer m where
renderConsole :: T.Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)
renderConsole :: HasVersion => T.Text -> AuthMode -> Bool -> Maybe Text -> m (Either String Text)
renderHtmlTemplate :: M.Template -> Value -> Either String Text
renderHtmlTemplate template jVal =
@ -398,7 +398,7 @@ queryParsers =
return $ f q
legacyQueryHandler
:: (MonadIO m, MetadataApiAuthorization m)
:: (HasVersion, MonadIO m, MetadataApiAuthorization m)
=> TableName -> T.Text -> Object
-> Handler m (HttpResponse EncJSON)
legacyQueryHandler tn queryType req =
@ -425,7 +425,8 @@ data HasuraApp
mkWaiApp
:: forall m.
( MonadIO m
( HasVersion
, MonadIO m
, MonadStateless IO m
, ConsoleRenderer m
, HttpLog m
@ -513,7 +514,7 @@ mkWaiApp isoLevel logger sqlGenCtx enableAL pool ci httpManager mode corsCfg ena
httpApp
:: (MonadIO m, ConsoleRenderer m, HttpLog m, UserAuthentication m, MetadataApiAuthorization m)
:: (HasVersion, MonadIO m, ConsoleRenderer m, HttpLog m, UserAuthentication m, MetadataApiAuthorization m)
=> CorsConfig
-> ServerCtx
-> Bool

16
server/src-lib/Hasura/Server/Auth.hs
View File

@ -23,6 +23,7 @@ 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
@ -43,7 +44,8 @@ import Hasura.Server.Utils
-- | Typeclass representing the @UserInfo@ authorization and resolving effect
class (Monad m) => UserAuthentication m where
resolveUserInfo
:: Logger Hasura
:: (HasVersion)
=> Logger Hasura
-> H.Manager
-> [N.Header]
-- ^ request headers
@ -79,7 +81,8 @@ data AuthMode
deriving (Show, Eq)
mkAuthMode
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadError T.Text m
)
=> Maybe AdminSecret
@ -117,7 +120,8 @@ mkAuthMode mAdminSecret mWebHook mJwtSecret mUnAuthRole httpManager logger =
<> " when --auth-hook (HASURA_GRAPHQL_AUTH_HOOK) is set"
mkJwtCtx
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadError T.Text m
)
=> JWTConfig
@ -180,7 +184,7 @@ mkUserInfoFromResp logger url method statusCode respBody
url method Nothing $ fmap (bsToTxt . BL.toStrict) mResp
userInfoFromAuthHook
:: (MonadIO m, MonadError QErr m)
:: (HasVersion, MonadIO m, MonadError QErr m)
=> Logger Hasura
-> H.Manager
-> AuthHook
@ -219,7 +223,7 @@ userInfoFromAuthHook logger manager hook reqHeaders = do
n `notElem` commonClientHeadersIgnored
getUserInfo
:: (MonadIO m, MonadError QErr m)
:: (HasVersion, MonadIO m, MonadError QErr m)
=> Logger Hasura
-> H.Manager
-> [N.Header]
@ -228,7 +232,7 @@ getUserInfo
getUserInfo l m r a = fst <$> getUserInfoWithExpTime l m r a
getUserInfoWithExpTime
:: (MonadIO m, MonadError QErr m)
:: (HasVersion, MonadIO m, MonadError QErr m)
=> Logger Hasura
-> H.Manager
-> [N.Header]

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

@ -28,6 +28,7 @@ import Hasura.RQL.Types
import Hasura.Server.Auth.JWT.Internal (parseHmacKey, parseRsaKey)
import Hasura.Server.Auth.JWT.Logging
import Hasura.Server.Utils (diffTimeToMicro, fmapL, userRoleHeader)
import Hasura.Server.Version (HasVersion)
import qualified Control.Concurrent as C
import qualified Crypto.JWT as Jose
@ -105,7 +106,7 @@ computeDiffTime t =
-- | create a background thread to refresh the JWK
jwkRefreshCtrl
:: (MonadIO m)
:: (HasVersion, MonadIO m)
=> Logger Hasura
-> HTTP.Manager
-> URI
@ -130,7 +131,8 @@ jwkRefreshCtrl logger manager url ref time =
-- | Given a JWK url, fetch JWK from it and update the IORef
updateJwkRef
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadError T.Text m
)
=> Logger Hasura
@ -430,4 +432,3 @@ instance A.FromJSON JWTConfig where
runEither = either (invalidJwk . T.unpack) return
invalidJwk msg = fail ("Invalid JWK: " <> msg)

14
server/src-lib/Hasura/Server/CheckUpdates.hs
View File

@ -5,6 +5,7 @@ module Hasura.Server.CheckUpdates
import Control.Exception (try)
import Control.Lens
import Control.Monad (forever)
import Data.Text.Conversions (toText)
import qualified CI
import qualified Control.Concurrent as C
@ -13,23 +14,24 @@ import qualified Data.Aeson.Casing as A
import qualified Data.Aeson.TH as A
import qualified Data.Text as T
import qualified Network.HTTP.Client as H
import qualified Network.URI.Encode as URI
import qualified Network.Wreq as Wreq
import qualified System.Log.FastLogger as FL
import Hasura.HTTP
import Hasura.Logging (LoggerCtx (..))
import Hasura.Prelude
import Hasura.Server.Version (currentVersion)
import Hasura.Server.Version (HasVersion, Version, currentVersion)
newtype UpdateInfo
= UpdateInfo
{ _uiLatest :: T.Text
} deriving (Show, Eq)
{ _uiLatest :: Version
} deriving (Show)
$(A.deriveJSON (A.aesonDrop 2 A.snakeCase) ''UpdateInfo)
checkForUpdates :: LoggerCtx a -> H.Manager -> IO ()
checkForUpdates :: (HasVersion) => LoggerCtx a -> H.Manager -> IO ()
checkForUpdates (LoggerCtx loggerSet _ _ _) manager = do
let options = wreqOptions manager []
url <- getUrl
@ -45,10 +47,10 @@ checkForUpdates (LoggerCtx loggerSet _ _ _) manager = do
C.threadDelay aDay
where
updateMsg v = "Update: A new version is available: " <> v
updateMsg v = "Update: A new version is available: " <> toText v
getUrl = do
let buildUrl agent = "https://releases.hasura.io/graphql-engine?agent=" <>
agent <> "&version=" <> currentVersion
agent <> "&version=" <> URI.encodeText (toText currentVersion)
ciM <- CI.getCI
return . buildUrl $ case ciM of
Nothing -> "server"

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

@ -9,7 +9,7 @@ import Data.Aeson.TH
import Hasura.Prelude
import Hasura.Server.Auth
import Hasura.Server.Auth.JWT
import qualified Hasura.Server.Version as V
import Hasura.Server.Version (HasVersion, Version, currentVersion)
data JWTInfo
= JWTInfo
@ -21,22 +21,22 @@ $(deriveToJSON (aesonDrop 4 snakeCase) ''JWTInfo)
data ServerConfig
= ServerConfig
{ scfgVersion :: !Text
{ scfgVersion :: !Version
, scfgIsAdminSecretSet :: !Bool
, scfgIsAuthHookSet :: !Bool
, scfgIsJwtSet :: !Bool
, scfgJwt :: !(Maybe JWTInfo)
} deriving (Show, Eq)
} deriving (Show)
$(deriveToJSON (aesonDrop 4 snakeCase) ''ServerConfig)
runGetConfig :: AuthMode -> ServerConfig
runGetConfig :: HasVersion => AuthMode -> ServerConfig
runGetConfig am = ServerConfig
V.currentVersion
(isAdminSecretSet am)
(isAuthHookSet am)
(isJWTSet am)
(getJWTInfo am)
currentVersion
(isAdminSecretSet am)
(isAuthHookSet am)
(isJWTSet am)
(getJWTInfo am)
isAdminSecretSet :: AuthMode -> Bool
isAdminSecretSet = \case

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

@ -22,19 +22,20 @@ import Data.Time.Clock (UTCTime)
import Hasura.Prelude
import qualified Data.Aeson as A
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Database.PG.Query as Q
import qualified Database.PG.Query.Connection as Q
import qualified Language.Haskell.TH.Lib as TH
import qualified Language.Haskell.TH.Syntax as TH
import qualified Data.HashMap.Strict as HM
import Hasura.Logging (Hasura, LogLevel (..), ToEngineLog (..))
import Hasura.RQL.DDL.Relationship
import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types
import Hasura.RQL.DDL.Relationship
import Hasura.Server.Logging (StartupLog (..))
import Hasura.Server.Migrate.Version (latestCatalogVersion, latestCatalogVersionString)
import Hasura.Server.Version (HasVersion)
import Hasura.SQL.Types
dropCatalog :: (MonadTx m) => m ()
@ -66,7 +67,8 @@ instance ToEngineLog MigrationResult Hasura where
migrateCatalog
:: forall m
. ( MonadIO m
. ( HasVersion
, MonadIO m
, MonadTx m
, MonadUnique m
, HasHttpManager m

5
server/src-lib/Hasura/Server/Query.hs
View File

@ -34,6 +34,7 @@ import Hasura.RQL.Types
import Hasura.RQL.Types.Run
import Hasura.Server.Init (InstanceId (..))
import Hasura.Server.Utils
import Hasura.Server.Version (HasVersion)
data RQLQueryV1
@ -168,7 +169,7 @@ recordSchemaUpdate instanceId =
|] (Identity instanceId) True
runQuery
:: (MonadIO m, MonadError QErr m)
:: (HasVersion, MonadIO m, MonadError QErr m)
=> PGExecCtx -> InstanceId
-> UserInfo -> RebuildableSchemaCache Run -> HTTP.Manager
-> SQLGenCtx -> SystemDefined -> RQLQuery -> m (EncJSON, RebuildableSchemaCache Run)
@ -305,7 +306,7 @@ reconcileAccessModes (Just mode1) (Just mode2)
| otherwise = Left mode2
runQueryM
:: ( QErrM m, CacheRWM m, UserInfoM m, MonadTx m
:: ( HasVersion, QErrM m, CacheRWM m, UserInfoM m, MonadTx m
, MonadIO m, HasHttpManager m, HasSQLGenCtx m
, HasSystemDefined m
)

56
server/src-lib/Hasura/Server/Telemetry.hs
View File

@ -9,9 +9,10 @@ module Hasura.Server.Telemetry
)
where
import Control.Exception (try)
import Control.Exception (try)
import Control.Lens
import Data.List
import Data.Text.Conversions (UTF8 (..), decodeText)
import Hasura.HTTP
import Hasura.Logging
@ -21,17 +22,16 @@ import Hasura.Server.Init
import Hasura.Server.Version
import qualified CI
import qualified Control.Concurrent as C
import qualified Data.Aeson as A
import qualified Data.Aeson.Casing as A
import qualified Data.Aeson.TH as A
import qualified Data.ByteString.Lazy as BL
import qualified Data.HashMap.Strict as Map
import qualified Data.String.Conversions as CS
import qualified Data.Text as T
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wreq as Wreq
import qualified Control.Concurrent as C
import qualified Data.Aeson as A
import qualified Data.Aeson.Casing as A
import qualified Data.Aeson.TH as A
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 HTTP
import qualified Network.HTTP.Types as HTTP
import qualified Network.Wreq as Wreq
data RelationshipMetric
@ -39,7 +39,7 @@ data RelationshipMetric
{ _rmManual :: !Int
, _rmAuto :: !Int
} deriving (Show, Eq)
$(A.deriveJSON (A.aesonDrop 3 A.snakeCase) ''RelationshipMetric)
$(A.deriveToJSON (A.aesonDrop 3 A.snakeCase) ''RelationshipMetric)
data PermissionMetric
= PermissionMetric
@ -49,7 +49,7 @@ data PermissionMetric
, _pmDelete :: !Int
, _pmRoles :: !Int
} deriving (Show, Eq)
$(A.deriveJSON (A.aesonDrop 3 A.snakeCase) ''PermissionMetric)
$(A.deriveToJSON (A.aesonDrop 3 A.snakeCase) ''PermissionMetric)
data Metrics
= Metrics
@ -62,37 +62,39 @@ data Metrics
, _mtRemoteSchemas :: !Int
, _mtFunctions :: !Int
} deriving (Show, Eq)
$(A.deriveJSON (A.aesonDrop 3 A.snakeCase) ''Metrics)
$(A.deriveToJSON (A.aesonDrop 3 A.snakeCase) ''Metrics)
data HasuraTelemetry
= HasuraTelemetry
{ _htDbUid :: !Text
, _htInstanceUid :: !InstanceId
, _htVersion :: !Text
, _htVersion :: !Version
, _htCi :: !(Maybe CI.CI)
, _htMetrics :: !Metrics
} deriving (Show, Eq)
$(A.deriveJSON (A.aesonDrop 3 A.snakeCase) ''HasuraTelemetry)
} deriving (Show)
$(A.deriveToJSON (A.aesonDrop 3 A.snakeCase) ''HasuraTelemetry)
data TelemetryPayload
= TelemetryPayload
{ _tpTopic :: !Text
, _tpData :: !HasuraTelemetry
} deriving (Show, Eq)
$(A.deriveJSON (A.aesonDrop 3 A.snakeCase) ''TelemetryPayload)
} deriving (Show)
$(A.deriveToJSON (A.aesonDrop 3 A.snakeCase) ''TelemetryPayload)
telemetryUrl :: Text
telemetryUrl = "https://telemetry.hasura.io/v1/http"
mkPayload :: Text -> InstanceId -> Text -> Metrics -> IO TelemetryPayload
mkPayload :: Text -> InstanceId -> Version -> Metrics -> IO TelemetryPayload
mkPayload dbId instanceId version metrics = do
ci <- CI.getCI
return $ TelemetryPayload topic $
HasuraTelemetry dbId instanceId version ci metrics
where topic = bool "server" "server_test" isDevVersion
let topic = case version of
VersionDev _ -> "server_test"
VersionRelease _ -> "server"
pure $ TelemetryPayload topic $ HasuraTelemetry dbId instanceId version ci metrics
runTelemetry
:: Logger Hasura
:: (HasVersion)
=> Logger Hasura
-> HTTP.Manager
-> IO SchemaCache
-- ^ an action that always returns the latest schema cache
@ -207,8 +209,8 @@ mkHttpError url mResp httpEx =
Nothing -> TelemetryHttpError Nothing url httpEx Nothing
Just resp ->
let status = resp ^. Wreq.responseStatus
body = CS.cs $ resp ^. Wreq.responseBody
in TelemetryHttpError (Just status) url httpEx (Just body)
body = decodeText $ UTF8 (resp ^. Wreq.responseBody)
in TelemetryHttpError (Just status) url httpEx body
mkTelemetryLog :: Text -> Text -> Maybe TelemetryHttpError -> TelemetryLog
mkTelemetryLog = TelemetryLog LevelInfo

8
server/src-lib/Hasura/Server/Utils.hs
View File

@ -74,15 +74,15 @@ getRequestId headers =
Just reqId -> return $ RequestId $ bsToTxt reqId
-- Get an env var during compile time
getValFromEnvOrScript :: String -> String -> TH.Q TH.Exp
getValFromEnvOrScript :: String -> String -> TH.Q (TH.TExp String)
getValFromEnvOrScript n s = do
maybeVal <- TH.runIO $ lookupEnv n
case maybeVal of
Just val -> TH.lift val
Just val -> [|| val ||]
Nothing -> runScript s
-- Run a shell script during compile time
runScript :: FilePath -> TH.Q TH.Exp
runScript :: FilePath -> TH.Q (TH.TExp String)
runScript fp = do
TH.addDependentFile fp
fileContent <- TH.runIO $ TI.readFile fp
@ -91,7 +91,7 @@ runScript fp = do
when (exitCode /= ExitSuccess) $ fail $
"Running shell script " ++ fp ++ " failed with exit code : "
++ show exitCode ++ " and with error : " ++ stdErr
TH.lift stdOut
[|| stdOut ||]
-- find duplicates
duplicates :: Ord a => [a] -> [a]

131
server/src-lib/Hasura/Server/Version.hs
View File

@ -1,61 +1,98 @@
{-# OPTIONS_GHC -fforce-recomp #-}
{-# LANGUAGE ImplicitParams #-}
module Hasura.Server.Version
( currentVersion
, consoleVersion
, isDevVersion
( Version(..)
, getVersionFromEnvironment
, HasVersion
, currentVersion
, consoleAssetsVersion
, withVersion
)
where
import Control.Lens ((^.), (^?))
import Data.Either (isLeft)
import qualified Data.SemVer as V
import qualified Data.Text as T
import Hasura.Prelude
import Hasura.Server.Utils (getValFromEnvOrScript)
version :: T.Text
version = T.dropWhileEnd (== '\n')
$(getValFromEnvOrScript "VERSION" "../scripts/get-version.sh")
import qualified Data.SemVer as V
import qualified Data.Text as T
import qualified Language.Haskell.TH.Syntax as TH
parsedVersion :: Either String V.Version
parsedVersion = V.fromText $ T.dropWhile (== 'v') version
import Control.Lens ((^.), (^?))
import Data.Aeson (FromJSON (..), ToJSON (..))
import Data.Text.Conversions (FromText (..), ToText (..))
currentVersion :: T.Text
currentVersion = version
import Hasura.RQL.Instances ()
import Hasura.Server.Utils (getValFromEnvOrScript)
isDevVersion :: Bool
isDevVersion = isLeft parsedVersion
data Version
= VersionDev !Text
| VersionRelease !V.Version
deriving (Show, Eq)
rawVersion :: T.Text
rawVersion = "versioned/" <> version
instance ToText Version where
toText = \case
VersionDev txt -> txt
VersionRelease version -> "v" <> V.toText version
consoleVersion :: T.Text
consoleVersion = case parsedVersion of
Left _ -> rawVersion
Right v -> mkConsoleV v
instance FromText Version where
fromText txt = case V.fromText $ T.dropWhile (== 'v') txt of
Left _ -> VersionDev txt
Right version -> VersionRelease version
mkConsoleV :: V.Version -> T.Text
mkConsoleV v = case getReleaseChannel v of
Nothing -> rawVersion
Just c -> T.pack $ "channel/" <> c <> "/" <> vMajMin
instance ToJSON Version where
toJSON = toJSON . toText
instance FromJSON Version where
parseJSON = fmap fromText . parseJSON
getVersionFromEnvironment :: TH.Q (TH.TExp Version)
getVersionFromEnvironment = do
let txt = getValFromEnvOrScript "VERSION" "../scripts/get-version.sh"
[|| fromText $ T.dropWhileEnd (== '\n') $ T.pack $$(txt) ||]
-- | Lots of random things need access to the current version. It would be very convenient to define
-- @version :: 'Version'@ in this module and export it, and indeed, that’s what we used to do! But
-- that turns out to cause problems: the version is compiled into the executable via Template
-- Haskell, so the Pro codebase runs into awkward problems. Since the Pro codebase depends on this
-- code as a library, it has to do gymnastics to ensure that this library always gets recompiled in
-- order to use the updated version, and that’s really hacky.
--
-- A better solution is to explicitly plumb the version through to everything that needs it, but
-- that would be noisy, so as a compromise we use an implicit parameter. Since implicit parameters
-- are a little cumbersome, we hide the parameter itself behind this 'HasVersion' constraint,
-- 'currentVersion' can be used to access it, and 'withVersion' can be used to bring a version into
-- scope.
type HasVersion = ?version :: Version
currentVersion :: HasVersion => Version
currentVersion = ?version
withVersion :: Version -> (HasVersion => r) -> r
withVersion version x = let ?version = version in x
-- | A version-based string used to form the CDN URL for fetching console assets.
consoleAssetsVersion :: HasVersion => Text
consoleAssetsVersion = case currentVersion of
VersionDev txt -> "versioned/" <> txt
VersionRelease v -> case getReleaseChannel v of
Nothing -> "versioned/" <> vMajMin
Just c -> "channel/" <> c <> "/" <> vMajMin
where
vMajMin = T.pack ("v" <> show (v ^. V.major) <> "." <> show (v ^. V.minor))
where
vMajMin = "v" <> show (v ^. V.major) <> "." <> show (v ^. V.minor)
getReleaseChannel :: V.Version -> Maybe Text
getReleaseChannel sv = case sv ^. V.release of
[] -> Just "stable"
(mr:_) -> case getTextFromId mr of
Nothing -> Nothing
Just r -> if
| "alpha" `T.isPrefixOf` r -> Just "alpha"
| "beta" `T.isPrefixOf` r -> Just "beta"
| "rc" `T.isPrefixOf` r -> Just "rc"
| otherwise -> Nothing
getReleaseChannel :: V.Version -> Maybe String
getReleaseChannel sv = case sv ^. V.release of
[] -> Just "stable"
(mr:_) -> case getTextFromId mr of
Nothing -> Nothing
Just r -> if
| "alpha" `T.isPrefixOf` r -> Just "alpha"
| "beta" `T.isPrefixOf` r -> Just "beta"
| "rc" `T.isPrefixOf` r -> Just "rc"
| otherwise -> Nothing
getTextFromId :: V.Identifier -> Maybe T.Text
getTextFromId i = Just i ^? (toTextualM . V._Textual)
where
toTextualM _ Nothing = pure Nothing
toTextualM f (Just a) = f a
getTextFromId :: V.Identifier -> Maybe Text
getTextFromId i = Just i ^? (toTextualM . V._Textual)
where
toTextualM _ Nothing = pure Nothing
toTextualM f (Just a) = f a

4
server/src-test/Hasura/Server/MigrateSpec.hs
View File

@ -20,6 +20,7 @@ import Hasura.RQL.DDL.Schema
import Hasura.RQL.Types
import Hasura.Server.Migrate
import Hasura.Server.PGDump
import Hasura.Server.Version (HasVersion)
newtype CacheRefT m a
= CacheRefT { runCacheRefT :: MVar (RebuildableSchemaCache m) -> m a }
@ -51,7 +52,8 @@ singleTransaction :: CacheRefT m () -> CacheRefT m ()
singleTransaction = id
spec
:: ( MonadIO m
:: ( HasVersion
, MonadIO m
, MonadBaseControl IO m
, MonadTx m
, MonadUnique m

5
server/src-test/Main.hs
View File

@ -23,6 +23,7 @@ import Hasura.RQL.Types.Run
import Hasura.Server.Init (RawConnInfo, mkConnInfo, mkRawConnInfo,
parseRawConnInfo, runWithEnv)
import Hasura.Server.Migrate
import Hasura.Server.Version
import qualified Data.Parser.CacheControlSpec as CacheControlParser
import qualified Hasura.IncrementalSpec as IncrementalSpec
@ -38,7 +39,7 @@ data TestSuite
| PostgresSuite !RawConnInfo
main :: IO ()
main = parseArgs >>= \case
main = withVersion $$(getVersionFromEnvironment) $ parseArgs >>= \case
AllSuites pgConnOptions -> do
postgresSpecs <- buildPostgresSpecs pgConnOptions
runHspec (unitSpecs *> postgresSpecs)
@ -52,7 +53,7 @@ unitSpecs = do
describe "Hasura.Incremental" IncrementalSpec.spec
describe "Hasura.RQL.Metadata" MetadataSpec.spec
buildPostgresSpecs :: RawConnInfo -> IO Spec
buildPostgresSpecs :: (HasVersion) => RawConnInfo -> IO Spec
buildPostgresSpecs pgConnOptions = do
env <- getEnvironment