diff --git a/server/cabal.project.freeze b/server/cabal.project.freeze index 5a7842f3..3f90eae4 100644 --- a/server/cabal.project.freeze +++ b/server/cabal.project.freeze @@ -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, diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 3cf811ed..e4c9314f 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -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 diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index e9dfb987..3d61b2c7 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -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 diff --git a/server/src-lib/Hasura/App.hs b/server/src-lib/Hasura/App.hs index 56cff117..d98894c1 100644 --- a/server/src-lib/Hasura/App.hs +++ b/server/src-lib/Hasura/App.hs @@ -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 diff --git a/server/src-lib/Hasura/Events/Lib.hs b/server/src-lib/Hasura/Events/Lib.hs index 9f434b7d..f31191e1 100644 --- a/server/src-lib/Hasura/Events/Lib.hs +++ b/server/src-lib/Hasura/Events/Lib.hs @@ -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 diff --git a/server/src-lib/Hasura/GraphQL/Execute.hs b/server/src-lib/Hasura/GraphQL/Execute.hs index 22c6e8e0..dd0b9bb4 100644 --- a/server/src-lib/Hasura/GraphQL/Execute.hs +++ b/server/src-lib/Hasura/GraphQL/Execute.hs @@ -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 ) diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index f4aa1537..070a855e 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -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 diff --git a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs index d72b12d4..0413d3a2 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/HTTP.hs @@ -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 diff --git a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs index 4fba571e..33b9e9ce 100644 --- a/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs +++ b/server/src-lib/Hasura/GraphQL/Transport/WebSocket.hs @@ -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 diff --git a/server/src-lib/Hasura/HTTP.hs b/server/src-lib/Hasura/HTTP.hs index 521bf292..ef159bfe 100644 --- a/server/src-lib/Hasura/HTTP.hs +++ b/server/src-lib/Hasura/HTTP.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index bd46c1d0..0831fab6 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs index bd575d97..8e0c246a 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs @@ -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 diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs index 7892398c..8f0de991 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs @@ -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) diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index abf89a4f..e4714aeb 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Auth.hs b/server/src-lib/Hasura/Server/Auth.hs index 320681f3..0588c562 100644 --- a/server/src-lib/Hasura/Server/Auth.hs +++ b/server/src-lib/Hasura/Server/Auth.hs @@ -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] diff --git a/server/src-lib/Hasura/Server/Auth/JWT.hs b/server/src-lib/Hasura/Server/Auth/JWT.hs index 6e495e80..68a84a5b 100644 --- a/server/src-lib/Hasura/Server/Auth/JWT.hs +++ b/server/src-lib/Hasura/Server/Auth/JWT.hs @@ -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) - diff --git a/server/src-lib/Hasura/Server/CheckUpdates.hs b/server/src-lib/Hasura/Server/CheckUpdates.hs index e8ae1b90..8eb63fc5 100644 --- a/server/src-lib/Hasura/Server/CheckUpdates.hs +++ b/server/src-lib/Hasura/Server/CheckUpdates.hs @@ -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" diff --git a/server/src-lib/Hasura/Server/Config.hs b/server/src-lib/Hasura/Server/Config.hs index 3423639e..218c2a33 100644 --- a/server/src-lib/Hasura/Server/Config.hs +++ b/server/src-lib/Hasura/Server/Config.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Migrate.hs b/server/src-lib/Hasura/Server/Migrate.hs index 75530b24..288d6e29 100644 --- a/server/src-lib/Hasura/Server/Migrate.hs +++ b/server/src-lib/Hasura/Server/Migrate.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 033f54aa..969e2cc1 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -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 ) diff --git a/server/src-lib/Hasura/Server/Telemetry.hs b/server/src-lib/Hasura/Server/Telemetry.hs index b7b050ec..9ff28e18 100644 --- a/server/src-lib/Hasura/Server/Telemetry.hs +++ b/server/src-lib/Hasura/Server/Telemetry.hs @@ -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 diff --git a/server/src-lib/Hasura/Server/Utils.hs b/server/src-lib/Hasura/Server/Utils.hs index 02a432d1..c8e42699 100644 --- a/server/src-lib/Hasura/Server/Utils.hs +++ b/server/src-lib/Hasura/Server/Utils.hs @@ -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] diff --git a/server/src-lib/Hasura/Server/Version.hs b/server/src-lib/Hasura/Server/Version.hs index 7fd0561c..6e5cae36 100644 --- a/server/src-lib/Hasura/Server/Version.hs +++ b/server/src-lib/Hasura/Server/Version.hs @@ -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 diff --git a/server/src-test/Hasura/Server/MigrateSpec.hs b/server/src-test/Hasura/Server/MigrateSpec.hs index d36c821f..f6751ac1 100644 --- a/server/src-test/Hasura/Server/MigrateSpec.hs +++ b/server/src-test/Hasura/Server/MigrateSpec.hs @@ -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 diff --git a/server/src-test/Main.hs b/server/src-test/Main.hs index d29b787b..1f4d2010 100644 --- a/server/src-test/Main.hs +++ b/server/src-test/Main.hs @@ -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