server: prune health check from codecs for backends that don't support it

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/5822
GitOrigin-RevId: 637a8c668299409385f340d62fc6a84df5c4aa0f

server/graphql-engine.cabal

@@ -681,6 +681,7 @@ library
                      , Hasura.RQL.Types.Eventing
                      , Hasura.RQL.Types.Eventing.Backend
                      , Hasura.RQL.Types.HealthCheck
+                     , Hasura.RQL.Types.HealthCheckImplementation
                      , Hasura.RQL.Types.Function
                      , Hasura.RQL.Types.GraphqlSchemaIntrospection
                      , Hasura.RQL.Types.Instances

server/src-lib/Hasura/Backends/BigQuery/Instances/Types.hs

@@ -49,7 +49,6 @@ instance Backend 'BigQuery where
   type ExtraTableMetadata 'BigQuery = ()
 
   type HealthCheckTest 'BigQuery = Void
-  defaultHealthCheckTest = error "defaultHealthCheckTest"
 
   isComparableType :: ScalarType 'BigQuery -> Bool
   isComparableType = BigQuery.isComparableType

server/src-lib/Hasura/Backends/DataConnector/Adapter/Backend.hs

@@ -72,7 +72,6 @@ instance Backend 'DataConnector where
   type XStreamingSubscription 'DataConnector = XDisable
 
   type HealthCheckTest 'DataConnector = Void
-  defaultHealthCheckTest = error "defaultHealthCheckTest: not implemented for Data Connector backend"
 
   isComparableType :: ScalarType 'DataConnector -> Bool
   isComparableType = \case

server/src-lib/Hasura/Backends/MSSQL/Instances/Types.hs

@@ -14,9 +14,11 @@ import Hasura.Backends.MSSQL.Types.Insert qualified as MSSQL (BackendInsert)
 import Hasura.Backends.MSSQL.Types.Internal qualified as MSSQL
 import Hasura.Backends.MSSQL.Types.Update qualified as MSSQL (BackendUpdate)
 import Hasura.Base.Error
+import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON)
 import Hasura.Prelude
 import Hasura.RQL.Types.Backend
 import Hasura.RQL.Types.HealthCheck
+import Hasura.RQL.Types.HealthCheckImplementation (HealthCheckImplementation (..))
 import Hasura.SQL.Backend
 import Language.GraphQL.Draft.Syntax qualified as G
 
@@ -60,9 +62,12 @@ instance Backend 'MSSQL where
   type XStreamingSubscription 'MSSQL = XDisable
 
   type HealthCheckTest 'MSSQL = HealthCheckTestSql
-
-  defaultHealthCheckTest :: HealthCheckTest 'MSSQL
-  defaultHealthCheckTest = defaultHealthCheckTestSql
+  healthCheckImplementation =
+    Just $
+      HealthCheckImplementation
+        { _hciDefaultTest = defaultHealthCheckTestSql,
+          _hciTestCodec = placeholderCodecViaJSON
+        }
 
   isComparableType :: ScalarType 'MSSQL -> Bool
   isComparableType = MSSQL.isComparableType

server/src-lib/Hasura/Backends/MySQL/Instances/Types.hs

@@ -44,7 +44,6 @@ instance Backend 'MySQL where
   type XStreamingSubscription 'MySQL = XDisable
 
   type HealthCheckTest 'MySQL = Void
-  defaultHealthCheckTest = error "defaultHealthCheckTest"
 
   isComparableType :: ScalarType 'MySQL -> Bool
   isComparableType = isNumType @'MySQL -- TODO: For now we only allow comparisons for numeric types

server/src-lib/Hasura/Backends/Postgres/Instances/Types.hs

@@ -25,10 +25,12 @@ import Hasura.Backends.Postgres.Types.Function qualified as PG
 import Hasura.Backends.Postgres.Types.Insert qualified as PG (BackendInsert)
 import Hasura.Backends.Postgres.Types.Update qualified as PG
 import Hasura.Base.Error
+import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON)
 import Hasura.Prelude
 import Hasura.RQL.IR.BoolExp.AggregationPredicates qualified as Agg
 import Hasura.RQL.Types.Backend
 import Hasura.RQL.Types.HealthCheck
