server: fix major issue with JSON instances of AnyBackend

### Description
This PR fixes a major issue in the JSON instances of `AnyBackend`: they were not symmetrical! `FromJSON` always made the assumption that the value was an object, and that it contained a "kind" field if it happened to not be a Postgres value. `ToJSON` did NOT insert said field in the output, and did not enforce that the output was an object.

....however, it worked, because nowhere in the code did we yet rely on those being symmetrical. They are both used only once:
- `parseJSON` was used to decode a `Metadata` object, but the matching `toJSON` instance, which is heavily customized, does insert the "kind" field properly
- `toJSON` was only used on the `SchemaCache`, which has no corresponding `FromJSON` instance, since we only serialize it in debug endpoints

This PR makes no attempt at making the instances symmetrical. Instead, it implements simpler functions, and pushes the problem of identifying the proper backend (if any) to the call sites.

### Notes

Additionally, it cleans up some instances that were manually written where they could be auto-generated. In the process, this PR changes the semantics of `Show`, since the stock derived instance will include the constructor name, where before it was skipped. I think it is preferable.

https://github.com/hasura/graphql-engine-mono/pull/1672

GitOrigin-RevId: 0a1580a0e0f01c25b8c9fee7612dba6e7de055d5

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

@@ -337,13 +337,20 @@ instance FromJSON Metadata where
     version <- o .:? "version" .!= MVVersion1
     when (version /= MVVersion3) $ fail $
       "unexpected metadata version from storage: " <> show version
-    sources <- oMapFromL getSourceName <$> o .: "sources"
+    unprocessedSources <- o .: "sources"
+    sources <- oMapFromL getSourceName <$> traverse parseSourceMetadata unprocessedSources
     endpoints <- oMapFromL _ceName <$> o .:? "rest_endpoints" .!= []
     (remoteSchemas, queryCollections, allowlist, customTypes,
      actions, cronTriggers, apiLimits, metricsConfig, inheritedRoles,
      disabledSchemaIntrospectionRoles) <- parseNonSourcesMetadata o
     pure $ Metadata sources remoteSchemas queryCollections allowlist
            customTypes actions cronTriggers endpoints apiLimits metricsConfig inheritedRoles disabledSchemaIntrospectionRoles
+    where
+      parseSourceMetadata :: Value -> Parser (AB.AnyBackend SourceMetadata)
+      parseSourceMetadata = withObject "SourceMetadata" \o -> do
+        backendKind <- o .:? "kind" .!= Postgres Vanilla
+        AB.parseAnyBackendFromJSON backendKind (Object o)
+
 
 emptyMetadata :: Metadata
 emptyMetadata =

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

@@ -325,7 +325,28 @@ data SchemaCache
   , scMetadataResourceVersion        :: !(Maybe MetadataResourceVersion)
   , scSetGraphqlIntrospectionOptions :: !SetGraphqlIntrospectionOptions
   }
-$(deriveToJSON hasuraJSON ''SchemaCache)
+
+-- WARNING: this can only be used for debug purposes, as it loses all
+-- backend-specific information in the process!
+instance ToJSON SchemaCache where
+  toJSON SchemaCache{..} = object
+    [ "sources"                           .= toJSON (AB.debugAnyBackendToJSON <$> scSources)
+    , "actions"                           .= toJSON scActions
+    , "remote_schemas"                    .= toJSON scRemoteSchemas
+    , "allowlist"                         .= toJSON scAllowlist
+    , "g_q_l_context"                     .= toJSON scGQLContext
+    , "unauthenticated_g_q_l_context"     .= toJSON scUnauthenticatedGQLContext
+    , "relay_context"                     .= toJSON scRelayContext
+    , "unauthenticated_relay_context"     .= toJSON scUnauthenticatedRelayContext
+    , "dep_map"                           .= toJSON scDepMap
+    , "inconsistent_objs"                 .= toJSON scInconsistentObjs
+    , "cron_triggers"                     .= toJSON scCronTriggers
+    , "endpoints"                         .= toJSON scEndpoints
+    , "api_limits"                        .= toJSON scApiLimits
+    , "metrics_config"                    .= toJSON scMetricsConfig
+    , "metadata_resource_version"         .= toJSON scMetadataResourceVersion
+    , "set_graphql_introspection_options" .= toJSON scSetGraphqlIntrospectionOptions
+    ]
 
 getAllRemoteSchemas :: SchemaCache -> [RemoteSchemaName]
 getAllRemoteSchemas sc =

