diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-postgresql +## 2.10.1.2 + +* Fix issue with multiple foreign keys on single column. [#1010](https://github.com/yesodweb/persistent/pull/1010) + ## 2.10.1.1 * Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -554,7 +554,7 @@ -> EntityDef -> IO (Either [Text] [(Bool, Text)]) migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do - old <- getColumns getter entity + old <- getColumns getter entity newcols' case partitionEithers old of ([], old'') -> do exists <- @@ -565,6 +565,7 @@ (errs, _) -> return $ Left errs where name = entityDB entity + (newcols', udefs, fdefs) = mkColumns allDefs entity migrationText exists old'' = if not exists then createText newcols fdefs udspair @@ -574,7 +575,6 @@ in acs' ++ ats' where old' = partitionEithers old'' - (newcols', udefs, fdefs) = mkColumns allDefs entity newcols = filter (not . safeToRemove entity . cName) newcols' udspair = map udToPair udefs excludeForeignKeys (xs,ys) = (map excludeForeignKey xs,ys) @@ -650,9 +650,9 @@ -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) - -> EntityDef + -> EntityDef -> [Column] -> IO [Either Text (Either Column (DBName, [DBName]))] -getColumns getter def = do +getColumns getter def cols = do let sqlv=T.concat ["SELECT " ,"column_name " ,",is_nullable " @@ -700,6 +700,10 @@ us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) return $ cs ++ us where + refMap = Map.fromList $ foldl ref [] cols + where ref rs c = case cReference c of + Nothing -> rs + (Just r) -> (unDBName $ cName c, r) : rs getAll front = do x <- CL.head case x of @@ -715,8 +719,8 @@ x <- CL.head case x of Nothing -> return [] - Just x' -> do - col <- liftIO $ getColumn getter (entityDB def) x' + Just x'@((PersistText cname):_) -> do + col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) let col' = case col of Left e -> Left e Right c -> Right $ Left c @@ -764,8 +768,9 @@ getColumn :: (Text -> IO Statement) -> DBName -> [PersistValue] + -> Maybe (DBName, DBName) -> IO (Either Text Column) -getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] = +getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = case d' of Left s -> return $ Left s Right d'' -> @@ -776,7 +781,7 @@ Left s -> return $ Left s Right t -> do let cname = DBName columnName - ref <- getRef cname + ref <- getRef cname refName return $ Right Column { cName = cname , cNull = isNullable == "YES" @@ -798,7 +803,8 @@ case T.stripSuffix p t of Nothing -> loop' ps Just t' -> t' - getRef cname = do + getRef _ Nothing = return Nothing + getRef cname (Just (_, refName')) = do let sql = T.concat ["SELECT DISTINCT " ,"ccu.table_name, " ,"tc.constraint_name " @@ -810,16 +816,26 @@ ,"AND ccu.constraint_name=kcu.constraint_name " ,"AND kcu.ordinal_position=1 " ,"AND kcu.table_name=? " - ,"AND kcu.column_name=?"] + ,"AND kcu.column_name=? " + ,"AND tc.constraint_name=?"] stmt <- getter sql cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName' - ,PersistText $ unDBName cname]) + ,PersistText $ unDBName cname + ,PersistText $ unDBName refName']) (\src -> runConduit $ src .| CL.consume) case cntrs of [] -> return Nothing [[PersistText table, PersistText constraint]] -> return $ Just (DBName table, DBName constraint) - _ -> error "Postgresql.getColumn: error fetching constraints" + xs -> + error $ mconcat + [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " + , T.unpack (unDBName tableName') + , " and column: " + , T.unpack (unDBName cname) + , " but got: " + , show xs + ] d' = case defaultValue of PersistNull -> Right Nothing PersistText t -> Right $ Just t @@ -861,7 +877,7 @@ , ", respectively." , " Specify the values as numeric(total_digits, digits_after_decimal_place)." ] -getColumn _ _ columnName = +getColumn _ _ columnName _ = return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName -- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.10.1.1 +version: 2.10.1.2 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman diff --git a/test/CustomConstraintTest.hs b/test/CustomConstraintTest.hs --- a/test/CustomConstraintTest.hs +++ b/test/CustomConstraintTest.hs @@ -23,6 +23,12 @@ CustomConstraint2 cc_id CustomConstraint1Id constraint=custom_constraint deriving Show + +CustomConstraint3 + -- | This will lead to a constraint with the name custom_constraint3_cc_id1_fkey + cc_id1 CustomConstraint1Id + cc_id2 CustomConstraint1Id + deriving Show |] specs :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec @@ -51,3 +57,10 @@ ,PersistText "custom_constraint"] liftIO $ 1 @?= (exists :: Int) + it "allows multiple constraints on a single column" $ runDb $ do + runMigration customConstraintMigrate + -- | Here we add another foreign key on the same column where the default one already exists. In practice, this could be a compound key with another field. + rawExecute "ALTER TABLE \"custom_constraint3\" ADD CONSTRAINT \"extra_constraint\" FOREIGN KEY(\"cc_id1\") REFERENCES \"custom_constraint1\"(\"id\")" [] + -- | This is where the error is thrown in `getColumn` + _ <- getMigration customConstraintMigrate + pure ()