Make ForeignKey mappings non-empty

Previously, these were represented with a HashMap, but supposedly that map can never be empty. Now, it uses NEHashMap, which carries the non-empty invariant behind a smart constructor.

PR-URL: hasura/graphql-engine-mono#4481
GitOrigin-RevId: 93ad9aaa9354f25a1ba10e8207ae19614e1e439e

Author: Tom Harding

server/src-lib/Data/HashMap/Strict/NonEmpty.hs

@@ -7,24 +7,36 @@ module Data.HashMap.Strict.NonEmpty
     singleton,
     fromHashMap,
     fromList,
+    fromNonEmpty,
     toHashMap,
+    toList,
+    toNonEmpty,
 
     -- * Basic interface
     lookup,
     (!?),
     keys,
 
     -- * Combine
+    union,
     unionWith,
 
     -- * Transformations
     mapKeys,
+
+    -- * Predicates
+    isInverseOf,
   )
 where
 
+import Control.DeepSeq (NFData)
+import Data.Aeson (FromJSON, ToJSON)
 import Data.HashMap.Strict (HashMap)
 import Data.HashMap.Strict qualified as M
+import Data.HashMap.Strict.Extended qualified as Extended
 import Data.Hashable (Hashable)
+import Data.List.NonEmpty (NonEmpty)
+import Data.List.NonEmpty qualified as NE
 import Prelude hiding (lookup)
 
 -------------------------------------------------------------------------------
@@ -33,7 +45,7 @@ import Prelude hiding (lookup)
 -- only provides a restricted set of functionalities. It doesn't
 -- provide a 'Monoid' instance, nor an 'empty' function.
 newtype NEHashMap k v = NEHashMap {unNEHashMap :: HashMap k v}
-  deriving newtype (Show, Eq, Ord, Semigroup)
+  deriving newtype (Show, Eq, FromJSON, Hashable, NFData, Ord, Semigroup, ToJSON)
   deriving stock (Functor, Foldable, Traversable)
 
 -------------------------------------------------------------------------------
@@ -58,10 +70,23 @@ fromList :: (Eq k, Hashable k) => [(k, v)] -> Maybe (NEHashMap k v)
 fromList [] = Nothing
 fromList v = Just $ NEHashMap $ M.fromList v
 
+-- | A variant of 'fromList' that uses 'NonEmpty' inputs.
+fromNonEmpty :: (Eq k, Hashable k) => NonEmpty (k, v) -> NEHashMap k v
+fromNonEmpty (x NE.:| xs) = NEHashMap (M.fromList (x : xs))
+
 -- | Convert a non-empty map to a 'HashMap'.
 toHashMap :: NEHashMap k v -> HashMap k v
 toHashMap = unNEHashMap
 
+-- | Convert a non-empty map to a non-empty list of key/value pairs. The closed
+-- operations of 'NEHashMap' guarantee that this operation won't fail.
+toNonEmpty :: NEHashMap k v -> NonEmpty (k, v)
+toNonEmpty = NE.fromList . M.toList . unNEHashMap
+
+-- | Convert a non-empty map to a list of key/value pairs.
+toList :: NEHashMap k v -> [(k, v)]
+toList = M.toList . unNEHashMap
+
 -------------------------------------------------------------------------------
 
 -- | Return the value to which the specified key is mapped, or 'Nothing' if
@@ -84,6 +109,13 @@ keys = M.keys . unNEHashMap
 
 -- | The union of two maps.
 --
+-- If a key occurs in both maps, the left map @m1@ (first argument) will be
+-- preferred.
+union :: (Eq k, Hashable k) => NEHashMap k v -> NEHashMap k v -> NEHashMap k v
+union (NEHashMap m1) (NEHashMap m2) = NEHashMap $ M.union m1 m2
+
+-- | The union of two maps using a given value-wise union function.
+--
 -- If a key occurs in both maps, the provided function (first argument) will be
 -- used to compute the result.
 unionWith :: (Eq k, Hashable k) => (v -> v -> v) -> NEHashMap k v -> NEHashMap k v -> NEHashMap k v
@@ -98,3 +130,15 @@ unionWith fun (NEHashMap m1) (NEHashMap m2) = NEHashMap $ M.unionWith fun m1 m2
 -- values is chosen for the conflicting key.
 mapKeys :: (Eq k2, Hashable k2) => (k1 -> k2) -> NEHashMap k1 v -> NEHashMap k2 v
 mapKeys fun (NEHashMap m) = NEHashMap $ M.mapKeys fun m
+
+-------------------------------------------------------------------------------
+
+-- | Determines whether the left-hand-side and the right-hand-side are inverses of each other.
+--
+-- More specifically, for two maps @A@ and @B@, 'isInverseOf' is satisfied when both of the
+-- following are true:
+-- 1. @∀ key ∈ A. A[key] ∈  B ∧ B[A[key]] == key@
+-- 2. @∀ key ∈ B. B[key] ∈  A ∧ A[B[key]] == key@
+isInverseOf ::
+  (Eq k, Hashable k, Eq v, Hashable v) => NEHashMap k v -> NEHashMap v k -> Bool
+lhs `isInverseOf` rhs = toHashMap lhs `Extended.isInverseOf` toHashMap rhs

