{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE StandaloneDeriving #-} module CustomConstraintTest where import MyInit 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 CustomConstraint3 -- | This will lead to a constraint with the name custom_constraint3_cc_id1_fkey cc_id1 CustomConstraint1Id cc_id2 CustomConstraint1Id deriving Show |] clean :: MonadUnliftIO m => SqlPersistT m () clean = do rawExecute "drop table custom_constraint3" [] rawExecute "drop table custom_constraint2" [] rawExecute "drop table custom_constraint1" [] specs :: (MonadUnliftIO m, MonadFail m) => RunDb SqlBackend m -> Spec specs runDb = do describe "custom constraint used in migration" $ before_ (runDb $ void $ runMigrationSilent customConstraintMigrate) $ after_ (runDb clean) $ do it "custom constraint is actually created" $ runDb $ do void $ runMigrationSilent customConstraintMigrate -- run a second time to ensure the constraint isn't dropped let query = T.concat ["SELECT COUNT(*) " ,"FROM information_schema.key_column_usage " ,"WHERE ordinal_position=1 " ,"AND referenced_table_name=? " ,"AND referenced_column_name=? " ,"AND table_name=? " ,"AND column_name=? " ,"AND constraint_name=?"] [Single exists_] <- rawSql query [ PersistText "custom_constraint1" , PersistText "id" , PersistText "custom_constraint2" , PersistText "cc_id" , PersistText "custom_constraint" ] liftIO $ 1 @?= (exists_ :: Int) it "allows multiple constraints on a single column" $ runDb $ do -- 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 ()