refactor(test-harness): Make admin secret injectable

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/9147
GitOrigin-RevId: e12138ad59fb690261e5b8e474d959623bce0826

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))

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} =
     "<GlobalTestEnvironment: " ++ urlPrefix server ++ ":" ++ show (port server) ++ " >"

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

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

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
   )

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} =
     "<TestEnvironment: " ++ urlPrefix (server globalEnvironment) ++ ":" ++ show (port (server globalEnvironment)) ++ " >"