server/src-lib/Hasura/SQL/AnyBackend.hs

@@ -12,16 +12,17 @@ module Hasura.SQL.AnyBackend
   , unpackAnyBackend
   , composeAnyBackend
   , runBackend
+  , parseAnyBackendFromJSON
+  , debugAnyBackendToJSON
   ) where
 
 import           Hasura.Prelude
 
 import           Control.Arrow.Extended (ArrowChoice, arr, (|||))
-import           Data.Aeson             (FromJSON (..), ToJSON (..), Value (..), withObject, (.:?))
-import           Data.Hashable          (Hashable (hashWithSalt))
+import           Data.Aeson             (FromJSON (..), ToJSON (..), Value)
+import           Data.Aeson.Types       (Parser)
 import           Data.Kind              (Constraint, Type)
 import           Language.Haskell.TH    hiding (Type)
-import           Test.QuickCheck        (oneof)
 
 import           Hasura.SQL.Backend
 import           Hasura.SQL.TH
@@ -67,6 +68,8 @@ $(do
       -- (we Apply a type Variable to a Promoted name)
       [normalType $ AppT (VarT typeVarName) (getBackendTypeValue b)]
     )
+    -- classes in the deriving clause
+    [ ''Generic ]
  )
 
 
@@ -514,59 +517,54 @@ dispatchAnyBackendArrow arrow =
 
 
 
+--------------------------------------------------------------------------------
+-- JSON functions
+
+-- | Attempts to parse an 'AnyBackend' from a JSON value, using the provided
+-- backend information.
+parseAnyBackendFromJSON
+  :: i `SatisfiesForAllBackends` FromJSON
+  => BackendType
+  -> Value
+  -> Parser (AnyBackend i)
+parseAnyBackendFromJSON backendKind value = do
+  -- generates the following case for all backends:
+  --   Foo -> FooValue <$> parseJSON value
+  --   Bar -> BarValue <$> parseJSON value
+  --   ...
+  $(backendCase [| backendKind |]
+     -- the pattern for a given backend
+     ( \b -> do
+         (con:args) <- pure b
+         pure $ ConP con [ConP arg [] | arg <- args]
+     )
+     -- the body for each backend
+     ( \b -> do
+         let valueCon = pure $ ConE $ getBackendValueName b
+         [| $valueCon <$> parseJSON value |]
+     )
+     -- no default case
+     Nothing
+   )
+
+-- | Outputs a debug JSON value from an 'AnyBackend'. This function must only be
+-- used for debug purposes, as it has no way of inserting the backend kind in
+-- the output, since there's no guarantee that the output will be an object.
+debugAnyBackendToJSON
+  :: i `SatisfiesForAllBackends` ToJSON
+  => AnyBackend i
+  -> Value
+debugAnyBackendToJSON e = dispatchAnyBackend' @ToJSON e toJSON
+
+
+
 --------------------------------------------------------------------------------
 -- Instances for 'AnyBackend'
 
-instance i `SatisfiesForAllBackends` Show => Show (AnyBackend i) where
-  show e = dispatchAnyBackend' @Show e show
+deriving instance i `SatisfiesForAllBackends` Show => Show (AnyBackend i)
+deriving instance i `SatisfiesForAllBackends` Eq => Eq (AnyBackend i)
 