server/src-lib/Hasura/Backends/MSSQL/Meta.hs

@@ -16,6 +16,7 @@ import Data.Aeson as Aeson
 import Data.ByteString.UTF8 qualified as BSUTF8
 import Data.FileEmbed (embedFile, makeRelativeToProject)
 import Data.HashMap.Strict qualified as HM
+import Data.HashMap.Strict.NonEmpty qualified as NEHashMap
 import Data.HashSet qualified as HS
 import Data.String
 import Data.Text qualified as T
@@ -171,7 +172,7 @@ transformColumn columnInfo =
 
               schemaName = SchemaName $ ssName $ sfkcJoinedReferencedSysSchema foreignKeyColumn
               _fkForeignTable = TableName (sfkcJoinedReferencedTableName foreignKeyColumn) schemaName
-              _fkColumnMapping = HM.singleton rciName $ ColumnName $ sfkcJoinedReferencedColumnName foreignKeyColumn
+              _fkColumnMapping = NEHashMap.singleton rciName $ ColumnName $ sfkcJoinedReferencedColumnName foreignKeyColumn
            in ForeignKey {..}
 
       colIsImmutable = scIsComputed columnInfo || scIsIdentity columnInfo
@@ -192,7 +193,7 @@ coalesceKeys :: [ForeignKey 'MSSQL] -> [ForeignKey 'MSSQL]
 coalesceKeys = HM.elems . foldl' coalesce HM.empty
   where
     coalesce mapping fk@(ForeignKey constraint tableName _) = HM.insertWith combine (constraint, tableName) fk mapping
-    combine oldFK newFK = oldFK {_fkColumnMapping = (HM.union `on` _fkColumnMapping) oldFK newFK}
+    combine oldFK newFK = oldFK {_fkColumnMapping = (NEHashMap.union `on` _fkColumnMapping) oldFK newFK}
 
 parseScalarType :: Text -> ScalarType
 parseScalarType = \case

server/src-lib/Hasura/Backends/MySQL/Meta.hs

@@ -9,6 +9,7 @@ import Control.Exception (throw)
 import Data.ByteString.Char8 qualified as B8
 import Data.FileEmbed (embedFile, makeRelativeToProject)
 import Data.HashMap.Strict qualified as HM
+import Data.HashMap.Strict.NonEmpty qualified as NEHashMap
 import Data.HashSet qualified as HS
 import Data.Sequence.NonEmpty qualified as SNE
 import Data.String (fromString)
@@ -87,7 +88,7 @@ mergeMetadata InformationSchema {..} =
                               schema = isReferencedTableSchema
                             }
                         )
-                        ( HM.singleton
+                        ( NEHashMap.singleton
                             (Column isColumnName)
                             (Column $ fromMaybe "" isReferencedColumnName)
                         )

server/src-lib/Hasura/Incremental/Internal/Dependency.hs

@@ -22,6 +22,8 @@ import Data.Functor.Classes (Eq1 (..), Eq2 (..))
 import Data.GADT.Compare
 import Data.HashMap.Strict qualified as Map
 import Data.HashMap.Strict.InsOrd qualified as OMap
+import Data.HashMap.Strict.NonEmpty (NEHashMap)
+import Data.HashMap.Strict.NonEmpty qualified as NEHashMap
 import Data.HashSet.InsOrd qualified as OSet
 import Data.Int
 import Data.Scientific (Scientific)
@@ -254,6 +256,9 @@ instance (Cacheable a) => Cacheable (Vector a) where
 instance (Cacheable k, Cacheable v) => Cacheable (HashMap k v) where
   unchanged accesses = liftEq2 (unchanged accesses) (unchanged accesses)
 
+instance (Cacheable k, Cacheable v) => Cacheable (NEHashMap k v) where
+  unchanged accesses = unchanged accesses `on` NEHashMap.toHashMap
+
 instance (Cacheable a) => Cacheable (HashSet a) where
   unchanged = liftEq . unchanged
 

server/src-lib/Hasura/RQL/DDL/Relationship.hs

@@ -16,6 +16,7 @@ import Control.Lens ((.~))
 import Data.Aeson.Types
 import Data.HashMap.Strict qualified as Map
 import Data.HashMap.Strict.InsOrd qualified as OMap
+import Data.HashMap.Strict.NonEmpty qualified as NEHashMap
 import Data.HashSet qualified as Set
 import Data.Text.Extended
 import Data.Tuple (swap)
@@ -140,7 +141,7 @@ objRelP2Setup source qt foreignKeys (RelDef rn ru _) = case ru of
               DRRemoteTable
           ]
             <> fmap (drUsingColumnDep @b source qt) (toList columns)
-    pure (RelInfo rn ObjRel colMap foreignTable False BeforeParent, dependencies)
+    pure (RelInfo rn ObjRel (NEHashMap.toHashMap colMap) foreignTable False BeforeParent, dependencies)
   RUFKeyOn (RemoteTable remoteTable remoteCols) ->
     mkFkeyRel ObjRel AfterParent source rn qt remoteTable remoteCols foreignKeys
 
