tests-hspec refactor leftovers and another small refactor: typos, setup/teardown catch, better error messages for env-vars

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3748
GitOrigin-RevId: 4e4959e41ff33539d82968bbdf56dc10b362e641

server/tests-hspec/Harness/Env.hs

@@ -1,32 +1,55 @@
 {-# OPTIONS -Wno-redundant-constraints #-}
 
+-- | Read environment variables
 module Harness.Env (getEnvRead, getEnvJSON, getEnvString) where
 
 import Data.Aeson qualified as Aeson
 import Data.String
+import Data.Typeable (Proxy (Proxy), Typeable, typeRep)
 import GHC.Stack
 import Hasura.Prelude
-import System.Environment (getEnv)
+import System.Environment (lookupEnv)
 
-getEnvRead :: (Read a, HasCallStack) => String -> IO a
-getEnvRead var = do
-  str <- getEnv var
-  onNothing
-    (readMaybe str)
-    ( error
-        ( unlines
-            ["Failure parsing " <> var, " containing value " <> show str]
-        )
-    )
+-- * API
+
+getEnvRead :: (Read a, Typeable a, HasCallStack) => String -> IO a
+getEnvRead var =
+  withFrozenCallStack $ do
+    readVarValue var =<< getEnv var
 
 getEnvString :: (IsString a, HasCallStack) => String -> IO a
-getEnvString var = fromString <$> getEnv var
+getEnvString var =
+  withFrozenCallStack $
+    fromString <$> getEnv var
 
-getEnvJSON :: (Aeson.FromJSON a, HasCallStack) => String -> IO a
-getEnvJSON var = do
-  accountString <- getEnv var
-  onLeft
-    (Aeson.eitherDecode' (fromString accountString))
-    ( \err ->
-        error (unlines ["Failure parsing " <> var <> ":", show err])
-    )
+getEnvJSON :: forall a. (Typeable a, Aeson.FromJSON a, HasCallStack) => String -> IO a
+getEnvJSON var =
+  withFrozenCallStack $ do
+    accountString <- getEnv var
+    onLeft
+      (Aeson.eitherDecode' (fromString accountString))
+      ( \err ->
+          let expectedType = show (typeRep (Proxy :: Proxy a))
+           in error (unlines ["Failure parsing '" <> var <> "' to type '" <> expectedType <> "':", show err])
+      )
+
+-- * Helpers
+
+getEnv :: HasCallStack => String -> IO String
+getEnv var = do
+  value <- lookupEnv var
+  onNothing value (error $ "getEnv: " <> var <> " does not exist (no environment variable)")
+
+-- | Read a variable to a specific type.
+readVarValue :: forall a. (Read a, Typeable a, HasCallStack) => String -> String -> IO a
+readVarValue var value =
+  onNothing
+    (readMaybe value)
+    let expectedType = show (typeRep (Proxy :: Proxy a))
+     in error
+          ( unwords
+              [ "Failure parsing '" <> var <> "'",
+                "to type '" <> expectedType <> "';",
+                "containing value '" <> show value <> "'."
+              ]
+          )

server/tests-hspec/Harness/Test/Context.hs

@@ -1,6 +1,11 @@
 {-# LANGUAGE DeriveAnyClass #-}
 
--- | Helper functions for easily testing features.
+-- | Helper functions for testing in specific contexts.
+--
+--   A 'Context' represents the prerequisites for running a test,
+--   such as the required backend, the setup process of tables and permissions,
+--   the creation of local state and the teardown of created context after the test
+--   is done.
 module Harness.Test.Context
   ( run,
     runWithLocalState,
@@ -79,7 +84,7 @@ mapItemAction mapActionWith item@Item {itemExample} =
 
 -- | Runs the given tests, for each provided 'Context'@ a@.
 --
--- Each 'Context' provides distinct setup and teardown functions; 'feature'
+-- Each 'Context' provides distinct setup and teardown functions; 'runWithLocalState'
 -- guarantees that the associated 'teardown' function is always called after a
 -- setup, even if the tests fail.
 --
@@ -114,12 +119,14 @@ runWithLocalState contexts tests =
         catch
           -- Setup for a test
           (setup state)
-          ( \setupEx ->
+          ( \setupEx -> do
               catch
-                -- On setup error, attempt to run `teardown` and then throw the setup error
-                (teardown state *> throwIO setupEx)
+                -- On setup error, attempt to run `teardown`
+                (teardown state)
                 -- On teardown error as well, throw both exceptions
                 (throwIO . Exceptions setupEx)
+              -- if teardown succeeds, throw the setup error
+              throwIO setupEx
           )
 
         -- Run tests.
@@ -171,7 +178,7 @@ runWithLocalState contexts tests =
 data Context a = Context
   { -- | A name describing the given context.
     --
-    -- e.g. @Postgre@ or @MySQL@
+    -- e.g. @Postgres@ or @MySQL@
     name :: ContextName,
     -- | Setup actions associated with creating a local state for this 'Context'; for example:
     --  * starting remote servers

server/tests-hspec/README.md

@@ -163,7 +163,7 @@ The `teardown` function is responsible to destroy the local state as well, if ne
 
 #### Setup action
 
-A setup action is a function of type `(State, a) -> IO ()` which is responsible with
+A setup action is a function of type `(State, a) -> IO ()` which is responsible for
 creating the environment for the test. It needs to:
 
 1. Clear and reconfigure the metadata

server/tests-hspec/Test/ObjectRelationshipsLimitSpec.hs

@@ -318,9 +318,9 @@ postgresTeardown :: (State, ()) -> IO ()
 postgresTeardown _ = do
   Postgres.run_
     [sql|
-DROP TABLE hasura.article;
+DROP TABLE IF EXISTS hasura.article;
 |]
   Postgres.run_
     [sql|
-DROP TABLE hasura.author;
+DROP TABLE IF EXISTS hasura.author;
 |]