refactor

hasura · Sep 24, 2019 · dc35557 · dc35557
1 parent 1ddd4f2
commit dc35557
Show file tree

Hide file tree

Showing 2 changed files with 107 additions and 126 deletions.
diff --git 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
@@ -14,148 +14,132 @@ 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)
 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