@@ -218,7 +219,7 @@ mkFkeyRel relType io source rn sourceTable remoteTable remoteColumns foreignKeys
             DRRemoteTable
         ]
           <> fmap (drUsingColumnDep @b source remoteTable) (toList remoteColumns)
-  pure (RelInfo rn relType (reverseMap colMap) remoteTable False io, dependencies)
+  pure (RelInfo rn relType (reverseMap (NEHashMap.toHashMap colMap)) remoteTable False io, dependencies)
   where
     reverseMap :: Eq y => Hashable y => HashMap x y -> HashMap y x
     reverseMap = Map.fromList . fmap swap . Map.toList
@@ -235,7 +236,7 @@ getRequiredFkey cols fkeys =
     [] -> throw400 ConstraintError "no foreign constraint exists on the given column(s)"
     _ -> throw400 ConstraintError "more than one foreign key constraint exists on the given column(s)"
   where
-    filteredFkeys = filter ((== Set.fromList (toList cols)) . Map.keysSet . _fkColumnMapping) fkeys
+    filteredFkeys = filter ((== Set.fromList (toList cols)) . Map.keysSet . NEHashMap.toHashMap . _fkColumnMapping) fkeys
 
 drUsingColumnDep ::
   forall b.

server/src-lib/Hasura/RQL/DDL/Schema/Enum.hs

@@ -15,6 +15,7 @@ module Hasura.RQL.DDL.Schema.Enum
 where
 
 import Data.HashMap.Strict qualified as M
+import Data.HashMap.Strict.NonEmpty qualified as NEHashMap
 import Data.Sequence qualified as Seq
 import Data.Sequence.NonEmpty qualified as NESeq
 import Hasura.Prelude
@@ -39,7 +40,7 @@ resolveEnumReferences enumTables =
   where
     resolveEnumReference :: ForeignKey b -> Maybe (Column b, EnumReference b)
     resolveEnumReference foreignKey = do
-      [(localColumn, foreignColumn)] <- pure $ M.toList (_fkColumnMapping @b foreignKey)
+      [(localColumn, foreignColumn)] <- pure $ NEHashMap.toList (_fkColumnMapping @b foreignKey)
       let foreignKeyTableName = _fkForeignTable foreignKey
       (primaryKey, tConfig, enumValues) <- M.lookup foreignKeyTableName enumTables
       let tableCustomName = _tcCustomName tConfig

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

@@ -93,6 +93,8 @@ import Data.Aeson.TH
 import Data.Aeson.Types (Parser, prependFailure, typeMismatch)
 import Data.HashMap.Strict qualified as M
 import Data.HashMap.Strict.Extended qualified as M
+import Data.HashMap.Strict.NonEmpty (NEHashMap)
+import Data.HashMap.Strict.NonEmpty qualified as NEHashMap
 import Data.HashSet qualified as HS
 import Data.List.Extended (duplicates)
 import Data.List.NonEmpty qualified as NE
@@ -761,7 +763,7 @@ $(makeLenses ''PrimaryKey)
 data ForeignKey (b :: BackendType) = ForeignKey
   { _fkConstraint :: !(Constraint b),
     _fkForeignTable :: !(TableName b),
-    _fkColumnMapping :: !(HashMap (Column b) (Column b))
+    _fkColumnMapping :: !(NEHashMap (Column b) (Column b))
   }
   deriving (Generic)
 
@@ -861,18 +863,28 @@ instance Backend b => FromJSON (ForeignKeyMetadata b) where
     constraint <- o .: "constraint"
     foreignTable <- o .: "foreign_table"
 
-    columns <- o .: "columns"
-    foreignColumns <- o .: "foreign_columns"
-    if length columns == length foreignColumns
-      then
-        pure $
-          ForeignKeyMetadata
-            ForeignKey
-              { _fkConstraint = constraint,
-                _fkForeignTable = foreignTable,
-                _fkColumnMapping = M.fromList $ zip columns foreignColumns
-              }
-      else fail "columns and foreign_columns differ in length"
+    columns <-
+      o .: "columns" >>= \case
+        x : xs -> pure (x :| xs)
+        [] -> fail "columns must be non-empty"
+
+    foreignColumns <-
+      o .: "foreign_columns" >>= \case
+        x : xs -> pure (x :| xs)
+        [] -> fail "foreign_columns must be non-empty"
+
+    unless (length columns == length foreignColumns) do
+      fail "columns and foreign_columns differ in length"
+
+    pure $
+      ForeignKeyMetadata
+        ForeignKey
+          { _fkConstraint = constraint,
+            _fkForeignTable = foreignTable,
+            _fkColumnMapping =
+              NEHashMap.fromNonEmpty $
+                NE.zip columns foreignColumns
+          }
 
 -- | Metadata of any Backend table which is being extracted from source database
 data DBTableMetadata (b :: BackendType) = DBTableMetadata