+import Hasura.RQL.Types.HealthCheckImplementation (HealthCheckImplementation (..))
 import Hasura.SQL.Backend
 import Hasura.SQL.Tag
 
@@ -110,7 +112,12 @@ instance
   type XStreamingSubscription ('Postgres pgKind) = XEnable
 
   type HealthCheckTest ('Postgres pgKind) = HealthCheckTestSql
-  defaultHealthCheckTest = defaultHealthCheckTestSql
+  healthCheckImplementation =
+    Just $
+      HealthCheckImplementation
+        { _hciDefaultTest = defaultHealthCheckTestSql,
+          _hciTestCodec = placeholderCodecViaJSON
+        }
 
   isComparableType = PG.isComparableType
   isNumType = PG.isNumType

server/src-lib/Hasura/RQL/Types/Backend.hs

@@ -23,6 +23,7 @@ import Hasura.Base.Error
 import Hasura.Base.ToErrorValue
 import Hasura.Incremental (Cacheable)
 import Hasura.Prelude
+import Hasura.RQL.Types.HealthCheckImplementation (HealthCheckImplementation)
 import Hasura.SQL.Backend
 import Hasura.SQL.Tag
 import Hasura.SQL.Types
@@ -248,8 +249,11 @@ class
   -- | A config type for health check tests
   type HealthCheckTest b :: Type
 
-  -- | Default health check test config
-  defaultHealthCheckTest :: HealthCheckTest b
+  -- | A backend type can opt into supporting health checks by providing an
+  -- implementation that includes a default health check test, and a health
+  -- check test codec.
+  healthCheckImplementation :: Maybe (HealthCheckImplementation (HealthCheckTest b))
+  healthCheckImplementation = Nothing
 
   -- Backend-specific IR types
 

server/src-lib/Hasura/RQL/Types/HealthCheck.hs

@@ -6,16 +6,21 @@ module Hasura.RQL.Types.HealthCheck
     HealthCheckRetryInterval (..),
     HealthCheckTimeout (..),
     defaultHealthCheckTestSql,
+    healthCheckConfigCodec,
   )
 where
 
 import Autodocodec hiding (object, (.=))
 import Autodocodec qualified as AC
 import Data.Aeson.Extended
+import Data.Aeson.Types (parseFail)
+import Data.Text qualified as T
+import Data.Text.Extended qualified as T
 import Hasura.Incremental (Cacheable)
-import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON)
 import Hasura.Prelude
 import Hasura.RQL.Types.Backend
