persistent-postgresql 2.10.0 → 2.10.1
raw patch · 6 files changed
+101/−33 lines, 6 files
Files
- ChangeLog.md +4/−0
- Database/Persist/Postgresql.hs +36/−26
- Database/Persist/Postgresql/JSON.hs +6/−6
- persistent-postgresql.cabal +2/−1
- test/CustomConstraintTest.hs +51/−0
- test/main.hs +2/−0
ChangeLog.md view
@@ -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)
Database/Persist/Postgresql.hs view
@@ -94,11 +94,12 @@ "Unexpected PostgreSQL server version, got " <> uniqueMsg instance Exception PostgresServerVersionError --- | Create a PostgreSQL connection pool and run the given--- action. The pool is properly released after the action--- finishes using it. Note that you should not use the given--- 'ConnectionPool' outside the action since it may already+-- | Create a PostgreSQL connection pool and run the given action. The pool is+-- properly released after the action finishes using it. Note that you should+-- not use the given 'ConnectionPool' outside the action since it may already -- have been released.+-- The provided action should use 'runSqlConn' and *not* 'runReaderT' because+-- the former brackets the database action with transaction begin/commit. withPostgresqlPool :: (MonadLogger m, MonadUnliftIO m) => ConnectionString -- ^ Connection string to the database.@@ -175,6 +176,8 @@ -- | Same as 'withPostgresqlPool', but instead of opening a pool -- of connections, only one connection is opened.+-- The provided action should use 'runSqlConn' and *not* 'runReaderT' because+-- the former brackets the database action with transaction begin/commit. withPostgresqlConn :: (MonadUnliftIO m, MonadLogger m) => ConnectionString -> (SqlBackend -> m a) -> m a withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion@@ -565,7 +568,7 @@ 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'@@ -574,6 +577,13 @@ (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 @@ -789,23 +799,27 @@ 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@@ -905,7 +919,7 @@ 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@@ -1136,10 +1150,6 @@ addUser = maybeAddParam "user" "PGUSER" 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)
Database/Persist/Postgresql/JSON.hs view
@@ -199,9 +199,9 @@ -- -- @column ?|. list@ ----- /N.B. An empty list __will never match anything__. Also, this--- operator might have some unexpected interactions with--- non-object values. Please reference the examples./+-- /N.B. An empty list __will never match anything__. Also, this/+-- /operator might have some unexpected interactions with/+-- /non-object values. Please reference the examples./ -- -- === __Objects__ --@@ -254,9 +254,9 @@ -- -- @column ?&. list@ ----- /N.B. An empty list __will match anything__. Also, this--- operator might have some unexpected interactions with--- non-object values. Please reference the examples./+-- /N.B. An empty list __will match anything__. Also, this/+-- /operator might have some unexpected interactions with/+-- /non-object values. Please reference the examples./ -- -- === __Objects__ --
persistent-postgresql.cabal view
@@ -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 @@ ArrayAggTest EquivalentTypeTestPostgres JSONTest+ CustomConstraintTest ghc-options: -Wall build-depends: base >= 4.9 && < 5
+ test/CustomConstraintTest.hs view
@@ -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)+
test/main.hs view
@@ -46,6 +46,7 @@ import qualified TreeTest import qualified UniqueTest import qualified UpsertTest+import qualified CustomConstraintTest type Tuple = (,) @@ -172,5 +173,6 @@ EquivalentTypeTestPostgres.specs TransactionLevelTest.specsWith db JSONTest.specs+ CustomConstraintTest.specs db -- FIXME: not used, probably should? -- ArrayAggTest.specs db