Postgresql constraint= attribute support

persistent-postgresql/ChangeLog.md

@@ -1,5 +1,9 @@
 # Changelog for persistent-postgresql
 
+## 2.10.1
+
+* Added support for the `constraint=` attribute to the Postgresql backend. [#979](https://github.com/yesodweb/persistent/pull/979)
+
 ## 2.10.0
 
 * Added question mark operators (`(?.), (?|.), (?&.)`) to `Database.Persist.Postgresql.JSON` [#863](https://github.com/yesodweb/persistent/pull/863)

persistent-postgresql/Database/Persist/Postgresql.hs

@@ -568,7 +568,7 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
     migrationText exists old'' =
         if not exists
             then createText newcols fdefs udspair
-            else let (acs, ats) = getAlters allDefs entity (newcols, udspair) old'
+            else let (acs, ats) = getAlters allDefs entity (newcols, udspair) $ excludeForeignKeys $ old'
                      acs' = map (AlterColumn name) acs
                      ats' = map (AlterTable name) ats
                  in  acs' ++ ats'
@@ -577,6 +577,13 @@ migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do
          (newcols', udefs, fdefs) = mkColumns allDefs entity
          newcols = filter (not . safeToRemove entity . cName) newcols'
          udspair = map udToPair udefs
+         excludeForeignKeys (xs,ys) = (map excludeForeignKey xs,ys)
+         excludeForeignKey c = case cReference c of
+           Just (_,fk) ->
+             case find (\f -> fk == foreignConstraintNameDBName f) fdefs of
+               Just _ -> c { cReference = Nothing }
+               Nothing -> c
+           Nothing -> c
             -- Check for table existence if there are no columns, workaround
             -- for https://github.com/yesodweb/persistent/issues/152
 
@@ -792,23 +799,27 @@ getColumn getter tableName' [PersistText columnName, PersistText isNullable, Per
                 Nothing -> loop' ps
                 Just t' -> t'
     getRef cname = do
-        let sql = T.concat
-                [ "SELECT COUNT(*) FROM "
-                , "information_schema.table_constraints "
-                , "WHERE table_catalog=current_database() "
-                , "AND table_schema=current_schema() "
-                , "AND table_name=? "
-                , "AND constraint_type='FOREIGN KEY' "
-                , "AND constraint_name=?"
-                ]
-        let ref = refName tableName' cname
+        let sql = T.concat ["SELECT DISTINCT "
+                           ,"ccu.table_name, "
+                           ,"tc.constraint_name "
+                           ,"FROM information_schema.constraint_column_usage ccu, "
+                           ,"information_schema.key_column_usage kcu, "
+                           ,"information_schema.table_constraints tc "
+                           ,"WHERE tc.constraint_type='FOREIGN KEY' "
+                           ,"AND kcu.constraint_name=tc.constraint_name "
+                           ,"AND ccu.constraint_name=kcu.constraint_name "
+                           ,"AND kcu.ordinal_position=1 "
+                           ,"AND kcu.table_name=? "
+                           ,"AND kcu.column_name=?"]
         stmt <- getter sql
-        with (stmtQuery stmt
-                     [ PersistText $ unDBName tableName'
-                     , PersistText $ unDBName ref
-                     ]) (\src -> runConduit $ src .| do
-            Just [PersistInt64 i] <- CL.head
-            return $ if i == 0 then Nothing else Just (DBName "", ref))
+        cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName'
+                                      ,PersistText $ unDBName cname])
+                      (\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"
     d' = case defaultValue of
             PersistNull   -> Right Nothing
             PersistText t -> Right $ Just t
@@ -908,7 +919,7 @@ getAddReference :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, D
 getAddReference allDefs table reftable cname ref =
     case ref of
         Nothing -> Nothing
-        Just (s, _) -> Just $ AlterColumn table (s, AddReference (refName table cname) [cname] id_)
+        Just (s, constraintName) -> Just $ AlterColumn table (s, AddReference constraintName [cname] id_)
                           where
                             id_ = fromMaybe (error $ "Could not find ID of entity " ++ show reftable)
                                         $ do
@@ -1140,10 +1151,6 @@ instance PersistConfig PostgresConf where
         addPass     = maybeAddParam "password" "PGPASS"
         addDatabase = maybeAddParam "dbname"   "PGDATABASE"
 
-refName :: DBName -> DBName -> DBName
-refName (DBName table) (DBName column) =
-    DBName $ T.concat [table, "_", column, "_fkey"]
-
 udToPair :: UniqueDef -> (DBName, [DBName])
 udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud)
 

persistent-postgresql/persistent-postgresql.cabal

@@ -1,5 +1,5 @@
 name:            persistent-postgresql
-version:         2.10.0
+version:         2.10.1
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa, Michael Snoyman <michael@snoyman.com>
@@ -48,6 +48,7 @@ test-suite test
                      ArrayAggTest
                      EquivalentTypeTestPostgres
                      JSONTest
+                     CustomConstraintTest
     ghc-options:     -Wall
 
     build-depends:   base                 >= 4.9 && < 5

persistent-postgresql/test/CustomConstraintTest.hs

@@ -0,0 +1,51 @@
+{-# LANGUAGE EmptyDataDecls             #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE OverloadedStrings          #-}
+{-# LANGUAGE QuasiQuotes                #-}
+{-# LANGUAGE TemplateHaskell            #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
+module CustomConstraintTest where
+
+import PgInit
+import qualified Data.Text as T
+
+share [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] [persistLowerCase|
+CustomConstraint1
+    some_field Text
+    deriving Show
+
+CustomConstraint2
+    cc_id CustomConstraint1Id constraint=custom_constraint
+    deriving Show
+|]
+
+specs :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec
+specs runDb = do
+  describe "custom constraint used in migration" $ do
+    it "custom constraint is actually created" $ runDb $ do
+      runMigration customConstraintMigrate
+      runMigration customConstraintMigrate -- run a second time to ensure the constraint isn't dropped
+      let query = T.concat ["SELECT DISTINCT COUNT(*) "
+                           ,"FROM information_schema.constraint_column_usage ccu, "
+                           ,"information_schema.key_column_usage kcu, "
+                           ,"information_schema.table_constraints tc "
+                           ,"WHERE tc.constraint_type='FOREIGN KEY' "
+                           ,"AND kcu.constraint_name=tc.constraint_name "
+                           ,"AND ccu.constraint_name=kcu.constraint_name "
+                           ,"AND kcu.ordinal_position=1 "
+                           ,"AND ccu.table_name=? "
+                           ,"AND ccu.column_name=? "
+                           ,"AND kcu.table_name=? "
+                           ,"AND kcu.column_name=? "
+                           ,"AND tc.constraint_name=?"]
+      [Single exists] <- rawSql query [PersistText "custom_constraint1"
+                                      ,PersistText "id"
+                                      ,PersistText "custom_constraint2"
+                                      ,PersistText "cc_id"
+                                      ,PersistText "custom_constraint"]
+      liftIO $ 1 @?= (exists :: Int)
+

persistent-postgresql/test/main.hs

@@ -46,6 +46,7 @@ import qualified TransactionLevelTest
 import qualified TreeTest
 import qualified UniqueTest
 import qualified UpsertTest
+import qualified CustomConstraintTest
 
 type Tuple = (,)
 
@@ -172,5 +173,6 @@ main = do
     EquivalentTypeTestPostgres.specs
     TransactionLevelTest.specsWith db
     JSONTest.specs
+    CustomConstraintTest.specs db
     -- FIXME: not used, probably should?
     -- ArrayAggTest.specs db