diff --git a/CHANGELOG.md b/CHANGELOG.md index 21cc6d33d35..93fffc4c3e9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,7 @@ ## v2.0.4 +- server: Adding support for TLS allowlist by domain and service id (port) - server: Support computed fields in permission check/filter (close #7102) - server: support computed fields in query 'order_by' (close #7103) - server: log warning if there are errors while executing clean up actions after "drop source" (previously it would throw an error) diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 9e668ce90fd..23cdb748232 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -272,9 +272,12 @@ library -- bigquery support , memory , x509-store - + , connection + , tls + , x509-validation + , data-default-class + , x509-system , tagged - -- mysql , mysql , mysql-simple @@ -481,6 +484,7 @@ library , Hasura.RQL.Types.Metadata.Backend , Hasura.RQL.Types.Metadata.Instances , Hasura.RQL.Types.Metadata.Object + , Hasura.RQL.Types.Network , Hasura.RQL.Types.Permission , Hasura.RQL.Types.QueryCollection , Hasura.RQL.Types.QueryTags diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index 215d5c3f0ef..dbddaf4aea5 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -57,7 +57,10 @@ runApp :: Env.Environment -> HGEOptions Hasura -> IO () runApp env (HGEOptionsG rci metadataDbUrl hgeCmd) = do initTime <- liftIO getCurrentTime globalCtx@GlobalCtx{..} <- initGlobalCtx env metadataDbUrl rci - let (maybeDefaultPgConnInfo, maybeRetries) = _gcDefaultPostgresConnInfo + let + (maybeDefaultPgConnInfo, maybeRetries) = _gcDefaultPostgresConnInfo + httpMgr = manager _gcHttpMgrAndTlsAllowList + tlsAllowlist = allowList _gcHttpMgrAndTlsAllowList withVersion $$(getVersionFromEnvironment) $ case hgeCmd of HCServe serveOptions -> do @@ -122,14 +125,14 @@ runApp env (HGEOptionsG rci metadataDbUrl hgeCmd) = do serverConfigCtx = ServerConfigCtx functionPermsCtx remoteSchemaPermsCtx sqlGenCtx maintenanceMode mempty cacheBuildParams = - CacheBuildParams _gcHttpManager pgSourceResolver serverConfigCtx + CacheBuildParams httpMgr pgSourceResolver serverConfigCtx runManagedT (mkMinimalPool _gcMetadataDbConnInfo) $ \metadataDbPool -> do res <- flip runPGMetadataStorageAppT (metadataDbPool, pgLogger) $ runMetadataStorageT $ liftEitherM do (metadata, _) <- fetchMetadata - runAsAdmin _gcHttpManager serverConfigCtx $ do + runAsAdmin httpMgr serverConfigCtx $ do schemaCache <- runCacheBuild cacheBuildParams $ - buildRebuildableSchemaCache env metadata + buildRebuildableSchemaCache env metadata tlsAllowlist execQuery env queryBs & Tracing.runTraceTWithReporter Tracing.noReporter "execute" & runMetadataT metadata diff --git a/server/src-lib/Hasura/App.hs b/server/src-lib/Hasura/App.hs index 2e1a7098a5b..1a5351f9808 100644 --- a/server/src-lib/Hasura/App.hs +++ b/server/src-lib/Hasura/App.hs @@ -12,19 +12,27 @@ import qualified Control.Exception.Lifted as LE import qualified Data.Aeson as A import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.Default.Class as HTTP import qualified Data.Environment as Env import qualified Data.HashMap.Strict as HM import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Time.Clock as Clock +import qualified Data.X509 as HTTP +import qualified Data.X509.CertificateStore as HTTP +import qualified Data.X509.Validation as HTTP import qualified Data.Yaml as Y import qualified Database.PG.Query as Q +import qualified Network.Connection as HTTP import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP +import qualified Network.TLS as HTTP +import qualified Network.TLS.Extra as TLS import qualified Network.Wai.Handler.Warp as Warp import qualified System.Log.FastLogger as FL import qualified System.Metrics as EKG import qualified System.Metrics.Gauge as EKG.Gauge +import qualified System.X509 as HTTP import qualified Text.Mustache.Compile as M import qualified Web.Spock.Core as Spock @@ -40,9 +48,9 @@ import Control.Monad.Trans.Managed (ManagedT (..)) import Control.Monad.Unique import Data.FileEmbed (makeRelativeToProject) import Data.Time.Clock (UTCTime) -#ifndef PROFILING + import GHC.AssertNF -#endif + import Network.HTTP.Client.Extended import Options.Applicative import System.Environment (getEnvironment) @@ -72,6 +80,8 @@ import Hasura.RQL.DDL.Schema.Cache import Hasura.RQL.DDL.Schema.Cache.Common import Hasura.RQL.DDL.Schema.Catalog import Hasura.RQL.Types +import Hasura.RQL.Types.Network (TlsAllow (TlsAllow), + TlsPermission (SelfSigned)) import Hasura.RQL.Types.Run import Hasura.Server.API.Query (requiresAdmin, runQueryM) import Hasura.Server.App @@ -165,13 +175,72 @@ mkPGLogger (Logger logger) (Q.PLERetryMsg msg) = -- | Context required for all graphql-engine CLI commands data GlobalCtx = GlobalCtx - { _gcHttpManager :: !HTTP.Manager + { _gcHttpMgrAndTlsAllowList :: !HttpMgrWithTlsAllowList , _gcMetadataDbConnInfo :: !Q.ConnInfo , _gcDefaultPostgresConnInfo :: !(Maybe (UrlConf, Q.ConnInfo), Maybe Int) -- ^ --database-url option, @'UrlConf' is required to construct default source configuration -- and optional retries } +data HttpMgrWithTlsAllowList = + HttpMgrWithTlsAllowList + { manager :: HTTP.Manager + , allowList :: TlsAllowList + } + +mkMgr :: IO HttpMgrWithTlsAllowList +mkMgr = do + allowList :: STM.TVar [TlsAllow] <- STM.newTVarIO [] + systemStore <- HTTP.getSystemCertificateStore + let settings = HTTP.mkManagerSettings (tlsSettingsComplex systemStore allowList) Nothing + manager <- HTTP.newManager settings + pure $ HttpMgrWithTlsAllowList manager (TlsAllowList allowList) + + where + tlsSettingsComplex :: HTTP.CertificateStore -> STM.TVar [TlsAllow] -> HTTP.TLSSettings + tlsSettingsComplex systemStore = HTTP.TLSSettings . clientParams systemStore + + clientParams :: HTTP.CertificateStore -> STM.TVar [TlsAllow] -> HTTP.ClientParams + clientParams systemStore allowList = + (HTTP.defaultParamsClient hostName serviceIdBlob) + { HTTP.clientSupported = HTTP.def { HTTP.supportedCiphers = TLS.ciphersuite_default } -- supportedCiphers :: [Cipher] Supported cipher methods. The default is empty, specify a suitable cipher list. ciphersuite_default is often a good choice. Default: [] -- https://hackage.haskell.org/package/tls-1.5.5/docs/Network-TLS.html#t:Cipher + , HTTP.clientShared = HTTP.def { HTTP.sharedCAStore = systemStore } + , HTTP.clientHooks = + HTTP.def + { HTTP.onServerCertificate = (certValidation allowList) + } } + + certValidation :: STM.TVar [TlsAllow] -> HTTP.CertificateStore -> HTTP.ValidationCache -> HTTP.ServiceID -> HTTP.CertificateChain -> IO [HTTP.FailedReason] + certValidation allowList' certStore validationCache sid chain = do + res <- HTTP.onServerCertificate HTTP.def certStore validationCache sid chain + allowList <- STM.readTVarIO allowList' + if any (allowed sid res) allowList + then pure [] + else pure res + + -- These always seem to be overwritten when a connection is established + -- Should leave as errors in this case in order to validate this assumption. + hostName = error "hostname undefined" + serviceIdBlob = error "serviceIdBlob undefined" + + -- Checks that: + -- * the service (host) and service-suffix (port) match + -- * the error response is permitted + allowed :: (String, BC.ByteString) -> [HTTP.FailedReason] -> TlsAllow -> Bool + allowed (sHost, sPort) res (TlsAllow aHost aPort aPermit) = + (sHost == aHost) + && (BC.unpack sPort ==? aPort) + && all (\x -> any (($ x) . permitted) (fromMaybe [SelfSigned] aPermit)) res + -- TODO: Could clean up this check some more. + + permitted SelfSigned HTTP.SelfSigned = True + permitted SelfSigned (HTTP.NameMismatch _) = True + permitted SelfSigned HTTP.LeafNotV3 = True -- TODO: What does this mean???? + permitted SelfSigned _ = False + -- allowed HTTP.UnknownCA = True -- As described in https://hackage.haskell.org/package/tls-0.8.5/docs/src/Network-TLS-Core.html -- This is taken care of by the system certificate set. + + _ ==? Nothing = True + a ==? Just a' = a == a' initGlobalCtx :: (MonadIO m) @@ -182,7 +251,10 @@ initGlobalCtx -- ^ the user's DB URL -> m GlobalCtx initGlobalCtx env metadataDbUrl defaultPgConnInfo = do - httpManager <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings + -- allowList <- liftIO $ STM.newTVarIO [] + -- manager' <- liftIO $ HTTP.newManager HTTP.tlsManagerSettings + -- let manager = HttpMgrWithTlsAllowList manager' (TlsAllowList allowList) + manager <- liftIO $ mkMgr let PostgresConnInfo dbUrlConf maybeRetries = defaultPgConnInfo mkConnInfoFromSource dbUrl = do @@ -193,7 +265,7 @@ initGlobalCtx env metadataDbUrl defaultPgConnInfo = do in (Q.ConnInfo retries . Q.CDDatabaseURI . txtToBs . T.pack) mdbUrl mkGlobalCtx mdbConnInfo sourceConnInfo = - pure $ GlobalCtx httpManager mdbConnInfo (sourceConnInfo, maybeRetries) + pure $ GlobalCtx manager mdbConnInfo (sourceConnInfo, maybeRetries) case (metadataDbUrl, dbUrlConf) of (Nothing, Nothing) -> @@ -228,6 +300,7 @@ data ServeCtx , _scSchemaCache :: !RebuildableSchemaCache , _scSchemaCacheRef :: !SchemaCacheRef , _scMetaVersionRef :: !(STM.TMVar MetadataResourceVersion) + , _scTlsAllowList :: !TlsAllowList } -- | Collection of the LoggerCtx, the regular Logger and the PGLogger @@ -301,13 +374,17 @@ initialiseServeCtx env GlobalCtx{..} so@ServeOptions{..} = do in PostgresConnConfiguration sourceConnInfo Nothing sqlGenCtx = SQLGenCtx soStringifyNum soDangerousBooleanCollapse - let serverConfigCtx = + let + serverConfigCtx = ServerConfigCtx soInferFunctionPermissions soEnableRemoteSchemaPermissions sqlGenCtx soEnableMaintenanceMode soExperimentalFeatures + httpMgr = manager _gcHttpMgrAndTlsAllowList + tlsAllow = allowList _gcHttpMgrAndTlsAllowList + (rebuildableSchemaCache, _) <- lift . flip onException (flushLogger loggerCtx) $ - migrateCatalogSchema env logger metadataDbPool maybeDefaultSourceConfig _gcHttpManager + migrateCatalogSchema env logger metadataDbPool maybeDefaultSourceConfig httpMgr tlsAllow serverConfigCtx (mkPgSourceResolver pgLogger) @@ -323,8 +400,8 @@ initialiseServeCtx env GlobalCtx{..} so@ServeOptions{..} = do schemaCacheRef <- initialiseCache rebuildableSchemaCache - pure $ ServeCtx _gcHttpManager instanceId loggers soEnabledLogTypes metadataDbPool latch - rebuildableSchemaCache schemaCacheRef metaVersionRef + pure $ ServeCtx httpMgr instanceId loggers soEnabledLogTypes metadataDbPool latch + rebuildableSchemaCache schemaCacheRef metaVersionRef tlsAllow mkLoggers :: (MonadIO m, MonadBaseControl IO m) @@ -341,12 +418,17 @@ mkLoggers enabledLogs logLevel = do -- | helper function to initialize or migrate the @hdb_catalog@ schema (used by pro as well) migrateCatalogSchema :: (HasVersion, MonadIO m, MonadBaseControl IO m) - => Env.Environment -> Logger Hasura -> Q.PGPool -> Maybe (SourceConnConfiguration ('Postgres 'Vanilla)) - -> HTTP.Manager -> ServerConfigCtx + => Env.Environment + -> Logger Hasura + -> Q.PGPool + -> Maybe (SourceConnConfiguration ('Postgres 'Vanilla)) + -> HTTP.Manager + -> TlsAllowList + -> ServerConfigCtx -> SourceResolver -> m (RebuildableSchemaCache, UTCTime) migrateCatalogSchema env logger pool defaultSourceConfig - httpManager serverConfigCtx + httpManager tlsAllowlist serverConfigCtx sourceResolver = do currentTime <- liftIO Clock.getCurrentTime initialiseResult <- runExceptT $ do @@ -369,7 +451,7 @@ migrateCatalogSchema env logger pool defaultSourceConfig -- @'CatalogUpdate' re-creates event triggers in the database. if version < 43 then CatalogUpdate else CatalogSync schemaCache <- runCacheBuild cacheBuildParams $ - buildRebuildableSchemaCacheWithReason buildReason env metadata + buildRebuildableSchemaCacheWithReason buildReason env metadata tlsAllowlist pure (migrationResult, schemaCache) (migrationResult, schemaCache) <- @@ -481,9 +563,9 @@ runHGEServer setupHook env ServeOptions{..} ServeCtx{..} initTime postPollHook s -- tool. -- -- NOTE: be sure to compile WITHOUT code coverage, for this to work properly. -#ifndef PROFILING + liftIO disableAssertNF -#endif + let sqlGenCtx = SQLGenCtx soStringifyNum soDangerousBooleanCollapse Loggers loggerCtx logger _ = _scLoggers @@ -520,6 +602,7 @@ runHGEServer setupHook env ServeOptions{..} ServeCtx{..} initTime postPollHook s soEnableMaintenanceMode soExperimentalFeatures _scEnabledLogTypes + (tlsAllowList _scTlsAllowList) let serverConfigCtx = ServerConfigCtx soInferFunctionPermissions diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index 7e3e67f625b..ce9bc6290bf 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -166,7 +166,7 @@ runReplaceMetadataV2 ReplaceMetadataV2{..} = do pure $ Metadata (OMap.singleton defaultSource newDefaultSourceMetadata) _mnsRemoteSchemas _mnsQueryCollections _mnsAllowlist _mnsCustomTypes _mnsActions cronTriggersMetadata (_metaRestEndpoints oldMetadata) - emptyApiLimit emptyMetricsConfig mempty introspectionDisabledRoles queryTagsConfig + emptyApiLimit emptyMetricsConfig mempty introspectionDisabledRoles queryTagsConfig Nothing putMetadata metadata case _rmv2AllowInconsistentMetadata of diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs index 5f7d9c97856..caf574006e6 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs @@ -68,7 +68,8 @@ import Hasura.RQL.DDL.Schema.Function import Hasura.RQL.DDL.Schema.Table import Hasura.RQL.Types hiding (fmFunction, tmTable) import Hasura.SQL.Tag -import Hasura.Server.Types (MaintenanceMode (..)) +import Hasura.Server.Types (MaintenanceMode (..), TlsAllowList (..), + updateTlsAllowlist) import Hasura.Server.Version (HasVersion) import Hasura.Session @@ -77,6 +78,7 @@ buildRebuildableSchemaCache :: HasVersion => Env.Environment -> Metadata + -> TlsAllowList -> CacheBuild RebuildableSchemaCache buildRebuildableSchemaCache = buildRebuildableSchemaCacheWithReason CatalogSync @@ -86,10 +88,12 @@ buildRebuildableSchemaCacheWithReason => BuildReason -> Env.Environment -> Metadata + -> TlsAllowList -> CacheBuild RebuildableSchemaCache -buildRebuildableSchemaCacheWithReason reason env metadata = do +buildRebuildableSchemaCacheWithReason reason env metadata tlsAllowlist = do result <- flip runReaderT reason $ - Inc.build (buildSchemaCacheRule env) (metadata, initialInvalidationKeys) + Inc.build (buildSchemaCacheRule tlsAllowlist env) (metadata, initialInvalidationKeys) + pure $ RebuildableSchemaCache (Inc.result result) initialInvalidationKeys (Inc.rebuildRule result) @@ -153,9 +157,10 @@ buildSchemaCacheRule , MonadReader BuildReason m, HasHttpManagerM m, MonadResolveSource m , HasServerConfigCtx m ) - => Env.Environment + => TlsAllowList + -> Env.Environment -> (Metadata, InvalidationKeys) `arr` SchemaCache -buildSchemaCacheRule env = proc (metadata, invalidationKeys) -> do +buildSchemaCacheRule tlsAllowlist env = proc (metadata, invalidationKeys) -> do invalidationKeysDep <- Inc.newDependency -< invalidationKeys -- Step 1: Process metadata and collect dependency information. @@ -443,7 +448,7 @@ buildSchemaCacheRule env = proc (metadata, invalidationKeys) -> do buildAndCollectInfo = proc (metadata, invalidationKeys) -> do let Metadata sources remoteSchemas collections allowlists customTypes actions cronTriggers endpoints apiLimits metricsConfig inheritedRoles - _introspectionDisabledRoles queryTagsConfig = metadata + _introspectionDisabledRoles queryTagsConfig _tlsWhitelist = metadata actionRoles = map _apmRole . _amPermissions =<< OMap.elems actions remoteSchemaRoles = map _rspmRole . _rsmPermissions =<< OMap.elems remoteSchemas sourceRoles = @@ -586,6 +591,9 @@ buildSchemaCacheRule env = proc (metadata, invalidationKeys) -> do cronTriggersMap <- buildCronTriggers -< ((), OMap.elems cronTriggers) + -- Note: Updates from metadata that include changes to the TLS AllowList will be written here. + bindA -< updateTlsAllowlist tlsAllowlist (metaTlsAllowlist metadata) + returnA -< BuildOutputs { _boSources = M.map fst sourcesOutput , _boActions = actionCache diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs b/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs index c3455d2e8a5..3df993744fb 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/LegacyCatalog.hs @@ -341,9 +341,9 @@ fetchMetadataFromHdbTables = liftTx do -- fetch actions actions <- oMapFromL _amName <$> fetchActions + cronTriggers <- fetchCronTriggers - MetadataNoSources fullTableMetaMap functions remoteSchemas collections - allowlist customTypes actions <$> fetchCronTriggers + pure $ MetadataNoSources fullTableMetaMap functions remoteSchemas collections allowlist customTypes actions cronTriggers where modMetaMap l f xs = do diff --git a/server/src-lib/Hasura/RQL/Types/Metadata.hs b/server/src-lib/Hasura/RQL/Types/Metadata.hs index 71079e412bc..318562edbc7 100644 --- a/server/src-lib/Hasura/RQL/Types/Metadata.hs +++ b/server/src-lib/Hasura/RQL/Types/Metadata.hs @@ -35,6 +35,7 @@ import Hasura.RQL.Types.Function import Hasura.RQL.Types.GraphqlSchemaIntrospection import Hasura.RQL.Types.Metadata.Backend import Hasura.RQL.Types.Metadata.Instances () +import Hasura.RQL.Types.Network import Hasura.RQL.Types.Permission import Hasura.RQL.Types.QueryCollection import Hasura.RQL.Types.QueryTags @@ -333,7 +334,9 @@ data Metadata , _metaInheritedRoles :: !InheritedRoles , _metaSetGraphqlIntrospectionOptions :: !SetGraphqlIntrospectionOptions , _metaQueryTagsConfig :: !QueryTagsConfig + , _metaNetwork :: !(Maybe Network) } deriving (Show, Eq, Generic) + $(makeLenses ''Metadata) instance FromJSON Metadata where @@ -344,23 +347,28 @@ instance FromJSON Metadata where rawSources <- o .: "sources" sources <- oMapFromL getSourceName <$> traverse parseSourceMetadata rawSources endpoints <- oMapFromL _ceName <$> o .:? "rest_endpoints" .!= [] + network <- o .:? "network" (remoteSchemas, queryCollections, allowlist, customTypes, actions, cronTriggers, apiLimits, metricsConfig, inheritedRoles, disabledSchemaIntrospectionRoles, queryTagsConfig) <- parseNonSourcesMetadata o pure $ Metadata sources remoteSchemas queryCollections allowlist customTypes actions cronTriggers endpoints apiLimits metricsConfig inheritedRoles disabledSchemaIntrospectionRoles - queryTagsConfig + queryTagsConfig network 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 = Metadata mempty mempty mempty mempty emptyCustomTypes mempty mempty mempty - emptyApiLimit emptyMetricsConfig mempty mempty emptyQueryTagsConfig + emptyApiLimit emptyMetricsConfig mempty mempty emptyQueryTagsConfig Nothing + +metaTlsAllowlist :: Metadata -> [TlsAllow] +metaTlsAllowlist m = case _metaNetwork m of + (Just m') -> networkTlsAllowlist m' + _ -> [] tableMetadataSetter :: (BackendMetadata b) @@ -442,6 +450,7 @@ metadataToOrdJSON ( Metadata inheritedRoles introspectionDisabledRoles queryTagsConfig + tlsWhitelist ) = AO.object $ [ versionPair , sourcesPair] <> catMaybes [ remoteSchemasPair , queryCollectionsPair @@ -455,6 +464,7 @@ metadataToOrdJSON ( Metadata , inheritedRolesPair , introspectionDisabledRolesPair , queryTagsConfigPair + , networkPair tlsWhitelist ] where versionPair = ("version", AO.toOrdered currentMetadataVersion) @@ -482,6 +492,10 @@ metadataToOrdJSON ( Metadata Nothing (introspectionDisabledRoles == mempty) + networkPair :: Maybe Network -> Maybe (Text, AO.Value) + networkPair (Just n) = Just ("network", AO.toOrdered n) + networkPair _ = Nothing + queryTagsConfigPair = if queryTagsConfig == emptyQueryTagsConfig then Nothing else Just ("query_tags", AO.toOrdered queryTagsConfig) @@ -843,3 +857,4 @@ $(deriveToJSON defaultOptions ''GetCatalogState) instance FromJSON GetCatalogState where parseJSON _ = pure GetCatalogState + diff --git a/server/src-lib/Hasura/RQL/Types/Network.hs b/server/src-lib/Hasura/RQL/Types/Network.hs new file mode 100644 index 00000000000..0936304c883 --- /dev/null +++ b/server/src-lib/Hasura/RQL/Types/Network.hs @@ -0,0 +1,80 @@ +-- | + +module Hasura.RQL.Types.Network where + +import Hasura.Prelude + +import qualified Data.Text as T + +import Data.Aeson as A +import Test.QuickCheck.Arbitrary as Q + + +data Network + = Network + { _nwHttp :: !(Maybe Http) + } deriving (Show, Eq, Generic) + +networkTlsAllowlist :: Network -> [TlsAllow] +networkTlsAllowlist (Network (Just (Http l))) = l +networkTlsAllowlist _ = [] + +instance Q.Arbitrary Network where + -- TODO: Decide if this should be extended to actual arbitrary networks + -- This could prove complicated for testing purposes since the implications + -- Are difficult to test. + arbitrary = pure (Network Nothing) + +instance FromJSON Network where + parseJSON = withObject "Network" $ \o -> Network + <$> o .:? "http" + +instance ToJSON Network where + toJSON (Network h) = object ["http" A..= h] + +data Http + = Http + { _hTlsAllowList :: ![TlsAllow] + } deriving (Show, Eq, Generic) + +instance FromJSON Http where + parseJSON = withObject "HTTP" $ \o -> Http + <$> o .:? "tls_allowlist" .!= [] + +instance ToJSON Http where + toJSON (Http t) = object ["tls_allowlist" A..= t] + +data TlsAllow + = TlsAllow + { taHost :: !String + , taSuffix :: !(Maybe String) + , taPermit :: !(Maybe [TlsPermission]) + } deriving (Show, Eq, Generic) + +instance FromJSON TlsAllow where + parseJSON j = aString j <|> anObject j + where + aString = withText "TlsAllow" $ \s -> pure $ TlsAllow (T.unpack s) Nothing Nothing + anObject = withObject "TlsAllow" $ \o -> TlsAllow + <$> o .: "host" + <*> o .:? "suffix" + <*> o .:? "permissions" + +instance ToJSON TlsAllow where + toJSON (TlsAllow h p a) = object + [ "host" A..= h + , "suffix" A..= p + , "permissions" A..= a + ] + +data TlsPermission + = SelfSigned + deriving (Show, Eq, Generic, Enum, Bounded) + +instance FromJSON TlsPermission where + parseJSON (String "self-signed") = pure SelfSigned + parseJSON _ = fail $ "TlsPermission expecting one of " <> intercalate ", " (map (show :: TlsPermission -> String) [minBound .. maxBound]) + +instance ToJSON TlsPermission where + toJSON SelfSigned = String "self-signed" + diff --git a/server/src-lib/Hasura/Server/API/Metadata.hs b/server/src-lib/Hasura/Server/API/Metadata.hs index 500f4a1e54e..4de9d104d4f 100644 --- a/server/src-lib/Hasura/Server/API/Metadata.hs +++ b/server/src-lib/Hasura/Server/API/Metadata.hs @@ -342,6 +342,7 @@ runMetadataQuery env logger instanceId userInfo httpManager serverConfigCtx sche & peelRun (RunCtx userInfo httpManager serverConfigCtx) & runExceptT & liftEitherM + pure (r, modSchemaCache') MaintenanceModeEnabled -> throw500 "metadata cannot be modified in maintenance mode" diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index b066ec767d9..b7f32f1dbae 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -66,6 +66,7 @@ import Hasura.HTTP import Hasura.Metadata.Class import Hasura.RQL.DDL.Schema import Hasura.RQL.Types +import Hasura.RQL.Types.Network (TlsAllow) import Hasura.Server.API.Config (runGetConfig) import Hasura.Server.API.Metadata import Hasura.Server.API.Query @@ -124,6 +125,7 @@ data ServerCtx , scExperimentalFeatures :: !(S.HashSet ExperimentalFeature) , scEnabledLogTypes :: !(S.HashSet (L.EngineLogType L.Hasura)) -- ^ this is only required for the short-term fix in https://github.com/hasura/graphql-engine-mono/issues/1770 + , scTlsAllowlist :: !(STM.TVar [TlsAllow]) } data HandlerCtx @@ -787,11 +789,12 @@ mkWaiApp -> S.HashSet ExperimentalFeature -- ^ Set of the enabled experimental features -> S.HashSet (L.EngineLogType L.Hasura) + -> STM.TVar [TlsAllow] -> m HasuraApp mkWaiApp setupHook env logger sqlGenCtx enableAL httpManager mode corsCfg enableConsole consoleAssetsDir enableTelemetry instanceId apis lqOpts responseErrorsConfig liveQueryHook schemaCacheRef ekgStore serverMetrics enableRSPermsCtx functionPermsCtx - connectionOptions keepAliveDelay maintenanceMode experimentalFeatures enabledLogTypes = do + connectionOptions keepAliveDelay maintenanceMode experimentalFeatures enabledLogTypes tlsWhitelist = do let getSchemaCache = first lastBuiltSchemaCache <$> readIORef (_scrCache schemaCacheRef) @@ -820,6 +823,7 @@ mkWaiApp setupHook env logger sqlGenCtx enableAL httpManager mode corsCfg enable , scEnableMaintenanceMode = maintenanceMode , scExperimentalFeatures = experimentalFeatures , scEnabledLogTypes = enabledLogTypes + , scTlsAllowlist = tlsWhitelist } spockApp <- liftWithStateless $ \lowerIO -> diff --git a/server/src-lib/Hasura/Server/Migrate.hs b/server/src-lib/Hasura/Server/Migrate.hs index 25022d2b133..229553618dc 100644 --- a/server/src-lib/Hasura/Server/Migrate.hs +++ b/server/src-lib/Hasura/Server/Migrate.hs @@ -281,7 +281,7 @@ migrations maybeDefaultSourceConfig dryRun maintenanceMode = SourceMetadata defaultSource _mnsTables _mnsFunctions defaultSourceConfig in Metadata (OMap.singleton defaultSource defaultSourceMetadata) _mnsRemoteSchemas _mnsQueryCollections _mnsAllowlist _mnsCustomTypes _mnsActions _mnsCronTriggers mempty - emptyApiLimit emptyMetricsConfig mempty mempty emptyQueryTagsConfig + emptyApiLimit emptyMetricsConfig mempty mempty emptyQueryTagsConfig Nothing liftTx $ insertMetadataInCatalog metadataV3 from43To42 = do diff --git a/server/src-lib/Hasura/Server/Types.hs b/server/src-lib/Hasura/Server/Types.hs index 7727dc09f9a..3d15ae43640 100644 --- a/server/src-lib/Hasura/Server/Types.hs +++ b/server/src-lib/Hasura/Server/Types.hs @@ -4,12 +4,14 @@ import Hasura.Prelude import Data.Aeson +import qualified Control.Concurrent.STM as STM import qualified Data.HashSet as Set import qualified Database.PG.Query as Q import qualified Network.HTTP.Types as HTTP import Hasura.RQL.Types.Common import Hasura.RQL.Types.Function +import Hasura.RQL.Types.Network import Hasura.RQL.Types.RemoteSchema import Hasura.Server.Utils @@ -77,3 +79,14 @@ data ServerConfigCtx , _sccMaintenanceMode :: !MaintenanceMode , _sccExperimentalFeatures :: !(Set.HashSet ExperimentalFeature) } deriving (Show, Eq) + +newtype TlsAllowList = + TlsAllowList + { tlsAllowList :: STM.TVar [TlsAllow] + } + +newEmptyTlsAllowlist :: MonadIO m => m TlsAllowList +newEmptyTlsAllowlist = liftIO $ TlsAllowList <$> STM.newTVarIO [] + +updateTlsAllowlist :: MonadIO m => TlsAllowList -> [TlsAllow] -> m () +updateTlsAllowlist (TlsAllowList al) = liftIO . STM.atomically . STM.writeTVar al diff --git a/server/src-test/Hasura/Server/MigrateSpec.hs b/server/src-test/Hasura/Server/MigrateSpec.hs index 04c2e67f30c..6fc5d5f9185 100644 --- a/server/src-test/Hasura/Server/MigrateSpec.hs +++ b/server/src-test/Hasura/Server/MigrateSpec.hs @@ -28,7 +28,7 @@ import Hasura.RQL.Types import Hasura.Server.API.PGDump import Hasura.Server.Init (DowngradeOptions (..)) import Hasura.Server.Migrate -import Hasura.Server.Types (MaintenanceMode (..)) +import Hasura.Server.Types (MaintenanceMode (..), newEmptyTlsAllowlist) import Hasura.Server.Version (HasVersion) import Hasura.Session @@ -88,7 +88,8 @@ spec spec srcConfig pgExecCtx pgConnInfo = do let migrateCatalogAndBuildCache env time = do (migrationResult, metadata) <- runTx pgExecCtx $ migrateCatalog (Just srcConfig) MaintenanceModeDisabled time - (,migrationResult) <$> runCacheBuildM (buildRebuildableSchemaCache env metadata) + tlsAllowlist <- newEmptyTlsAllowlist + (,migrationResult) <$> runCacheBuildM (buildRebuildableSchemaCache env metadata tlsAllowlist) dropAndInit env time = lift $ CacheRefT $ flip modifyMVar \_ -> (runTx pgExecCtx dropHdbCatalogSchema) *> (migrateCatalogAndBuildCache env time) diff --git a/server/src-test/Main.hs b/server/src-test/Main.hs index 7013050abd6..54ed509429c 100644 --- a/server/src-test/Main.hs +++ b/server/src-test/Main.hs @@ -126,7 +126,9 @@ buildPostgresSpecs maybeUrlTemplate = do (metadata, schemaCache) <- run do metadata <- snd <$> (liftEitherM . runExceptT . runLazyTx pgContext Q.ReadWrite) (migrateCatalog (Just sourceConfig) maintenanceMode =<< liftIO getCurrentTime) - schemaCache <- lift $ lift $ buildRebuildableSchemaCache envMap metadata + -- TODO: Decide if this should be passed in via reader + tlsAllowlist <- newEmptyTlsAllowlist + schemaCache <- lift $ lift $ buildRebuildableSchemaCache envMap metadata tlsAllowlist pure (metadata, schemaCache) cacheRef <- newMVar schemaCache