diff --git a/server/lib/api-tests/src/Test/Regression/MultiplexQuerySpec.hs b/server/lib/api-tests/src/Test/Regression/MultiplexQuerySpec.hs index 3041bdd906a..30bbaf03b8a 100644 --- a/server/lib/api-tests/src/Test/Regression/MultiplexQuerySpec.hs +++ b/server/lib/api-tests/src/Test/Regression/MultiplexQuerySpec.hs @@ -114,9 +114,9 @@ tests :: SpecWith TestEnvironment tests = do -- Test subscriptions with two websocket clients. The database state for the following tests are shared. -- Tests involving computed fields - withSubscriptions (withSubscriptions' snd multiplexedQueryComputedFieldsSpec) + withSubscriptions (withSubscriptions multiplexedQueryComputedFieldsSpec) -- Tests involving custom functions - withSubscriptions (withSubscriptions' snd multiplexedQueryCustomFunctionsSpec) + withSubscriptions (withSubscriptions multiplexedQueryCustomFunctionsSpec) multiplexedQueryComputedFieldsSpec :: SpecWith (Value -> [Pair] -> IO SubscriptionHandle, (Value -> [Pair] -> IO SubscriptionHandle, TestEnvironment)) diff --git a/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs b/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs index ad81e4ef4f3..6f1c24fa838 100644 --- a/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs +++ b/server/lib/test-harness/src/Harness/GlobalTestEnvironment.hs @@ -14,6 +14,7 @@ where import Control.Concurrent.Async (Async) import Data.Has +import Data.Text qualified as T import Data.Word import Database.PostgreSQL.Simple.Options (Options) import Harness.Logging.Messages @@ -60,6 +61,17 @@ instance Has PassthroughEnvVars GlobalTestEnvironment where getter = passthroughEnvVars modifier f x = x {passthroughEnvVars = f (passthroughEnvVars x)} +instance Has Services.HgeServerInstance GlobalTestEnvironment where + getter ge = + let s = server ge + in Services.HgeServerInstance + { hgeServerHost = T.drop 7 (T.pack $ urlPrefix s), + hgeServerPort = fromIntegral $ port s, + hgeAdminSecret = "top-secret" + } + + modifier = error "GlobalTestEnvironment does not support modifying HgeServerInstance" + instance Show GlobalTestEnvironment where show GlobalTestEnvironment {server} = "" diff --git a/server/lib/test-harness/src/Harness/GraphqlEngine.hs b/server/lib/test-harness/src/Harness/GraphqlEngine.hs index 1c9fba54f27..6f28a76c0c0 100644 --- a/server/lib/test-harness/src/Harness/GraphqlEngine.hs +++ b/server/lib/test-harness/src/Harness/GraphqlEngine.hs @@ -134,7 +134,7 @@ postWithHeadersStatus statusCode testEnv@(getServer -> Server {urlPrefix, port}) NonAdmin _ -> "test-role" headers' :: Http.RequestHeaders - headers' = ("X-Hasura-Admin-Secret", adminSecret) : ("X-Hasura-Role", role) : headers + headers' = ("X-Hasura-Admin-Secret", "top-secret") : ("X-Hasura-Role", role) : headers responseBody <- withFrozenCallStack case requestProtocol (globalEnvironment testEnv) of WebSocket connection -> postWithHeadersStatusViaWebSocket connection headers' requestBody diff --git a/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs b/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs index b3dd587fb83..37751cdbb49 100644 --- a/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs +++ b/server/lib/test-harness/src/Harness/Services/GraphqlEngine.hs @@ -11,7 +11,6 @@ module Harness.Services.GraphqlEngine hgePost, hgePostGraphql, PostGraphql (..), - adminSecret, ) where @@ -23,9 +22,8 @@ import Data.Attoparsec.ByteString as Atto import Data.ByteString qualified as BS import Data.Has import Data.IORef -import Data.String (fromString) import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Time (NominalDiffTime, diffUTCTime, getCurrentTime) import Data.Vector (fromList) import Harness.Exceptions @@ -44,9 +42,6 @@ import System.IO import System.Process import Test.Hspec -adminSecret :: (IsString a) => a -adminSecret = fromString "top-secret" - -- | The path to the 'graphql-engine' executable. newtype HgeBinPath = HgeBinPath FilePath @@ -56,7 +51,8 @@ data HgeConfig = HgeConfig data HgeServerInstance = HgeServerInstance { hgeServerHost :: Text, - hgeServerPort :: Int + hgeServerPort :: Int, + hgeAdminSecret :: Text } getHgeServerInstanceUrl :: HgeServerInstance -> Text @@ -130,7 +126,7 @@ spawnServer testEnv (HgeConfig {hgeConfigEnvironmentVars}) = do { env = Just $ ("HASURA_GRAPHQL_GRACEFUL_SHUTDOWN_TIMEOUT", "0") - : ("HASURA_GRAPHQL_ADMIN_SECRET", adminSecret) + : ("HASURA_GRAPHQL_ADMIN_SECRET", T.unpack adminSecret) : allEnv, std_out = CreatePipe, std_err = CreatePipe, @@ -158,13 +154,16 @@ spawnServer testEnv (HgeConfig {hgeConfigEnvironmentVars}) = do hgeLogRelayThread logger hgeStdOut hgeStdErrRelayThread logger hgeStdErr liftIO do - let server = HgeServerInstance "127.0.0.1" port + let server = HgeServerInstance "127.0.0.1" port adminSecret result <- Http.healthCheck' (T.unpack $ getHgeServerInstanceUrl server <> "/healthz") case result of Http.Healthy -> pure server Http.Unhealthy failures -> do runLogger logger $ HgeInstanceFailedHealthcheckMessage failures error "Graphql-Engine failed http healthcheck." + where + adminSecret :: Text + adminSecret = "top-secret" -- | Log message type used to indicate a HGE server instance has started. data HgeInstanceStartMessage = HgeInstanceStartMessage {hiStartPort :: Int} @@ -311,10 +310,12 @@ hgePost :: J.Value -> IO J.Value hgePost env statusCode path headers requestBody = do - let hgeUrl = getHgeServerInstanceUrl $ getter env + let hgeInstance = getter @HgeServerInstance env + let hgeUrl = getHgeServerInstanceUrl hgeInstance + let adminSecret = hgeAdminSecret hgeInstance let fullUrl = T.unpack $ hgeUrl <> path testLogMessage env $ LogHGERequest path requestBody - let headersWithAdmin = ("x-hasura-admin-secret", adminSecret) : headers + let headersWithAdmin = ("x-hasura-admin-secret", encodeUtf8 adminSecret) : headers responseBody <- withFrozenCallStack $ Http.postValueWithStatus statusCode fullUrl headersWithAdmin requestBody testLogMessage env $ LogHGEResponse path responseBody return responseBody diff --git a/server/lib/test-harness/src/Harness/Subscriptions.hs b/server/lib/test-harness/src/Harness/Subscriptions.hs index 6cd23225758..0d1f1af922e 100644 --- a/server/lib/test-harness/src/Harness/Subscriptions.hs +++ b/server/lib/test-harness/src/Harness/Subscriptions.hs @@ -16,7 +16,6 @@ module Harness.Subscriptions ( -- * Subscriptions SubscriptionHandle, withSubscriptions, - withSubscriptions', withSubscriptionsHeaders, getNextResponse, ) @@ -30,16 +29,16 @@ import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar) import Data.Aeson import Data.Aeson.QQ import Data.Aeson.Types (Pair) +import Data.Has import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Map.Strict qualified as Map import Data.Text qualified as T import Harness.Exceptions (throw, withFrozenCallStack) import Harness.Logging.Messages -import Harness.Services.GraphqlEngine (adminSecret) +import Harness.Services.GraphqlEngine import Harness.TestEnvironment ( GlobalTestEnvironment (..), Server (..), - TestEnvironment (..), ) import Harness.WebSockets (responseListener) import Hasura.Prelude @@ -48,8 +47,8 @@ import System.Timeout (timeout) import Test.Hspec -- | A subscription's connection initiation message. -initMessage :: [(T.Text, T.Text)] -> Value -initMessage headers = +initMessage :: HgeServerInstance -> [(T.Text, T.Text)] -> Value +initMessage hgeInstance headers = [aesonQQ| { "type": "connection_init", @@ -60,7 +59,7 @@ initMessage headers = } |] where - hdrs = mkInitMessageHeaders headers + hdrs = mkInitMessageHeaders hgeInstance headers -- | A subscription's start query message. startQueryMessage :: Int -> Value -> [Pair] -> Value @@ -99,53 +98,34 @@ newtype SubscriptionHandle = SubscriptionHandle {unSubscriptionHandle :: MVar Va -- > actual :: IO Value -- > actual = getNextResponse query -- > actual `shouldBe` expected -withSubscriptions :: SpecWith (Value -> [Pair] -> IO SubscriptionHandle, TestEnvironment) -> SpecWith TestEnvironment +withSubscriptions :: + ( Has HgeServerInstance env, + Has GlobalTestEnvironment env, + Has Logger env + ) => + SpecWith (Value -> [Pair] -> IO SubscriptionHandle, env) -> + SpecWith env withSubscriptions = withSubscriptionsHeaders [] -withSubscriptionsHeaders :: [(T.Text, T.Text)] -> SpecWith (Value -> [Pair] -> IO SubscriptionHandle, TestEnvironment) -> SpecWith TestEnvironment -withSubscriptionsHeaders headers = withSubscriptionsHeaders' headers id - --- | A composable @'withSubscriptions'. Helpful in writing tests involving multiple websocket clients. --- Example usage: --- --- > spec :: SpecWith (TestEnvironment) --- > spec = do --- > describe "subscriptions multiple clients" $ --- > withSubscriptions' [] id (withSubscriptons' snd subscriptionsSpec) --- --- > subscriptionsSpec :: SpecWith (Value -> [Pair] -> IO SubscriptionHandle, (Value -> [Pair] -> IO SubscriptionHandle, TestEnvironment)) --- > subscriptionsSpec = do --- > it "works" $ \(mkSubscriptionClient2, (mkSubscriptionClient1, _te)) -> do --- > let schemaName :: Schema.SchemaName --- > schemaName = Schema.getSchemaName testEnvironment --- > query1 <- mkSubscriptionClient1 "[graphql| subscription { #{schemaName}_example { id, name }} |]" --- > let expected :: Value --- > expected = --- > [yaml| --- > data: --- > hasura_example: [] --- > |] --- > actual1 :: IO Value --- > actual1 = getNextResponse query1 --- > actual1 `shouldBe` expected --- > query2 <- mkSubscriptionClient2 "[graphql| subscription { #{schemaName}_example { id, name, age }} |]" --- > let actual2 :: IO Value --- > actual2 = getNextResponse query2 --- > actual2 `shouldBe` expected -withSubscriptions' :: (a -> TestEnvironment) -> SpecWith (Value -> [Pair] -> IO SubscriptionHandle, a) -> SpecWith a -withSubscriptions' = withSubscriptionsHeaders' [] - -withSubscriptionsHeaders' :: [(T.Text, T.Text)] -> (a -> TestEnvironment) -> SpecWith (Value -> [Pair] -> IO SubscriptionHandle, a) -> SpecWith a -withSubscriptionsHeaders' headers getTestEnvironment = aroundAllWith \actionWithSubAndTest a -> do - let testEnvironment = getTestEnvironment a - WS.runClient "127.0.0.1" (fromIntegral $ port $ server $ globalEnvironment testEnvironment) "/v1/graphql" \conn -> do +withSubscriptionsHeaders :: + ( Has HgeServerInstance env, + Has GlobalTestEnvironment env, + Has Logger env + ) => + [(T.Text, T.Text)] -> + SpecWith (Value -> [Pair] -> IO SubscriptionHandle, env) -> + SpecWith env +withSubscriptionsHeaders headers = aroundAllWith \actionWithSubAndTest testEnv -> do + let hgeInstance = getter @HgeServerInstance testEnv + let globalEnv = getter @GlobalTestEnvironment testEnv + WS.runClient "127.0.0.1" (fromIntegral $ port $ server globalEnv) "/v1/graphql" \conn -> do -- CAVE: loads of stuff still outstanding: -- * trimming threads, NDAT-228 -- * multiplexing handles, NDAT-229 -- * timeouts on blocking operations, NDAT-230 -- send initialization message - WS.sendTextData conn (encode $ initMessage headers) + WS.sendTextData conn (encode $ initMessage hgeInstance headers) -- Open communication channel with responses. -- @@ -192,7 +172,7 @@ withSubscriptionsHeaders' headers getTestEnvironment = aroundAllWith \actionWith atomicModify handlers (Map.insert (tshow subId) messageBox) -- initialize a connection. - testLogMessage testEnvironment $ LogSubscriptionInit query + testLogMessage testEnv $ LogSubscriptionInit query WS.sendTextData conn (encode $ startQueryMessage subId query extras) pure $ SubscriptionHandle messageBox @@ -207,7 +187,7 @@ withSubscriptionsHeaders' headers getTestEnvironment = aroundAllWith \actionWith -- @withAsync@ will take care of cancelling the 'listener' thread -- for us once the test has been executed. Async.withAsync (handleExceptionsAndTimeout listener) \_ -> do - actionWithSubAndTest (mkSub, a) + actionWithSubAndTest (mkSub, testEnv) -- | Get the next response received on a subscription. -- Blocks until data is available. @@ -220,12 +200,12 @@ getNextResponse handle = do subscriptionsTimeoutTime :: Seconds subscriptionsTimeoutTime = 20 -mkInitMessageHeaders :: [(T.Text, T.Text)] -> Value -mkInitMessageHeaders hdrs = +mkInitMessageHeaders :: HgeServerInstance -> [(T.Text, T.Text)] -> Value +mkInitMessageHeaders hgeInstance hdrs = ( toJSON $ Map.fromList $ [ ("content-type", "application/json"), - ("X-Hasura-Admin-Secret", adminSecret) + ("X-Hasura-Admin-Secret", hgeAdminSecret hgeInstance) ] <> hdrs ) diff --git a/server/lib/test-harness/src/Harness/TestEnvironment.hs b/server/lib/test-harness/src/Harness/TestEnvironment.hs index 8aeca473a3a..67fb1fff9f4 100644 --- a/server/lib/test-harness/src/Harness/TestEnvironment.hs +++ b/server/lib/test-harness/src/Harness/TestEnvironment.hs @@ -111,6 +111,10 @@ instance Has PassthroughEnvVars TestEnvironment where getter = getter . getter @GlobalTestEnvironment modifier f = modifier (modifier @_ @GlobalTestEnvironment f) +instance Has Services.HgeServerInstance TestEnvironment where + getter = getter . getter @GlobalTestEnvironment + modifier f = modifier (modifier @_ @GlobalTestEnvironment f) + instance Show TestEnvironment where show TestEnvironment {globalEnvironment} = ""