From 332faabc240bdad360a8bfb9573a45bc0a989cbf Mon Sep 17 00:00:00 2001 From: Jesse Hallett Date: Wed, 12 Oct 2022 12:28:51 -0400 Subject: [PATCH] server: codecs for remaining database configuration types PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6062 GitOrigin-RevId: f1ba9fa30267d1825ba36480103cd973616f3079 --- server/graphql-engine.cabal | 1 + server/src-lib/Database/MSSQL/Pool.hs | 4 + .../Hasura/Backends/BigQuery/Source.hs | 103 +++++++++++++- .../Hasura/Backends/MSSQL/Connection.hs | 38 +++++- .../Hasura/Backends/MSSQL/Instances/Types.hs | 4 +- .../Hasura/Backends/MySQL/Types/Instances.hs | 29 +++- .../Backends/Postgres/Connection/Settings.hs | 3 +- .../Backends/Postgres/Instances/Types.hs | 5 +- server/src-lib/Hasura/Metadata/DTO/Utils.hs | 21 ++- server/src-lib/Hasura/RQL/Types/Common.hs | 39 +++++- .../src-lib/Hasura/RQL/Types/HealthCheck.hs | 6 + .../Hasura/Backends/BigQuery/SourceSpec.hs | 127 ++++++++++++++++++ 12 files changed, 352 insertions(+), 28 deletions(-) create mode 100644 server/src-test/Hasura/Backends/BigQuery/SourceSpec.hs diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index d5b0365d127..5d225e7e542 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -969,6 +969,7 @@ test-suite graphql-engine-tests Discover Hasura.AppSpec Hasura.Base.Error.TestInstances + Hasura.Backends.BigQuery.SourceSpec Hasura.Backends.DataConnector.API.V0.AggregateSpec Hasura.Backends.DataConnector.API.V0.CapabilitiesSpec Hasura.Backends.DataConnector.API.V0.ColumnSpec diff --git a/server/src-lib/Database/MSSQL/Pool.hs b/server/src-lib/Database/MSSQL/Pool.hs index fbc05b98aed..7689397fbfc 100644 --- a/server/src-lib/Database/MSSQL/Pool.hs +++ b/server/src-lib/Database/MSSQL/Pool.hs @@ -12,6 +12,7 @@ module Database.MSSQL.Pool ) where +import Autodocodec (HasCodec (codec), dimapCodec) import Control.Exception.Lifted import Control.Monad.Trans.Control import Data.Aeson @@ -24,6 +25,9 @@ import Prelude newtype ConnectionString = ConnectionString {unConnectionString :: Text} deriving (Show, Eq, ToJSON, FromJSON, Generic) +instance HasCodec ConnectionString where + codec = dimapCodec ConnectionString unConnectionString codec + data ConnectionOptions = ConnectionOptions { _coConnections :: Int, _coStripes :: Int, diff --git a/server/src-lib/Hasura/Backends/BigQuery/Source.hs b/server/src-lib/Hasura/Backends/BigQuery/Source.hs index f7214d33fa1..bfb533dafa1 100644 --- a/server/src-lib/Hasura/Backends/BigQuery/Source.hs +++ b/server/src-lib/Hasura/Backends/BigQuery/Source.hs @@ -18,7 +18,7 @@ module Hasura.Backends.BigQuery.Source ) where -import Autodocodec (HasCodec, codec, named) +import Autodocodec import Control.Concurrent.MVar import Crypto.PubKey.RSA.Types qualified as Cry import Data.Aeson qualified as J @@ -27,11 +27,12 @@ import Data.Aeson.KeyMap qualified as KM import Data.Aeson.TH qualified as J import Data.ByteString.Lazy qualified as BL import Data.Int qualified as Int +import Data.Scientific (Scientific) import Data.Text.Encoding qualified as TE import Data.X509 qualified as X509 import Data.X509.Memory qualified as X509 import Hasura.Incremental (Cacheable (..)) -import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON) +import Hasura.Metadata.DTO.Utils (fromEnvCodec) import Hasura.Prelude data PKey = PKey @@ -52,6 +53,13 @@ deriving instance Hashable Cry.PrivateKey -- orphan deriving instance Hashable Cry.PublicKey -- orphan +instance HasCodec PKey where + codec = bimapCodec dec originalBS codec + where + dec k = case X509.readKeyFileFromMemory $ TE.encodeUtf8 k of + [X509.PrivKeyRSA k'] -> Right $ PKey k' k + _ -> Left "unable to parse private key" + instance J.FromJSON PKey where parseJSON = J.withText "private_key" $ \k -> case X509.readKeyFileFromMemory $ TE.encodeUtf8 k of @@ -84,6 +92,14 @@ data ServiceAccount = ServiceAccount } deriving (Eq, Show, Data, NFData, Generic, Hashable) +instance HasCodec ServiceAccount where + codec = + object "BigQueryServiceAccount" $ + ServiceAccount + <$> requiredField' "client_email" .= _saClientEmail + <*> requiredField' "private_key" .= _saPrivateKey + <*> requiredField' "project_id" .= _saProjectId + $(J.deriveJSON (J.aesonDrop 3 J.snakeCase) {J.omitNothingFields = False} ''ServiceAccount) data ConfigurationJSON a @@ -92,6 +108,54 @@ data ConfigurationJSON a deriving stock (Show, Eq, Generic) deriving (NFData, Hashable) +-- This codec has straightforward encoding, but on decoding there is +-- a possibility of receiving a string that contains JSON that is recursively +-- handled by this codec. There is also the issue that decoding the +-- @FromYamlJSON@ case should be attempted last because there is a possibility +-- that the decoding for @a@ is not disjoint from the other decoding cases. This +-- presents some asymmetry that is a little tricky to capture in a codec. +instance HasCodec a => HasCodec (ConfigurationJSON a) where + codec = parseAlternative (parseAlternative mainCodec fromEnvEncodedAsNestedJSON) yamlJSONCodec + where + -- This is the only codec in this implementation that is used for + -- encoding. It must cover both the @FromEnvJSON@ and @FromYamlJSON@ cases + -- because Autodocodec does not support codecs that are partial in + -- encoding. + mainCodec :: JSONCodec (ConfigurationJSON a) + mainCodec = + dimapCodec dec enc $ + eitherCodec + fromEnvCodec + ( bimapCodec + -- Fail parsing at this point because @codec \@a@ should only be + -- used for parsing after trying @fromEnvEncodedAsNestedJSON@. + (const $ Left "not used for parsing") + id + $ codec @a + ) + where + dec (Left text) = FromEnvJSON text + dec (Right a) = FromYamlJSON a + + enc (FromEnvJSON i) = Left i + enc (FromYamlJSON j) = Right j + + -- The JSON-encoded string case is used as an alternative in + -- a 'parseAlternative' because we can implement the decoding direction, + -- but not the encoding direction. (There isn't a good way to implement + -- @ConfigurationJSON a -> Text@.) Fortunately an alternative in + -- a 'parseAlternative' is only used for decoding so we don't need to + -- implement encoding logic here. + fromEnvEncodedAsNestedJSON :: ValueCodec Text (ConfigurationJSON a) + fromEnvEncodedAsNestedJSON = + bimapCodec + (eitherDecodeJSONViaCodec . BL.fromStrict . TE.encodeUtf8) + id + $ codec @Text "JSON-encoded string" + + yamlJSONCodec :: ValueCodec a (ConfigurationJSON a) + yamlJSONCodec = FromYamlJSON <$> codec @a + instance J.FromJSON a => J.FromJSON (ConfigurationJSON a) where parseJSON = \case J.Object o | Just (J.String text) <- KM.lookup "from_env" o -> pure (FromEnvJSON text) @@ -105,7 +169,7 @@ instance J.ToJSON a => J.ToJSON (ConfigurationJSON a) where FromEnvJSON i -> J.object ["from_env" J..= i] FromYamlJSON j -> J.toJSON j --- | Configuration inputs when they are a YAML array or an Env var whos value is +-- | Configuration inputs when they are a YAML array or an Env var whose value is -- a comma-separated string data ConfigurationInputs = FromYamls [Text] @@ -113,6 +177,15 @@ data ConfigurationInputs deriving stock (Show, Eq, Generic) deriving (NFData, Hashable) +instance HasCodec ConfigurationInputs where + codec = + dimapCodec + (either FromYamls FromEnvs) + (\case FromYamls i -> Left i; FromEnvs i -> Right i) + $ disjointEitherCodec + (codec @[Text]) + fromEnvCodec + instance J.ToJSON ConfigurationInputs where toJSON = \case FromYamls i -> J.toJSON i @@ -125,13 +198,25 @@ instance J.FromJSON ConfigurationInputs where _ -> fail "one of array or object must be provided" -- | Configuration input when the YAML value as well as the Env var have --- singlular values +-- singular values data ConfigurationInput = FromYaml Text | FromEnv Text deriving stock (Show, Eq, Generic) deriving (NFData, Hashable) +instance HasCodec ConfigurationInput where + codec = + dimapCodec + (either FromYaml FromEnv) + (\case FromYaml i -> Left i; FromEnv i -> Right i) + $ disjointEitherCodec fromYamls fromEnvCodec + where + fromYamls = + parseAlternative + (codec @Text) + (tshow <$> codec @Scientific) + instance J.ToJSON ConfigurationInput where toJSON = \case FromYaml i -> J.toJSON i @@ -159,7 +244,15 @@ $(J.deriveJSON (J.aesonDrop 4 J.snakeCase) {J.omitNothingFields = True} ''BigQue -- TODO: Write a proper codec, and use it to derive FromJSON and ToJSON -- instances. instance HasCodec BigQueryConnSourceConfig where - codec = named "BigQueryConnSourceConfig" $ placeholderCodecViaJSON + codec = + object "BigQueryConnSourceConfig" $ + BigQueryConnSourceConfig + <$> requiredField' "service_account" .= _cscServiceAccount + <*> requiredField' "datasets" .= _cscDatasets + <*> requiredField' "project_id" .= _cscProjectId + <*> optionalFieldOrNull' "global_select_limit" .= _cscGlobalSelectLimit + <*> optionalFieldOrNull' "retry_base_delay" .= _cscRetryBaseDelay + <*> optionalFieldOrNull' "retry_limit" .= _cscRetryLimit deriving instance Show BigQueryConnSourceConfig diff --git a/server/src-lib/Hasura/Backends/MSSQL/Connection.hs b/server/src-lib/Hasura/Backends/MSSQL/Connection.hs index 0c7389ccce7..39098f93499 100644 --- a/server/src-lib/Hasura/Backends/MSSQL/Connection.hs +++ b/server/src-lib/Hasura/Backends/MSSQL/Connection.hs @@ -23,7 +23,8 @@ module Hasura.Backends.MSSQL.Connection ) where -import Autodocodec (HasCodec (codec), named) +import Autodocodec (HasCodec (codec), dimapCodec, disjointEitherCodec, optionalFieldOrNull', optionalFieldWithDefault', requiredField') +import Autodocodec qualified as AC import Control.Monad.Morph (hoist) import Control.Monad.Trans.Control import Data.Aeson @@ -38,7 +39,7 @@ import Database.ODBC.SQLServer qualified as ODBC import Hasura.Backends.MSSQL.SQL.Error import Hasura.Base.Error import Hasura.Incremental (Cacheable (..)) -import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON) +import Hasura.Metadata.DTO.Utils (fromEnvCodec) import Hasura.Prelude class MonadError QErr m => MonadMSSQLTx m where @@ -79,6 +80,13 @@ instance Hashable InputConnectionString instance NFData InputConnectionString +instance HasCodec InputConnectionString where + codec = + dimapCodec + (either RawString FromEnvironment) + (\case RawString m -> Left m; FromEnvironment wEnv -> Right wEnv) + $ disjointEitherCodec codec fromEnvCodec + instance ToJSON InputConnectionString where toJSON = \case @@ -112,6 +120,13 @@ instance FromJSON MSSQLPoolSettings where <$> o .:? "max_connections" .!= _mpsMaxConnections defaultMSSQLPoolSettings <*> o .:? "idle_timeout" .!= _mpsIdleTimeout defaultMSSQLPoolSettings +instance HasCodec MSSQLPoolSettings where + codec = + AC.object "MSSQLPoolSettings" $ + MSSQLPoolSettings + <$> optionalFieldWithDefault' "max_connections" (_mpsMaxConnections defaultMSSQLPoolSettings) AC..= _mpsMaxConnections + <*> optionalFieldWithDefault' "idle_timeout" (_mpsMaxConnections defaultMSSQLPoolSettings) AC..= _mpsIdleTimeout + defaultMSSQLPoolSettings :: MSSQLPoolSettings defaultMSSQLPoolSettings = MSSQLPoolSettings @@ -131,6 +146,13 @@ instance Hashable MSSQLConnectionInfo instance NFData MSSQLConnectionInfo +instance HasCodec MSSQLConnectionInfo where + codec = + AC.object "MSSQLConnectionInfo" $ + MSSQLConnectionInfo + <$> requiredField' "connection_string" AC..= _mciConnectionString + <*> requiredField' "pool_settings" AC..= _mciPoolSettings + $(deriveToJSON hasuraJSON ''MSSQLConnectionInfo) instance FromJSON MSSQLConnectionInfo where @@ -151,12 +173,14 @@ instance Hashable MSSQLConnConfiguration instance NFData MSSQLConnConfiguration -$(deriveJSON hasuraJSON {omitNothingFields = True} ''MSSQLConnConfiguration) - --- TODO: Write a proper codec, and use it to derive FromJSON and ToJSON --- instances. instance HasCodec MSSQLConnConfiguration where - codec = named "MSSQLConnConfiguration" $ placeholderCodecViaJSON + codec = + AC.object "MSSQLConnConfiguration" $ + MSSQLConnConfiguration + <$> requiredField' "connection_info" AC..= _mccConnectionInfo + <*> optionalFieldOrNull' "read_replicas" AC..= _mccReadReplicas + +$(deriveJSON hasuraJSON {omitNothingFields = True} ''MSSQLConnConfiguration) createMSSQLPool :: MonadIO m => diff --git a/server/src-lib/Hasura/Backends/MSSQL/Instances/Types.hs b/server/src-lib/Hasura/Backends/MSSQL/Instances/Types.hs index d223efa34f2..a79cc4c168d 100644 --- a/server/src-lib/Hasura/Backends/MSSQL/Instances/Types.hs +++ b/server/src-lib/Hasura/Backends/MSSQL/Instances/Types.hs @@ -5,6 +5,7 @@ -- Defines a 'Hasura.RQL.Types.Backend.Backend' type class instance for MSSQL. module Hasura.Backends.MSSQL.Instances.Types () where +import Autodocodec (codec) import Data.Aeson import Data.Text.Casing (GQLNameIdentifier) import Database.ODBC.SQLServer qualified as ODBC @@ -14,7 +15,6 @@ 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 @@ -66,7 +66,7 @@ instance Backend 'MSSQL where Just $ HealthCheckImplementation { _hciDefaultTest = defaultHealthCheckTestSql, - _hciTestCodec = placeholderCodecViaJSON + _hciTestCodec = codec } isComparableType :: ScalarType 'MSSQL -> Bool diff --git a/server/src-lib/Hasura/Backends/MySQL/Types/Instances.hs b/server/src-lib/Hasura/Backends/MySQL/Types/Instances.hs index 463c7aab956..970055711ca 100644 --- a/server/src-lib/Hasura/Backends/MySQL/Types/Instances.hs +++ b/server/src-lib/Hasura/Backends/MySQL/Types/Instances.hs @@ -5,7 +5,8 @@ -- | Instances that're slow to compile. module Hasura.Backends.MySQL.Types.Instances () where -import Autodocodec (HasCodec (codec), named) +import Autodocodec (HasCodec (codec), optionalFieldWithDefault', requiredField, requiredField') +import Autodocodec qualified as AC import Control.DeepSeq import Data.Aeson qualified as J import Data.Aeson.Casing qualified as J @@ -20,7 +21,6 @@ import Hasura.Backends.MySQL.Types.Internal import Hasura.Base.ErrorValue qualified as ErrorValue import Hasura.Base.ToErrorValue import Hasura.Incremental.Internal.Dependency -import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON) import Hasura.Prelude import Language.Haskell.TH import Language.Haskell.TH.Syntax @@ -196,6 +196,13 @@ instance Semigroup Top where (<>) x NoTop = x (<>) (Top x) (Top y) = Top (min x y) +instance HasCodec ConnPoolSettings where + codec = + AC.object "MySQLConnPoolSettings" $ + ConnPoolSettings + <$> optionalFieldWithDefault' "idle_timeout" (_cscIdleTimeout defaultConnPoolSettings) AC..= _cscIdleTimeout + <*> optionalFieldWithDefault' "max_connections" (_cscMaxConnections defaultConnPoolSettings) AC..= _cscMaxConnections + instance J.FromJSON ConnPoolSettings where parseJSON = J.withObject "MySQL pool settings" $ \o -> ConnPoolSettings @@ -211,12 +218,20 @@ instance J.ToJSON Expression where instance J.FromJSON Expression where parseJSON value = ValueExpression <$> J.parseJSON value -$(J.deriveJSON (J.aesonDrop 4 J.snakeCase) {J.omitNothingFields = False} ''ConnSourceConfig) - --- TODO: Write a proper codec, and use it to derive FromJSON and ToJSON --- instances. instance HasCodec ConnSourceConfig where - codec = named "MySQLConnConfiguration" $ placeholderCodecViaJSON + codec = + AC.object "MySQLConnSourceConfig" $ + ConnSourceConfig + <$> requiredField "host" hostDoc AC..= _cscHost + <*> requiredField' "port" AC..= _cscPort + <*> requiredField' "user" AC..= _cscUser + <*> requiredField' "password" AC..= _cscPassword + <*> requiredField' "database" AC..= _cscDatabase + <*> requiredField' "pool_settings" AC..= _cscPoolSettings + where + hostDoc = "Works with `127.0.0.1` but not with `localhost`: https://mariadb.com/kb/en/troubleshooting-connection-issues/#localhost-and" + +$(J.deriveJSON (J.aesonDrop 4 J.snakeCase) {J.omitNothingFields = False} ''ConnSourceConfig) instance J.ToJSON (Pool Connection) where toJSON = const (J.String "_REDACTED_") diff --git a/server/src-lib/Hasura/Backends/Postgres/Connection/Settings.hs b/server/src-lib/Hasura/Backends/Postgres/Connection/Settings.hs index 4ea00e016d7..96e9c399e79 100644 --- a/server/src-lib/Hasura/Backends/Postgres/Connection/Settings.hs +++ b/server/src-lib/Hasura/Backends/Postgres/Connection/Settings.hs @@ -48,7 +48,6 @@ import Data.Time.Clock.Compat () import Database.PG.Query qualified as PG import Hasura.Base.Instances () import Hasura.Incremental (Cacheable (..)) -import Hasura.Metadata.DTO.Placeholder (placeholderCodecViaJSON) import Hasura.Prelude import Hasura.RQL.Types.Common (UrlConf (..)) import Hasura.SQL.Types (ExtensionsSchema (..)) @@ -328,7 +327,7 @@ instance HasCodec PostgresSourceConnInfo where CommentCodec "https://hasura.io/docs/latest/graphql/core/api-reference/syntax-defs.html#pgsourceconnectioninfo" $ AC.object "PostgresSourceConnInfo" $ PostgresSourceConnInfo - <$> requiredFieldWith "database_url" placeholderCodecViaJSON databaseUrlDoc .== _psciDatabaseUrl + <$> requiredField "database_url" databaseUrlDoc .== _psciDatabaseUrl <*> optionalFieldOrNull "pool_settings" poolSettingsDoc .== _psciPoolSettings <*> optionalFieldWithOmittedDefault "use_prepared_statements" False usePreparedStatementsDoc .== _psciUsePreparedStatements <*> optionalFieldWithOmittedDefault "isolation_level" PG.ReadCommitted isolationLevelDoc .== _psciIsolationLevel diff --git a/server/src-lib/Hasura/Backends/Postgres/Instances/Types.hs b/server/src-lib/Hasura/Backends/Postgres/Instances/Types.hs index 1484af5bbb2..1a0d9b898f3 100644 --- a/server/src-lib/Hasura/Backends/Postgres/Instances/Types.hs +++ b/server/src-lib/Hasura/Backends/Postgres/Instances/Types.hs @@ -9,7 +9,7 @@ module Hasura.Backends.Postgres.Instances.Types ) where -import Autodocodec (HasCodec) +import Autodocodec (HasCodec (codec)) import Data.Aeson (FromJSON) import Data.Aeson qualified as J import Data.Kind (Type) @@ -25,7 +25,6 @@ import Hasura.Backends.Postgres.Types.Function qualified as Postgres import Hasura.Backends.Postgres.Types.Insert qualified as Postgres (BackendInsert) import Hasura.Backends.Postgres.Types.Update qualified as Postgres 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 @@ -116,7 +115,7 @@ instance Just $ HealthCheckImplementation { _hciDefaultTest = defaultHealthCheckTestSql, - _hciTestCodec = placeholderCodecViaJSON + _hciTestCodec = codec } isComparableType = Postgres.isComparableType diff --git a/server/src-lib/Hasura/Metadata/DTO/Utils.hs b/server/src-lib/Hasura/Metadata/DTO/Utils.hs index 8b5e17da81b..611ebea45e0 100644 --- a/server/src-lib/Hasura/Metadata/DTO/Utils.hs +++ b/server/src-lib/Hasura/Metadata/DTO/Utils.hs @@ -1,10 +1,19 @@ -- | Utility functions for use defining autodocodec codecs. -module Hasura.Metadata.DTO.Utils (codecNamePrefix, versionField, optionalVersionField) where +module Hasura.Metadata.DTO.Utils + ( codecNamePrefix, + fromEnvCodec, + versionField, + optionalVersionField, + ) +where import Autodocodec ( Codec (EqCodec), + JSONCodec, ObjectCodec, + object, optionalFieldWith', + requiredField', requiredFieldWith', scientificCodec, (.=), @@ -38,3 +47,13 @@ optionalVersionField v = -- database kind from type context. codecNamePrefix :: forall b. (HasTag b) => Text codecNamePrefix = T.toTitle $ T.toTxt $ reify $ backendTag @b + +-- | Represents a text field wrapped in an object with a single property +-- named @from_env@. +-- +-- Objects of this form appear in many places in the Metadata API. If we +-- reproduced this codec in each use case the OpenAPI document would have many +-- identical object definitions. Using a shared codec allows a single shared +-- reference. +fromEnvCodec :: JSONCodec Text +fromEnvCodec = object "FromEnv" $ requiredField' "from_env" diff --git a/server/src-lib/Hasura/RQL/Types/Common.hs b/server/src-lib/Hasura/RQL/Types/Common.hs index 403878bd3b6..6c0f75493fa 100644 --- a/server/src-lib/Hasura/RQL/Types/Common.hs +++ b/server/src-lib/Hasura/RQL/Types/Common.hs @@ -43,7 +43,8 @@ module Hasura.RQL.Types.Common ) where -import Autodocodec (HasCodec (codec), dimapCodec) +import Autodocodec (HasCodec (codec), bimapCodec, dimapCodec, disjointEitherCodec, optionalFieldOrNull', requiredField') +import Autodocodec qualified as AC import Data.Aeson import Data.Aeson qualified as J import Data.Aeson.Casing @@ -63,6 +64,7 @@ import Hasura.Base.ToErrorValue import Hasura.EncJSON import Hasura.GraphQL.Schema.Options qualified as Options import Hasura.Incremental (Cacheable (..)) +import Hasura.Metadata.DTO.Utils (fromEnvCodec) import Hasura.Prelude import Hasura.RQL.DDL.Headers () import Language.GraphQL.Draft.Syntax qualified as G @@ -284,6 +286,15 @@ instance Cacheable InputWebhook instance Hashable InputWebhook +instance HasCodec InputWebhook where + codec = dimapCodec InputWebhook unInputWebhook urlTemplateCodec + where + urlTemplateCodec = + bimapCodec + (mapLeft ("Parsing URL template failed: " ++) . parseURLTemplate) + printURLTemplate + codec + instance ToJSON InputWebhook where toJSON = String . printURLTemplate . unInputWebhook @@ -336,6 +347,16 @@ instance Cacheable PGConnectionParams instance Hashable PGConnectionParams +instance HasCodec PGConnectionParams where + codec = + AC.object "PGConnectionParams" $ + PGConnectionParams + <$> requiredField' "host" AC..= _pgcpHost + <*> requiredField' "username" AC..= _pgcpUsername + <*> optionalFieldOrNull' "password" AC..= _pgcpPassword + <*> requiredField' "port" AC..= _pgcpPort + <*> requiredField' "database" AC..= _pgcpDatabase + $(deriveToJSON hasuraJSON {omitNothingFields = True} ''PGConnectionParams) instance FromJSON PGConnectionParams where @@ -362,6 +383,22 @@ instance Cacheable UrlConf instance Hashable UrlConf +instance HasCodec UrlConf where + codec = + dimapCodec dec enc $ + disjointEitherCodec valCodec $ disjointEitherCodec fromEnvCodec fromParamsCodec + where + valCodec = codec + fromParamsCodec = AC.object "UrlConfFromParams" $ requiredField' "connection_parameters" + + dec (Left w) = UrlValue w + dec (Right (Left wEnv)) = UrlFromEnv wEnv + dec (Right (Right wParams)) = UrlFromParams wParams + + enc (UrlValue w) = Left w + enc (UrlFromEnv wEnv) = Right $ Left wEnv + enc (UrlFromParams wParams) = Right $ Right wParams + instance ToJSON UrlConf where toJSON (UrlValue w) = toJSON w toJSON (UrlFromEnv wEnv) = object ["from_env" .= wEnv] diff --git a/server/src-lib/Hasura/RQL/Types/HealthCheck.hs b/server/src-lib/Hasura/RQL/Types/HealthCheck.hs index 4a059f1531d..cab1cd48be6 100644 --- a/server/src-lib/Hasura/RQL/Types/HealthCheck.hs +++ b/server/src-lib/Hasura/RQL/Types/HealthCheck.hs @@ -27,6 +27,12 @@ newtype HealthCheckTestSql = HealthCheckTestSql } deriving (Eq, Generic, Show, Cacheable, Hashable, NFData) +instance HasCodec HealthCheckTestSql where + codec = + AC.object "HealthCheckTestSql" $ + HealthCheckTestSql + <$> optionalFieldWithDefault' "sql" defaultTestSql AC..= _hctSql + instance ToJSON HealthCheckTestSql where toJSON = genericToJSON hasuraJSON {omitNothingFields = True} diff --git a/server/src-test/Hasura/Backends/BigQuery/SourceSpec.hs b/server/src-test/Hasura/Backends/BigQuery/SourceSpec.hs new file mode 100644 index 00000000000..180bf249cfb --- /dev/null +++ b/server/src-test/Hasura/Backends/BigQuery/SourceSpec.hs @@ -0,0 +1,127 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +module Hasura.Backends.BigQuery.SourceSpec (spec) where + +import Autodocodec (HasCodec (codec), eitherDecodeJSONViaCodec, object, requiredField', toJSONViaCodec, (.=)) +import Data.Aeson (FromJSON, ToJSON (toJSON), Value, eitherDecode, encode) +import Data.Aeson qualified as J +import Data.Aeson.Casing qualified as J +import Data.Aeson.QQ (aesonQQ) +import Data.Aeson.TH qualified as J +import Data.ByteString.Lazy (ByteString) +import Data.Text.Lazy.Encoding (decodeUtf8) +import Hasura.Backends.BigQuery.Source (ConfigurationInput (FromEnv), ConfigurationJSON (..)) +import Hasura.Prelude +import Test.Hspec + +-- ConfigurationJSON is used with the real ServiceAccount type - but that type +-- has a private key property that is obnoxious to get a mock value for. +data MockServiceAccount = MockServiceAccount + { _msaClientEmail :: Text, + _msaPrivateKey :: Text, + _msaProjectId :: Text + } + deriving (Eq, Show) + +instance HasCodec MockServiceAccount where + codec = + object "MockServiceAccount" $ + MockServiceAccount + <$> requiredField' "client_email" .= _msaClientEmail + <*> requiredField' "private_key" .= _msaPrivateKey + <*> requiredField' "project_id" .= _msaProjectId + +$(J.deriveJSON (J.aesonDrop 4 J.snakeCase) {J.omitNothingFields = False} ''MockServiceAccount) + +spec :: Spec +spec = do + describe "BigQuery" do + describe "HasCodec (ConfigurationJSON a)" do + it "should accept text from a @from_env@ property" do + let input = encode $ [aesonQQ|{"from_env": "config text"}|] + input `shouldDecodeTo` FromEnvJSON @(ConfigurationJSON MockServiceAccount) "config text" + + it "should accept data parsed via underlying codec" do + let clientEmail = "client@test.net" + let privateKey = "-----BEGIN RSA PRIVATE KEY----- etc." + let projectId = "2" + let input = + encode $ + [aesonQQ| + { client_email: #{clientEmail}, + private_key: #{privateKey}, + project_id: #{projectId} + } + |] + input + `shouldDecodeTo` FromYamlJSON + ( MockServiceAccount clientEmail privateKey projectId + ) + + it "should accept a string containing a serialized object with a @from_env@ property" do + let input = "{\"from_env\":\"config text\"}" + input `shouldDecodeTo` FromEnvJSON @(ConfigurationJSON MockServiceAccount) "config text" + + it "should accept a string containing a serialized value parsed via underlying codec" do + let clientEmail = "client@test.net" + let privateKey = "-----BEGIN RSA PRIVATE KEY----- etc." + let projectId = "2" + let input = + decodeUtf8 $ + encode $ + [aesonQQ| + { client_email: #{clientEmail}, + private_key: #{privateKey}, + project_id: #{projectId} + } + |] + let stringInput = encode input + stringInput + `shouldDecodeTo` FromYamlJSON + ( MockServiceAccount clientEmail privateKey projectId + ) + + it "should encode to an object with a @from_env@ property" do + let output = FromEnv "config text" + output `shouldEncodeTo` [aesonQQ|{from_env: "config text"}|] + + it "should encode via the underlying codec" do + let clientEmail = "client@test.net" + let privateKey = "-----BEGIN RSA PRIVATE KEY----- etc." + let projectId = "2" + let output = FromYamlJSON $ MockServiceAccount clientEmail privateKey projectId + output + `shouldEncodeTo` [aesonQQ| + { client_email: #{clientEmail}, + private_key: #{privateKey}, + project_id: #{projectId} + } + |] + +-- | Assert that the given bytestring decodes to the expected value when +-- decoding via Autodocodec, and that the decoded value matches decoding via a +-- FromJSON instance. +shouldDecodeTo :: + forall a. + (Eq a, FromJSON a, HasCodec a, Show a) => + ByteString -> + a -> + Expectation +input `shouldDecodeTo` expected = do + decoded `shouldBe` (Right expected) + decoded `shouldBe` decodedViaFromJSON + where + decoded = eitherDecodeJSONViaCodec @a input + decodedViaFromJSON = eitherDecode @a input + +-- | Assert that the given value encodes to the expected JSON value when +-- encoding via Autodocodec, and that the encoded value matches encoding via +-- a ToJSON instance. +shouldEncodeTo :: forall a. (HasCodec a, ToJSON a) => a -> Value -> Expectation +output `shouldEncodeTo` expected = do + encoded `shouldBe` expected + encoded `shouldBe` encodedViaToJSON + where + encoded = toJSONViaCodec output + encodedViaToJSON = toJSON output