diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs index 979c4f891207da..1f870dfde210a4 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE RecordWildCards #-} module Hasura.RQL.DDL.RemoteRelationship ( runCreateRemoteRelationship @@ -13,7 +13,7 @@ import Hasura.Prelude import Hasura.RQL.DDL.RemoteRelationship.Validate import Hasura.RQL.Types -import qualified Data.HashMap.Strict as HM +import qualified Data.HashMap.Strict as Map import qualified Data.Text as T import Instances.TH.Lift () @@ -27,14 +27,15 @@ runCreateRemoteRelationship remoteRelationship = do runCreateRemoteRelationshipP1 :: (MonadTx m, CacheRM m) => RemoteRelationship -> m (RemoteField, TypeMap) -runCreateRemoteRelationshipP1 remoteRelationship = do +runCreateRemoteRelationshipP1 remoteRel@RemoteRelationship{..}= do sc <- askSchemaCache - case HM.lookup - (rtrRemoteSchema remoteRelationship) + case Map.lookup + rtrRemoteSchema (scRemoteSchemas sc) of - Just {} -> do + Just rsCtx -> do + tableInfo <- onNothing (Map.lookup rtrTable $ scTables sc) $ throw400 NotFound "table not found" validation <- - getCreateRemoteRelationshipValidation remoteRelationship + getCreateRemoteRelationshipValidation remoteRel rsCtx tableInfo case validation of Left err -> throw400 RemoteSchemaError (T.pack (show err)) Right (remoteField, additionalTypesMap) -> diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs index 45fca31e149e47..4a24e55a06ed34 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteRelationship/Validate.hs @@ -14,6 +14,7 @@ module Hasura.RQL.DDL.RemoteRelationship.Validate import Data.Bifunctor import Data.Foldable import Data.List.NonEmpty (NonEmpty (..)) + import Data.Validation import Hasura.GraphQL.Validate.Types import Hasura.Prelude hiding (first) @@ -21,141 +22,124 @@ import Hasura.RQL.Types import Hasura.SQL.Types import qualified Data.HashMap.Strict as HM +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Hasura.GraphQL.Context as GC -import qualified Hasura.GraphQL.Schema as GS import qualified Language.GraphQL.Draft.Syntax as G -- | An error validating the remote relationship. data ValidationError - = CouldntFindRemoteField G.Name ObjTyInfo - | FieldNotFoundInRemoteSchema G.Name + = FieldNotFoundInRemoteSchema G.Name + | FieldNotFoundInType G.Name !ObjTyInfo + | TypeNotFoundInRemoteSchema G.NamedType | NoSuchArgumentForRemote G.Name | MissingRequiredArgument G.Name - | TypeNotFound G.NamedType | TableNotFound !QualifiedTable - | TableFieldNonexistent !QualifiedTable !FieldName + | TableFieldNotFound !QualifiedTable !FieldName | ExpectedTypeButGot !G.GType !G.GType - | InvalidType !G.GType!T.Text + | InvalidType !G.GType !T.Text | InvalidVariable G.Variable (HM.HashMap G.Variable (FieldInfo PGColumnInfo)) | NullNotAllowedHere - | ForeignRelationshipsNotAllowedInRemoteVariable !RelInfo - | RemoteFieldsNotAllowedInArguments !RemoteField - | UnsupportedArgumentType G.Value | InvalidGTypeForStripping !G.GType - | UnsupportedMultipleElementLists + | UnsupportedArgumentType G.Value + | UnsupportedForeignRelationship !RelInfo + | UnsupportedRemoteField !RemoteField | UnsupportedEnum deriving (Show, Eq) -- | Get a validation for the remote relationship proposal. getCreateRemoteRelationshipValidation :: - (QErrM m, CacheRM m) + (QErrM m) => RemoteRelationship + -> RemoteSchemaCtx + -> TableInfo PGColumnInfo -> m (Either (NonEmpty ValidationError) (RemoteField, TypeMap)) -getCreateRemoteRelationshipValidation createRemoteRelationship = do - schemaCache <- askSchemaCache +getCreateRemoteRelationshipValidation remoteRel rsCtx tableInfo = do pure (validateRelationship - createRemoteRelationship - (scDefaultRemoteGCtx schemaCache) - (scTables schemaCache)) + remoteRel + (rscGCtx rsCtx) + tableInfo) -- | Validate a remote relationship given a context. validateRelationship :: RemoteRelationship - -> GC.GCtx - -> HM.HashMap QualifiedTable (TableInfo PGColumnInfo) + -> GC.RemoteGCtx + -> TableInfo PGColumnInfo -> Either (NonEmpty ValidationError) (RemoteField, TypeMap) -validateRelationship remoteRelationship gctx tables = do - case HM.lookup tableName tables of - Nothing -> Left (pure (TableNotFound tableName)) - Just table -> do - fieldInfos <- - fmap - HM.fromList - (traverse - (\fieldName -> - case HM.lookup fieldName (_tiFieldInfoMap table) of - Nothing -> - Left (pure (TableFieldNonexistent tableName fieldName)) - Just fieldInfo -> pure (fieldName, fieldInfo)) - (toList (rtrHasuraFields remoteRelationship))) - (_leafTyInfo, leafGType, (leafParamMap, leafTypeMap)) <- - foldl - (\eitherObjTyInfoAndTypes fieldCall -> - case eitherObjTyInfoAndTypes of - Left err -> Left err - Right (objTyInfo, _, (_, typeMap)) -> do - objFldInfo <- lookupField (fcName fieldCall) objTyInfo - case _fiLoc objFldInfo of - TLHasuraType -> - Left - (pure (FieldNotFoundInRemoteSchema (fcName fieldCall))) - TLRemoteType {} -> do - let providedArguments = - remoteArgumentsToMap (fcArguments fieldCall) - toEither - (validateRemoteArguments - (_fiParams objFldInfo) - providedArguments - (HM.fromList - (map - (first fieldNameToVariable) - (HM.toList fieldInfos))) - (GS._gTypes gctx)) - (newParamMap, newTypeMap) <- - first - pure - (runStateT - (stripInMap - remoteRelationship - (GS._gTypes gctx) - (_fiParams objFldInfo) - providedArguments) - typeMap) - innerObjTyInfo <- - if isObjType (GS._gTypes gctx) objFldInfo - then getTyInfoFromField (GS._gTypes gctx) objFldInfo - else if isScalarType (GS._gTypes gctx) objFldInfo - then pure objTyInfo - else (Left (pure (InvalidType (_fiTy objFldInfo) "only objects or scalar types expected"))) - pure - ( innerObjTyInfo - , _fiTy objFldInfo - , (newParamMap, newTypeMap))) - (pure - ( GS._gQueryRoot gctx - , G.toGT (_otiName $ GS._gQueryRoot gctx) - , (mempty, mempty))) - (rtrRemoteFields remoteRelationship) - pure - ( RemoteField - { rmfRemoteRelationship = remoteRelationship - , rmfGType = leafGType - , rmfParamMap = leafParamMap - } - , leafTypeMap) +validateRelationship remoteRel rGCtx tableInfo = do + fieldInfos <- + fmap + HM.fromList + (flip traverse (toList (rtrHasuraFields remoteRel)) $ \fieldName -> + case HM.lookup fieldName (_tiFieldInfoMap tableInfo) of + Nothing -> Left . pure $ TableFieldNotFound tableName fieldName + Just fieldInfo -> pure (fieldName, fieldInfo)) + let initFieldCalls = NE.init $ rtrRemoteFields remoteRel + leafFieldCall = NE.last $ rtrRemoteFields remoteRel + (leafParentTypeInfo, leafParentTypeMap) <- + foldl + (\parentTypeTup fieldCall -> + case parentTypeTup of + Left err -> Left err + Right (objTypeInfo, typeMap) -> do + (objFldInfo, (_newParamMap, newTypeMap)) <- + validateFieldCallWith fieldCall fieldInfos objTypeInfo typeMap + innerTypeInfo <- + getObjTypeInfoFromField (GC._rgTypes rGCtx) objFldInfo + pure (innerTypeInfo, newTypeMap)) + (pure (GC._rgQueryRoot rGCtx, mempty)) + initFieldCalls + (leafObjFldInfo, (leafParamMap, leafTypeMap)) <- + validateFieldCallWith + leafFieldCall + fieldInfos + leafParentTypeInfo + leafParentTypeMap + pure + ( RemoteField + { rmfRemoteRelationship = remoteRel + , rmfGType = _fiTy leafObjFldInfo + , rmfParamMap = leafParamMap + } + , leafTypeMap) where - tableName = rtrTable remoteRelationship - getTyInfoFromField types field = + tableName = rtrTable remoteRel + getObjTypeInfoFromField types field = do let baseTy = getBaseTy (_fiTy field) - fieldName = _fiName field - typeInfo = HM.lookup baseTy types - in case typeInfo of - Just (TIObj objTyInfo) -> pure objTyInfo - _ -> Left (pure (FieldNotFoundInRemoteSchema fieldName)) - isObjType types field = - let baseTy = getBaseTy (_fiTy field) - typeInfo = HM.lookup baseTy types - in case typeInfo of - Just (TIObj _) -> True - _ -> False - isScalarType types field = - let baseTy = getBaseTy (_fiTy field) - typeInfo = HM.lookup baseTy types - in case typeInfo of - Just (TIScalar _) -> True - _ -> False + typeInfoM = HM.lookup baseTy types + case typeInfoM of + Just (TIObj objTyInfo) -> pure objTyInfo + _ -> + Left . pure $ + InvalidType + (_fiTy field) + "only object types expected in nested fields" + validateFieldCallWith fieldCall fieldInfos objTypeInfo typeMap = do + objFldInfo <- lookupField (fcName fieldCall) objTypeInfo + case _fiLoc objFldInfo of + TLHasuraType -> + Left . pure $ FieldNotFoundInRemoteSchema (fcName fieldCall) + TLRemoteType {} -> do + let providedArguments = remoteArgumentsToMap (fcArguments fieldCall) + toEither + (validateRemoteArguments + (_fiParams objFldInfo) + providedArguments + (HM.fromList + (map (first fieldNameToVariable) (HM.toList fieldInfos))) + (GC._rgTypes rGCtx)) + (newParamMap, newTypeMap) <- + first + pure + (runStateT + (stripInMap + remoteRel + (GC._rgTypes rGCtx) + (_fiParams objFldInfo) + providedArguments) + typeMap) + pure (objFldInfo, (newParamMap, newTypeMap)) -- | Return a map with keys deleted whose template argument is -- specified as an atomic (variable, constant), keys which are kept @@ -278,12 +262,9 @@ lookupField :: G.Name -> ObjTyInfo -> Either (NonEmpty ValidationError) ObjFldInfo -lookupField name objFldInfo = viaObject objFldInfo - where - viaObject = - maybe (Left (pure (CouldntFindRemoteField name objFldInfo))) pure . - HM.lookup name . - _otiFields +lookupField name objTypeInfo = + maybe (Left (pure (FieldNotFoundInType name objTypeInfo))) pure $ + HM.lookup name (_otiFields objTypeInfo) -- | Validate remote input arguments against the remote schema. validateRemoteArguments :: @@ -332,7 +313,7 @@ validateType permittedVariables value expectedGType types = traverse_ values (\val -> - validateType permittedVariables val (peelListType expectedGType) types)) + validateType permittedVariables val (peelType expectedGType) types)) pure () G.VObject (G.unObjectValue -> values) -> flip @@ -342,7 +323,7 @@ validateType permittedVariables value expectedGType types = let expectedNamedType = getBaseTy expectedGType in case HM.lookup expectedNamedType types of - Nothing -> Failure (pure $ TypeNotFound expectedNamedType) + Nothing -> Failure (pure $ TypeNotFoundInRemoteSchema expectedNamedType) Just typeInfo -> case typeInfo of TIInpObj inpObjTypeInfo -> @@ -365,7 +346,7 @@ assertType actualType expectedType = do (Failure (pure $ ExpectedTypeButGot expectedType actualType))) -- if list type then check over unwrapped type, else check base types if isListType actualType - then assertType (peelListType actualType) (peelListType expectedType) + then assertType (peelType actualType) (peelType expectedType) else (when (getBaseTy actualType /= getBaseTy expectedType) (Failure (pure $ ExpectedTypeButGot expectedType actualType))) @@ -386,19 +367,18 @@ fieldInfoToNamedType = PGColumnScalar scalarType -> pure $ mkScalarTy scalarType _ -> Failure $ pure UnsupportedEnum FIRelationship relInfo -> - Failure (pure (ForeignRelationshipsNotAllowedInRemoteVariable relInfo)) + Failure (pure (UnsupportedForeignRelationship relInfo)) -- FIRemote remoteField -> -- Failure (pure (RemoteFieldsNotAllowedInArguments remoteField)) --- | Reify the constructors to an Either. isListType :: G.GType -> Bool isListType = \case G.TypeNamed {} -> False G.TypeList {} -> True -peelListType :: G.GType -> G.GType -peelListType = +peelType :: G.GType -> G.GType +peelType = \case G.TypeList _ lt -> G.unListType lt nt -> nt