-instance i `SatisfiesForAllBackends` Eq => Eq (AnyBackend i) where
-  e1 == e2 =
-    -- generates the following case expression for all backends:
-    --   (FooValue a, FooValue b) -> a == b
-    --   ...
-    --   _ -> False
-    $(backendCase [| (e1, e2) |]
-       -- the pattern for a given backend
-       ( \b -> do
-           let valueCon n = pure $ ConP (getBackendValueName b) [VarP $ mkName n]
-           [p| ($(valueCon "a"), $(valueCon "b")) |]
-       )
-       -- the body for each backend
-       ( const [| a == b |] )
-       -- the default case
-       ( Just [| False |] )
-     )
-
-instance i `SatisfiesForAllBackends` ToJSON => ToJSON (AnyBackend i) where
-  toJSON e = dispatchAnyBackend' @ToJSON e toJSON
-
-instance i `SatisfiesForAllBackends` FromJSON => FromJSON (AnyBackend i) where
-  parseJSON = withObject "AnyBackend" $ \o -> do
-    backendKind <- fromMaybe (Postgres Vanilla) <$> o .:? "kind"
-    -- generates the following case for all backends:
-    --   Foo -> FooValue <$> parseJSON (Object o)
-    --   Bar -> BarValue <$> parseJSON (Object o)
-    --   ...
-    $(backendCase [| backendKind |]
-       -- the pattern for a given backend
-       ( \b -> do
-           (con:args) <- pure b
-           pure $ ConP con [ConP arg [] | arg <- args]
-       )
-       -- the body for each backend
-       ( \b -> do
-           let valueCon = pure $ ConE $ getBackendValueName b
-           [| $valueCon <$> parseJSON (Object o) |]
-       )
-       -- no default case
-       Nothing
-     )
-
-instance i `SatisfiesForAllBackends` Hashable => Hashable (AnyBackend i) where
-  hashWithSalt salt e = dispatchAnyBackend' @Hashable e (hashWithSalt salt)
+instance i `SatisfiesForAllBackends` Hashable => Hashable (AnyBackend i)
 
 instance i `SatisfiesForAllBackends` Arbitrary => Arbitrary (AnyBackend i) where
-  arbitrary = oneof
-    -- generates @FooValue <$> arbitrary@ for each backend
-    $(backendList \b -> [| $(pure $ ConE $ getBackendValueName b) <$> arbitrary |])
+  arbitrary = genericArbitrary

server/src-lib/Hasura/SQL/TH.hs

@@ -97,17 +97,18 @@ backendCase caseExp toPat toBody defaultCase = do
       pure $ matches ++ [Match WildP defaultBody []]
   pure $ CaseE cexp allMatches
 
--- | Creates a data type in which there's one constructor per backend.  While
+-- | Creates a data type in which there's one constructor per backend. While
 -- this only returns one declaration, it nonetheless returns a @[Dec]@ as it's
 -- what the $() splice interpolation syntax expects.
 backendData
   :: Name                          -- ^ the name of the type
   -> [TyVarBndr]                   -- ^ type variables of the type if any
   -> (BackendConstructor -> Q Con) -- ^ the constructor for a given backend
+  -> [Name]                        -- ^ classes to derive using the stock strategy
   -> Q [Dec]
-backendData name tVars mkCon = do
+backendData name tVars mkCon derivs = do
   constructors <- forEachBackend mkCon
-  pure [DataD [] name tVars Nothing constructors []]
+  pure [DataD [] name tVars Nothing constructors [DerivClause (Just StockStrategy) $ map ConT derivs]]
 
 -- | Generates a case expression that applies a function @f@ to each possible value
 -- of an 'AnyBackend' @e@:

server/src-lib/Hasura/SQL/Tag.hs

@@ -39,6 +39,8 @@ $(let name = mkName "BackendTag" in
     -- the resulting type (BackendTag 'Foo)
     (AppT (ConT name) (getBackendTypeValue b))
   )
+  -- deriving clauses
+  []
  )