+import Hasura.RQL.Types.HealthCheckImplementation (HealthCheckImplementation (HealthCheckImplementation, _hciDefaultTest, _hciTestCodec))
+import Hasura.SQL.Tag (HasTag (backendTag), reify)
 
 newtype HealthCheckTestSql = HealthCheckTestSql
   { _hctSql :: Text
@@ -45,7 +50,7 @@ newtype HealthCheckRetries = HealthCheckRetries {unHealthCheckRetries :: Int}
   deriving (Eq, Generic, Show, Cacheable, FromJSON, ToJSON)
 
 instance HasCodec HealthCheckRetries where
-  codec = AC.codecViaAeson "HealthCheckRetries"
+  codec = dimapCodec HealthCheckRetries unHealthCheckRetries codec
 
 newtype HealthCheckRetryInterval = HealthCheckRetryInterval {unHealthCheckRetryInterval :: Seconds}
   deriving (Eq, Generic, Show, Cacheable, ToJSON, FromJSON)
@@ -78,23 +83,32 @@ instance (Backend b) => ToJSON (HealthCheckConfig b) where
   toJSON = genericToJSON hasuraJSON {omitNothingFields = True}
 
 instance (Backend b) => FromJSON (HealthCheckConfig b) where
-  parseJSON = withObject "Object" $ \o ->
-    HealthCheckConfig
-      <$> o .:? "test" .!= defaultHealthCheckTest @b
-      <*> o .: "interval"
-      <*> o .:? "retries" .!= defaultRetries
-      <*> o .:? "retry_interval" .!= defaultRetryInterval
-      <*> o .:? "timeout" .!= defaultTimeout
+  parseJSON = case healthCheckImplementation @b of
+    Just (HealthCheckImplementation {..}) ->
+      withObject "Object" $ \o ->
+        HealthCheckConfig
+          <$> o .:? "test" .!= _hciDefaultTest
+          <*> o .: "interval"
+          <*> o .:? "retries" .!= defaultRetries
+          <*> o .:? "retry_interval" .!= defaultRetryInterval
+          <*> o .:? "timeout" .!= defaultTimeout
+    Nothing -> \_ ->
+      parseFail
+        "cannot deserialize health check config because backend does not implement health checks"
 
-instance (Backend b) => HasCodec (HealthCheckConfig b) where
-  codec =
-    AC.object "HealthCheckConfig" $
-      HealthCheckConfig
-        <$> optionalFieldWithOmittedDefaultWith' "test" placeholderCodecViaJSON (defaultHealthCheckTest @b) AC..= _hccTest
-        <*> requiredField' "interval" AC..= _hccInterval
-        <*> optionalFieldWithOmittedDefault' "retries" defaultRetries AC..= _hccRetries
-        <*> optionalFieldWithOmittedDefault' "retry_interval" defaultRetryInterval AC..= _hccRetryInterval
-        <*> optionalFieldWithOmittedDefault' "timeout" defaultTimeout AC..= _hccTimeout
+healthCheckConfigCodec ::
+  forall b.
+  (Backend b) =>
+  HealthCheckImplementation (HealthCheckTest b) ->
+  JSONCodec (HealthCheckConfig b)
+healthCheckConfigCodec (HealthCheckImplementation {..}) =
+  AC.object (codecNamePrefix @b <> "HealthCheckConfig") $
+    HealthCheckConfig
+      <$> optionalFieldWithOmittedDefaultWith' "test" _hciTestCodec _hciDefaultTest AC..= _hccTest
+      <*> requiredField' "interval" AC..= _hccInterval
+      <*> optionalFieldWithOmittedDefault' "retries" defaultRetries AC..= _hccRetries
+      <*> optionalFieldWithOmittedDefault' "retry_interval" defaultRetryInterval AC..= _hccRetryInterval
+      <*> optionalFieldWithOmittedDefault' "timeout" defaultTimeout AC..= _hccTimeout
 
 defaultRetries :: HealthCheckRetries
 defaultRetries = HealthCheckRetries 3
@@ -104,3 +118,6 @@ defaultRetryInterval = HealthCheckRetryInterval 10
 
 defaultTimeout :: HealthCheckTimeout
 defaultTimeout = HealthCheckTimeout 10
+
+codecNamePrefix :: forall b. (HasTag b) => Text
+codecNamePrefix = T.toTitle $ T.toTxt $ reify $ backendTag @b

server/src-lib/Hasura/RQL/Types/HealthCheckImplementation.hs

@@ -0,0 +1,10 @@
+-- | Provides a data type that holds all of the required implementation details
+-- for a backend that supports health checks.
+module Hasura.RQL.Types.HealthCheckImplementation (HealthCheckImplementation (..)) where
+
+import Autodocodec (JSONCodec)
+
+data HealthCheckImplementation healthCheckTest = HealthCheckImplementation
+  { _hciDefaultTest :: healthCheckTest,
+    _hciTestCodec :: JSONCodec healthCheckTest
+  }

server/src-lib/Hasura/RQL/Types/Metadata/Common.hs

@@ -485,8 +485,15 @@ instance Backend b => HasCodec (SourceMetadata b) where
         <*> requiredField' "configuration" .== _smConfiguration
         <*> optionalFieldOrNullWith' "query_tags" placeholderCodecViaJSON .== _smQueryTags -- TODO: replace placeholder
         <*> optionalFieldOrNullWithOmittedDefault' "customization" emptySourceCustomization .== _smCustomization
-        <*> optionalFieldOrNull' "health_check" .== _smHealthCheckConfig
+        <*> healthCheckField
     where
+      healthCheckField = case healthCheckImplementation @b of
+        Just hci -> optionalFieldOrNullWith' "health_check" (healthCheckConfigCodec hci) .== _smHealthCheckConfig
+        Nothing ->
+          -- If this backend does not support health check tests then this field
+          -- should be excluded from the serialization format.
+          pure Nothing
+
       (.==) = (AC..=)
 
 mkSourceMetadata ::