persistent-postgresql 2.11.0.1 → 2.12.0.0
raw patch · 7 files changed
+332/−179 lines, 7 filesdep +unliftiodep −persistent-templatedep ~basedep ~bytestringdep ~monad-loggernew-component:exe:conn-kill
Dependencies added: unliftio
Dependencies removed: persistent-template
Dependency ranges changed: base, bytestring, monad-logger, persistent, text, time, transformers
Files
- ChangeLog.md +5/−0
- Database/Persist/Postgresql.hs +168/−157
- conn-killed/Main.hs +98/−0
- persistent-postgresql.cabal +22/−3
- test/ArrayAggTest.hs +1/−1
- test/PgInit.hs +31/−12
- test/PgIntervalTest.hs +7/−6
ChangeLog.md view
@@ -1,5 +1,10 @@ # Changelog for persistent-postgresql +## 2.12.0.0++* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)+* Fix XML conversion [#1192](https://github.com/yesodweb/persistent/pull/1192)+ ## 2.11.0.1 * Fix foreign key migrations [#1167] https://github.com/yesodweb/persistent/pull/1167 * Fix a bug where a foreign key of a field to its table was ignored.
Database/Persist/Postgresql.hs view
@@ -49,7 +49,7 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO)-import Control.Monad.Logger (MonadLogger, runNoLoggingT)+import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) import Control.Monad.Trans.Reader (runReaderT) import Control.Monad.Trans.Writer (WriterT(..), runWriterT) @@ -116,7 +116,7 @@ -- 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)+withPostgresqlPool :: (MonadLoggerIO m, MonadUnliftIO m) => ConnectionString -- ^ Connection string to the database. -> Int@@ -132,7 +132,7 @@ -- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2-withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLogger m)+withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. -> ConnectionString@@ -151,7 +151,7 @@ -- | Same as 'withPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. -- -- @since 2.11.0.0-withPostgresqlPoolWithConf :: (MonadUnliftIO m, MonadLogger m)+withPostgresqlPoolWithConf :: (MonadUnliftIO m, MonadLoggerIO m) => PostgresConf -- ^ Configuration for connecting to Postgres -> PostgresConfHooks -- ^ Record of callback functions -> (Pool SqlBackend -> m a)@@ -168,7 +168,7 @@ -- responsibility to properly close the connection pool when -- unneeded. Use 'withPostgresqlPool' for an automatic resource -- control.-createPostgresqlPool :: (MonadUnliftIO m, MonadLogger m)+createPostgresqlPool :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionString -- ^ Connection string to the database. -> Int@@ -186,7 +186,7 @@ -- -- @since 2.1.3 createPostgresqlPoolModified- :: (MonadUnliftIO m, MonadLogger m)+ :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool.@@ -199,7 +199,7 @@ -- -- @since 2.6.2 createPostgresqlPoolModifiedWithVersion- :: (MonadUnliftIO m, MonadLogger m)+ :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version. -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created. -> ConnectionString -- ^ Connection string to the database.@@ -213,7 +213,7 @@ -- -- @since 2.11.0.0 createPostgresqlPoolWithConf- :: (MonadUnliftIO m, MonadLogger m)+ :: (MonadUnliftIO m, MonadLoggerIO m) => PostgresConf -- ^ Configuration for connecting to Postgres -> PostgresConfHooks -- ^ Record of callback functions -> m (Pool SqlBackend)@@ -234,7 +234,7 @@ -- 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)+withPostgresqlConn :: (MonadUnliftIO m, MonadLoggerIO m) => ConnectionString -> (SqlBackend -> m a) -> m a withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion @@ -242,7 +242,7 @@ -- the server version (to work around an Amazon Redshift bug). -- -- @since 2.6.2-withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLogger m)+withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) => (PG.Connection -> IO (Maybe Double)) -> ConnectionString -> (SqlBackend -> m a)@@ -355,7 +355,9 @@ Serializable -> PG.Serializable) conn , connCommit = const $ PG.commit conn , connRollback = const $ PG.rollback conn- , connEscapeName = escape+ , connEscapeFieldName = escapeF+ , connEscapeTableName = escapeE . entityDB+ , connEscapeRawName = escape , connNoLimit = "LIMIT ALL" , connRDBMS = "postgresql" , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL"@@ -378,12 +380,12 @@ insertSql' ent vals = case entityPrimary ent of Just _pdef -> ISRManyKeys sql vals- Nothing -> ISRSingle (sql <> " RETURNING " <> escape (fieldDB (entityId ent)))+ Nothing -> ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB (entityId ent))) where- (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escape)+ (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) sql = T.concat [ "INSERT INTO "- , escape $ entityDB ent+ , escapeE $ entityDB ent , if null (entityFields ent) then " DEFAULT VALUES" else T.concat@@ -396,17 +398,17 @@ ] -upsertSql' :: EntityDef -> NonEmpty (HaskellName, DBName) -> Text -> Text+upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text upsertSql' ent uniqs updateVal = T.concat [ "INSERT INTO "- , escape (entityDB ent)+ , escapeE (entityDB ent) , "(" , T.intercalate "," fieldNames , ") VALUES (" , T.intercalate "," placeholders , ") ON CONFLICT ("- , T.intercalate "," $ map (escape . snd) (NEL.toList uniqs)+ , T.intercalate "," $ map (escapeF . snd) (NEL.toList uniqs) , ") DO UPDATE SET " , updateVal , " WHERE "@@ -414,28 +416,28 @@ , " RETURNING ??" ] where- (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escape)+ (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs - singleClause :: DBName -> Text- singleClause field = escape (entityDB ent) <> "." <> (escape field) <> " =?"+ singleClause :: FieldNameDB -> Text+ singleClause field = escapeE (entityDB ent) <> "." <> (escapeF field) <> " =?" -- | SQL for inserting multiple rows at once and returning their primary keys. insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult insertManySql' ent valss = ISRSingle sql where- (fieldNames, placeholders)= unzip (Util.mkInsertPlaceholders ent escape)+ (fieldNames, placeholders)= unzip (Util.mkInsertPlaceholders ent escapeF) sql = T.concat [ "INSERT INTO "- , escape (entityDB ent)+ , escapeE (entityDB ent) , "(" , T.intercalate "," fieldNames , ") VALUES (" , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," placeholders , ") RETURNING "- , Util.commaSeparated $ Util.dbIdColumnsEsc escape ent+ , Util.commaSeparated $ Util.dbIdColumnsEsc escapeF ent ] @@ -529,9 +531,9 @@ toField (P PersistNull) = PGTF.toField PG.Null toField (P (PersistList l)) = PGTF.toField $ listToJSON l toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m- toField (P (PersistDbSpecific s)) = PGTF.toField (Unknown s)- toField (P (PersistLiteral l)) = PGTF.toField (UnknownLiteral l)- toField (P (PersistLiteralEscaped e)) = PGTF.toField (Unknown e)+ toField (P (PersistLiteral_ DbSpecific s)) = PGTF.toField (Unknown s)+ toField (P (PersistLiteral_ Unescaped l)) = PGTF.toField (UnknownLiteral l)+ toField (P (PersistLiteral_ Escaped e)) = PGTF.toField (Unknown e) toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a toField (P (PersistObjectId _)) = error "Refusing to serialize a PersistObjectId to a PostgreSQL value"@@ -624,8 +626,9 @@ instance PersistField PgInterval where toPersistValue = PersistLiteralEscaped . pgIntervalToBs- fromPersistValue (PersistDbSpecific bs) = fromPersistValue (PersistLiteralEscaped bs)- fromPersistValue x@(PersistLiteralEscaped bs) =+ fromPersistValue (PersistLiteral_ DbSpecific bs) =+ fromPersistValue (PersistLiteralEscaped bs)+ fromPersistValue x@(PersistLiteral_ Escaped bs) = case P.parseOnly (P.signed P.rational <* P.char 's' <* P.endOfInput) bs of Left _ -> Left $ fromPersistValueError "PgInterval" "Interval" x Right i -> Right $ PgInterval i@@ -674,7 +677,7 @@ , (k PS.int2, convertPV PersistInt64) , (k PS.int4, convertPV PersistInt64) , (k PS.text, convertPV PersistText)- , (k PS.xml, convertPV PersistText)+ , (k PS.xml, convertPV (PersistByteString . unUnknown)) , (k PS.float4, convertPV PersistDouble) , (k PS.float8, convertPV PersistDouble) , (k PS.money, convertPV PersistRational)@@ -703,7 +706,7 @@ , (1005, listOf PersistInt64) , (1007, listOf PersistInt64) , (1009, listOf PersistText)- , (143, listOf PersistText)+ , (143, listOf (PersistByteString . unUnknown)) , (1021, listOf PersistDouble) , (1022, listOf PersistDouble) , (1023, listOf PersistUTCTime)@@ -744,9 +747,9 @@ unBinary (PG.Binary x) = x doesTableExist :: (Text -> IO Statement)- -> DBName -- ^ table name+ -> EntityNameDB -> IO Bool-doesTableExist getter (DBName name) = do+doesTableExist getter (EntityNameDB name) = do stmt <- getter sql with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) where@@ -811,16 +814,12 @@ :: EntityDef -> ForeignDef -> Maybe AlterDB-mkForeignAlt entity fdef = do- pure $ AlterColumn- tableName_- ( foreignRefTableDBName fdef- , addReference- )+mkForeignAlt entity fdef = pure $ AlterColumn tableName_ addReference where tableName_ = entityDB entity addReference = AddReference+ (foreignRefTableDBName fdef) constraintName childfields escapedParentFields@@ -830,14 +829,14 @@ (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) escapedParentFields =- map escape parentfields+ map escapeF parentfields addTable :: [Column] -> EntityDef -> AlterDB addTable cols entity = AddTable $ T.concat -- Lower case e: see Database.Persist.Sql.Migration [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION!- , escape name+ , escapeE name , "(" , idtxt , if null nonIdCols then "" else ","@@ -859,14 +858,14 @@ Just pdef -> T.concat [ " PRIMARY KEY ("- , T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef+ , T.intercalate "," $ map (escapeF . fieldDB) $ compositeFields pdef , ")" ] Nothing -> let defText = defaultAttribute $ fieldAttrs $ entityId entity sType = fieldSqlType $ entityId entity in T.concat- [ escape $ fieldDB (entityId entity)+ [ escapeF $ fieldDB (entityId entity) , maySerial sType defText , " PRIMARY KEY UNIQUE" , mayDefault defText@@ -884,29 +883,32 @@ type SafeToRemove = Bool data AlterColumn- = ChangeType SqlType Text- | IsNull | NotNull | Add' Column | Drop SafeToRemove- | Default Text | NoDefault | Update' Text- | AddReference DBName [DBName] [Text] FieldCascade- | DropReference DBName+ = ChangeType Column SqlType Text+ | IsNull Column+ | NotNull Column+ | Add' Column+ | Drop Column SafeToRemove+ | Default Column Text+ | NoDefault Column+ | Update' Column Text+ | AddReference EntityNameDB ConstraintNameDB [FieldNameDB] [Text] FieldCascade+ | DropReference ConstraintNameDB deriving Show -type AlterColumn' = (DBName, AlterColumn)- data AlterTable- = AddUniqueConstraint DBName [DBName]- | DropConstraint DBName+ = AddUniqueConstraint ConstraintNameDB [FieldNameDB]+ | DropConstraint ConstraintNameDB deriving Show data AlterDB = AddTable Text- | AlterColumn DBName AlterColumn'- | AlterTable DBName AlterTable+ | AlterColumn EntityNameDB AlterColumn+ | AlterTable EntityNameDB AlterTable deriving Show -- | Returns all of the columns in the given table currently in the database. getColumns :: (Text -> IO Statement) -> EntityDef -> [Column]- -> IO [Either Text (Either Column (DBName, [DBName]))]+ -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] getColumns getter def cols = do let sqlv = T.concat [ "SELECT "@@ -934,7 +936,7 @@ stmt <- getter sqlv let vals =- [ PersistText $ unDBName $ entityDB def+ [ PersistText $ unEntityNameDB $ entityDB def ] columns <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| processColumns .| CL.consume) let sqlc = T.concat@@ -965,7 +967,7 @@ $ foldl' ref [] cols where ref rs c =- maybe rs (\r -> (unDBName $ cName c, r) : rs) (cReference c)+ maybe rs (\r -> (unFieldNameDB $ cName c, r) : rs) (cReference c) getAll = CL.mapM $ \x -> pure $ case x of@@ -977,7 +979,7 @@ error $ "unexpected datatype returned for postgres o="++show o helperU = do rows <- getAll .| CL.consume- return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd)))+ return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) $ groupBy ((==) `on` fst) rows processColumns = CL.mapM $ \x'@((PersistText cname) : _) -> do@@ -988,29 +990,29 @@ -- | Check if a column name is listed as the "safe to remove" in the entity -- list.-safeToRemove :: EntityDef -> DBName -> Bool-safeToRemove def (DBName colName)+safeToRemove :: EntityDef -> FieldNameDB -> Bool+safeToRemove def (FieldNameDB colName) = any (elem FieldAttrSafeToRemove . fieldAttrs)- $ filter ((== DBName colName) . fieldDB)+ $ filter ((== FieldNameDB colName) . fieldDB) $ keyAndEntityFields def getAlters :: [EntityDef] -> EntityDef- -> ([Column], [(DBName, [DBName])])- -> ([Column], [(DBName, [DBName])])- -> ([AlterColumn'], [AlterTable])+ -> ([Column], [(ConstraintNameDB, [FieldNameDB])])+ -> ([Column], [(ConstraintNameDB, [FieldNameDB])])+ -> ([AlterColumn], [AlterTable]) getAlters defs def (c1, u1) (c2, u2) = (getAltersC c1 c2, getAltersU u1 u2) where getAltersC [] old =- map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old+ map (\x -> Drop x $ safeToRemove def $ cName x) old getAltersC (new:news) old = let (alters, old') = findAlters defs def new old in alters ++ getAltersC news old' getAltersU- :: [(DBName, [DBName])]- -> [(DBName, [DBName])]+ :: [(ConstraintNameDB, [FieldNameDB])]+ -> [(ConstraintNameDB, [FieldNameDB])] -> [AlterTable] getAltersU [] old = map DropConstraint $ filter (not . isManual) $ map fst old@@ -1027,13 +1029,13 @@ : getAltersU news old' -- Don't drop constraints which were manually added.- isManual (DBName x) = "__manual_" `T.isPrefixOf` x+ isManual (ConstraintNameDB x) = "__manual_" `T.isPrefixOf` x getColumn :: (Text -> IO Statement)- -> DBName+ -> EntityNameDB -> [PersistValue]- -> Maybe (DBName, DBName)+ -> Maybe (EntityNameDB, ConstraintNameDB) -> IO (Either Text Column) getColumn getter tableName' [ PersistText columnName , PersistText isNullable@@ -1071,7 +1073,7 @@ t <- getType typeStr - let cname = DBName columnName+ let cname = FieldNameDB columnName ref <- lift $ fmap join $ traverse (getRef cname) refName_ @@ -1145,9 +1147,9 @@ cntrs <- with (stmtQuery stmt- [ PersistText $ unDBName tableName'- , PersistText $ unDBName cname- , PersistText $ unDBName refName'+ [ PersistText $ unEntityNameDB tableName'+ , PersistText $ unFieldNameDB cname+ , PersistText $ unConstraintNameDB refName' ] ) (\src -> runConduit $ src .| CL.consume)@@ -1155,13 +1157,13 @@ [] -> return Nothing [[PersistText table, PersistText constraint, PersistText updRule, PersistText delRule]] ->- return $ Just (DBName table, DBName constraint, updRule, delRule)+ return $ Just (EntityNameDB table, ConstraintNameDB constraint, updRule, delRule) xs -> error $ mconcat [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: "- , T.unpack (unDBName tableName')+ , T.unpack (unEntityNameDB tableName') , " and column: "- , T.unpack (unDBName cname)+ , T.unpack (unFieldNameDB cname) , " but got: " , show xs ]@@ -1187,7 +1189,7 @@ [ "No precision and scale were specified for the column: " , columnName , " in table: "- , unDBName tableName'+ , unEntityNameDB tableName' , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," , " which is probably not what you intended." , " Specify the values as numeric(total_digits, digits_after_decimal_place)."@@ -1197,7 +1199,7 @@ [ "Can not get numeric field precision for the column: " , columnName , " in table: "- , unDBName tableName'+ , unEntityNameDB tableName' , ". Expected an integer for both precision and scale, " , "got: " , T.pack $ show a@@ -1223,15 +1225,15 @@ -> Column -- ^ The column that we're searching for potential alterations for. -> [Column]- -> ([AlterColumn'], [Column])+ -> ([AlterColumn], [Column]) findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName _maxLen ref) cols = case List.find (\c -> cName c == name) cols of Nothing ->- ([(name, Add' col)], cols)+ ([Add' col], cols) Just (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') -> let refDrop Nothing = [] refDrop (Just ColumnReference {crConstraintName=cname}) =- [(name, DropReference cname)]+ [DropReference cname] refAdd Nothing = [] refAdd (Just colRef) =@@ -1239,13 +1241,12 @@ Just refdef | _oldName /= fieldDB (entityId edef) ->- [ ( crTableName colRef- , AddReference- (crConstraintName colRef)- [name]- (Util.dbIdColumnsEsc escape refdef)- (crFieldCascade colRef)- )+ [AddReference+ (entityDB edef)+ (crConstraintName colRef)+ [name]+ (Util.dbIdColumnsEsc escapeF refdef)+ (crFieldCascade colRef) ] Just _ -> [] Nothing ->@@ -1258,12 +1259,12 @@ modNull = case (isNull, isNull') of (True, False) -> do guard $ name /= fieldDB (entityId edef)- pure (name, IsNull)+ pure (IsNull col) (False, True) -> let up = case def of Nothing -> id- Just s -> (:) (name, Update' s)- in up [(name, NotNull)]+ Just s -> (:) (Update' col s)+ in up [NotNull col] _ -> [] modType | sqlTypeEq sqltype sqltype' = []@@ -1271,20 +1272,20 @@ -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is -- treated as UTC. | sqltype == SqlDayTime && sqltype' == SqlOther "timestamp" =- [(name, ChangeType sqltype $ T.concat+ [ChangeType col sqltype $ T.concat [ " USING "- , escape name+ , escapeF name , " AT TIME ZONE 'UTC'"- ])]- | otherwise = [(name, ChangeType sqltype "")]+ ]]+ | otherwise = [ChangeType col sqltype ""] modDef = if def == def' || isJust (T.stripPrefix "nextval" =<< def') then [] else case def of- Nothing -> [(name, NoDefault)]- Just s -> [(name, Default s)]+ Nothing -> [NoDefault col]+ Just s -> [Default col s] in ( modRef ++ modDef ++ modNull ++ modType , filter (\c -> cName c /= name) cols@@ -1312,15 +1313,14 @@ getAddReference :: [EntityDef] -> EntityDef- -> DBName+ -> FieldNameDB -> ColumnReference -> Maybe AlterDB getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do guard $ cname /= fieldDB (entityId entity) pure $ AlterColumn table- ( s- , AddReference constraintName [cname] id_ (crFieldCascade cr)+ (AddReference s constraintName [cname] id_ (crFieldCascade cr) ) where table = entityDB entity@@ -1329,11 +1329,11 @@ (error $ "Could not find ID of entity " ++ show s) $ do entDef <- find ((== s) . entityDB) allDefs- return $ Util.dbIdColumnsEsc escape entDef+ return $ Util.dbIdColumnsEsc escapeF entDef showColumn :: Column -> Text showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = T.concat- [ escape n+ [ escapeF n , " " , showSqlType sqlType' , " "@@ -1365,130 +1365,139 @@ showAlterDb :: AlterDB -> (Bool, Text) showAlterDb (AddTable s) = (False, s)-showAlterDb (AlterColumn t (c, ac)) =- (isUnsafe ac, showAlter t (c, ac))+showAlterDb (AlterColumn t ac) =+ (isUnsafe ac, showAlter t ac) where- isUnsafe (Drop safeRemove) = not safeRemove+ isUnsafe (Drop _ safeRemove) = not safeRemove isUnsafe _ = False showAlterDb (AlterTable t at) = (False, showAlterTable t at) -showAlterTable :: DBName -> AlterTable -> Text+showAlterTable :: EntityNameDB -> AlterTable -> Text showAlterTable table (AddUniqueConstraint cname cols) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ADD CONSTRAINT "- , escape cname+ , escapeC cname , " UNIQUE("- , T.intercalate "," $ map escape cols+ , T.intercalate "," $ map escapeF cols , ")" ] showAlterTable table (DropConstraint cname) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " DROP CONSTRAINT "- , escape cname+ , escapeC cname ] -showAlter :: DBName -> AlterColumn' -> Text-showAlter table (n, ChangeType t extra) =+showAlter :: EntityNameDB -> AlterColumn -> Text+showAlter table (ChangeType c t extra) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ALTER COLUMN "- , escape n+ , escapeF (cName c) , " TYPE " , showSqlType t , extra ]-showAlter table (n, IsNull) =+showAlter table (IsNull c) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ALTER COLUMN "- , escape n+ , escapeF (cName c) , " DROP NOT NULL" ]-showAlter table (n, NotNull) =+showAlter table (NotNull c) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ALTER COLUMN "- , escape n+ , escapeF (cName c) , " SET NOT NULL" ]-showAlter table (_, Add' col) =+showAlter table (Add' col) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ADD COLUMN " , showColumn col ]-showAlter table (n, Drop _) =+showAlter table (Drop c _) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " DROP COLUMN "- , escape n+ , escapeF (cName c) ]-showAlter table (n, Default s) =+showAlter table (Default c s) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ALTER COLUMN "- , escape n+ , escapeF (cName c) , " SET DEFAULT " , s ]-showAlter table (n, NoDefault) = T.concat+showAlter table (NoDefault c) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ALTER COLUMN "- , escape n+ , escapeF (cName c) , " DROP DEFAULT" ]-showAlter table (n, Update' s) = T.concat+showAlter table (Update' c s) = T.concat [ "UPDATE "- , escape table+ , escapeE table , " SET "- , escape n+ , escapeF (cName c) , "=" , s , " WHERE "- , escape n+ , escapeF (cName c) , " IS NULL" ]-showAlter table (reftable, AddReference fkeyname t2 id2 cascade) = T.concat+showAlter table (AddReference reftable fkeyname t2 id2 cascade) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " ADD CONSTRAINT "- , escape fkeyname+ , escapeC fkeyname , " FOREIGN KEY("- , T.intercalate "," $ map escape t2+ , T.intercalate "," $ map escapeF t2 , ") REFERENCES "- , escape reftable+ , escapeE reftable , "(" , T.intercalate "," id2 , ")" ] <> renderFieldCascade cascade-showAlter table (_, DropReference cname) = T.concat+showAlter table (DropReference cname) = T.concat [ "ALTER TABLE "- , escape table+ , escapeE table , " DROP CONSTRAINT "- , escape cname+ , escapeC cname ] -- | Get the SQL string for the table that a PeristEntity represents. -- Useful for raw SQL queries. tableName :: (PersistEntity record) => record -> Text-tableName = escape . tableDBName+tableName = escapeE . tableDBName -- | Get the SQL string for the field that an EntityField represents. -- Useful for raw SQL queries. fieldName :: (PersistEntity record) => EntityField record typ -> Text-fieldName = escape . fieldDBName+fieldName = escapeF . fieldDBName -escape :: DBName -> Text-escape (DBName s) =+escapeC :: ConstraintNameDB -> Text+escapeC = escapeWith escape++escapeE :: EntityNameDB -> Text+escapeE = escapeWith escape++escapeF :: FieldNameDB -> Text+escapeF = escapeWith escape++escape :: Text -> Text+escape s = T.pack $ '"' : go (T.unpack s) ++ "\"" where go "" = ""@@ -1607,11 +1616,11 @@ } -refName :: DBName -> DBName -> DBName-refName (DBName table) (DBName column) =+refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB+refName (EntityNameDB table) (FieldNameDB column) = let overhead = T.length $ T.concat ["_", "_fkey"] (fromTable, fromColumn) = shortenNames overhead (T.length table, T.length column)- in DBName $ T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"]+ in ConstraintNameDB $ T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"] where @@ -1639,7 +1648,7 @@ maximumIdentifierLength :: Int maximumIdentifierLength = 63 -udToPair :: UniqueDef -> (DBName, [DBName])+udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) udToPair ud = (uniqueDBName ud, map snd $ uniqueFields ud) mockMigrate :: [EntityDef]@@ -1703,7 +1712,9 @@ connBegin = undefined, connCommit = undefined, connRollback = undefined,- connEscapeName = escape,+ connEscapeFieldName = escapeF,+ connEscapeTableName = escapeE . entityDB,+ connEscapeRawName = escape, connNoLimit = undefined, connRDBMS = undefined, connLimitOffset = undefined,@@ -1719,21 +1730,21 @@ putManySql ent n = putManySql' conflictColumns fields ent n where fields = entityFields ent- conflictColumns = concatMap (map (escape . snd) . uniqueFields) (entityUniques ent)+ conflictColumns = concatMap (map (escapeF . snd) . uniqueFields) (entityUniques ent) repsertManySql :: EntityDef -> Int -> Text repsertManySql ent n = putManySql' conflictColumns fields ent n where fields = keyAndEntityFields ent- conflictColumns = escape . fieldDB <$> entityKeyFields ent+ conflictColumns = escapeF . fieldDB <$> entityKeyFields ent putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q where- fieldDbToText = escape . fieldDB+ fieldDbToText = escapeF . fieldDB mkAssignment f = T.concat [f, "=EXCLUDED.", f] - table = escape . entityDB $ ent+ table = escapeE . entityDB $ ent columns = Util.commaSeparated $ map fieldDbToText fields placeholders = map (const "?") fields updates = map (mkAssignment . fieldDbToText) fields
+ conn-killed/Main.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, GeneralizedNewtypeDeriving, DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings, QuantifiedConstraints #-}+{-# LANGUAGE TypeApplications #-}+{-# language OverloadedStrings #-}++-- | This executable is a test of the issue raised in #1199.+module Main where++import Prelude hiding (show)+import qualified Prelude++import qualified Data.Text as Text+import Control.Monad.IO.Class+import qualified Control.Monad as Monad+import qualified UnliftIO.Concurrent as Concurrent+import qualified UnliftIO.Exception as Exception+import qualified Database.Persist as Persist+import qualified Database.Persist.Sql as Persist+import qualified Database.Persist.Postgresql as Persist+import qualified Control.Monad.Logger as Logger+import Control.Monad.Logger+import qualified Data.ByteString as BS+import qualified Data.Pool as Pool+import Data.Time+import UnliftIO+import Data.Coerce+import Control.Monad.Trans.Reader+import Control.Monad.Trans++newtype LogPrefixT m a = LogPrefixT { runLogPrefixT :: ReaderT LogStr m a }+ deriving newtype+ (Functor, Applicative, Monad, MonadIO, MonadTrans)++instance MonadLogger m => MonadLogger (LogPrefixT m) where+ monadLoggerLog loc src lvl msg = LogPrefixT $ ReaderT $ \prefix ->+ monadLoggerLog loc src lvl (toLogStr prefix <> toLogStr msg)++deriving newtype instance (forall a b. Coercible a b => Coercible (m a) (m b), MonadUnliftIO m) => MonadUnliftIO (LogPrefixT m)++prefixLogs :: Text.Text -> LogPrefixT m a -> m a+prefixLogs prefix =+ flip runReaderT (toLogStr $! mconcat ["[", prefix, "] "]) . runLogPrefixT++infixr 5 `prefixLogs`+show :: Show a => a -> Text.Text+show = Text.pack . Prelude.show++main :: IO ()+main = runStdoutLoggingT $ Concurrent.myThreadId >>= \tid -> prefixLogs (show tid) $ do++ -- I started a postgres server with:+ -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres+ pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool "postgresql://postgres:secret@localhost:5433/postgres" 1++ logInfoN "creating table..."+ Monad.void $ liftIO $ createTableFoo pool++ liftIO getCurrentTime >>= \now ->+ simulateFailedLongRunningPostgresCall pool++ -- logInfoN "destroying resources"+ -- liftIO $ Pool.destroyAllResources pool++ logInfoN "pg_sleep"+ result :: Either Exception.SomeException [Persist.Single (Maybe String)] <-+ Exception.try . (liftIO . (flip Persist.runSqlPersistMPool) pool) $ do+ Persist.rawSql @(Persist.Single (Maybe String)) "select pg_sleep(2)" []++ -- when we try the above we get back:+ -- 'result: Left libpq: failed (another command is already in progress'+ -- this is because the connection went back into the pool before it was ready+ -- or perhaps it should have been destroyed and a new connection created and put into the pool?+ logInfoN $ "result: " <> show result++createTableFoo :: Pool.Pool Persist.SqlBackend -> IO ()+createTableFoo pool = (flip Persist.runSqlPersistMPool) pool $ do+ Persist.rawExecute "CREATE table if not exists foo(id int);" []++simulateFailedLongRunningPostgresCall+ :: (MonadLogger m, MonadUnliftIO m, forall a b. Coercible a b => Coercible (m a) (m b)) => Pool.Pool Persist.SqlBackend -> m ()+simulateFailedLongRunningPostgresCall pool = do+ threadId <- Concurrent.forkIO+ $ (do+ me <- Concurrent.myThreadId+ prefixLogs (show me) $ do+ let numThings :: Int = 100000000+ logInfoN $ "start inserting " <> show numThings <> " things"++ (`Persist.runSqlPool` pool) $ do+ logInfoN "inside of thing"+ Monad.forM_ [1 .. numThings] $ \i -> do+ Monad.when (i `mod` 1000 == 0) $+ logInfoN $ "Thing #: " <> show i+ Persist.rawExecute "insert into foo values(1);" []+ )+ Concurrent.threadDelay 1000000+ Monad.void $ Concurrent.killThread threadId+ logInfoN "killed thread"
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 2.11.0.1+version: 2.12.0.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>@@ -16,7 +16,7 @@ library build-depends: base >= 4.9 && < 5- , persistent >= 2.11 && < 3+ , persistent >= 2.12 && < 3 , aeson >= 1.0 , attoparsec , blaze-builder@@ -59,7 +59,6 @@ , persistent , persistent-postgresql , persistent-qq- , persistent-template , persistent-test , aeson , bytestring@@ -76,6 +75,26 @@ , time , transformers , unliftio-core+ , unliftio , unordered-containers , vector+ default-language: Haskell2010++executable conn-kill+ buildable: False+ main-is: Main.hs+ hs-source-dirs: conn-killed+ ghc-options: -threaded+ build-depends:+ base+ , persistent-postgresql+ , monad-logger+ , text+ , unliftio+ , time+ , transformers+ , persistent+ , bytestring+ , resource-pool+ , mtl default-language: Haskell2010
test/ArrayAggTest.hs view
@@ -43,7 +43,7 @@ , UserPT "c" $ Just "d" , UserPT "e" Nothing , UserPT "g" $ Just "h" ]- escape <- ((. DBName) . connEscapeName) `fmap` ask+ escape <- asks connEscapeRawName let query = T.concat [ "SELECT array_agg(", escape dbField, ") " , "FROM ", escape "UserPT" ]
test/PgInit.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module PgInit (@@ -41,6 +41,7 @@ -- re-exports import Control.Exception (SomeException)+import UnliftIO import Control.Monad (void, replicateM, liftM, when, forM_) import Control.Monad.Trans.Reader import Data.Aeson (Value(..))@@ -113,17 +114,35 @@ flip runLoggingT (\_ _ _ s -> printDebug s) $ do logInfoN (if travis then "Running in CI" else "CI not detected")- case connType of- RunConnBasic -> withPostgresqlPool connString poolSize $ runSqlPool f- RunConnConf -> do- let conf = PostgresConf- { pgConnStr = connString- , pgPoolStripes = 1- , pgPoolIdleTimeout = 60- , pgPoolSize = poolSize- }- hooks = defaultPostgresConfHooks- withPostgresqlPoolWithConf conf hooks (runSqlPool f)+ let go =+ case connType of+ RunConnBasic ->+ withPostgresqlPool connString poolSize $ runSqlPool f+ RunConnConf -> do+ let conf = PostgresConf+ { pgConnStr = connString+ , pgPoolStripes = 1+ , pgPoolIdleTimeout = 60+ , pgPoolSize = poolSize+ }+ hooks = defaultPostgresConfHooks+ withPostgresqlPoolWithConf conf hooks (runSqlPool f)+ -- horrifying hack :( postgresql is having weird connection failures in+ -- CI, for no reason that i can determine. see this PR for notes:+ -- https://github.com/yesodweb/persistent/pull/1197+ eres <- try go+ case eres of+ Left (err :: SomeException) -> do+ eres' <- try go+ case eres' of+ Left (err' :: SomeException) ->+ if show err == show err'+ then throwIO err+ else throwIO err'+ Right a ->+ pure a+ Right a ->+ pure a runConnAssert :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion runConnAssert actions = do
test/PgIntervalTest.hs view
@@ -33,9 +33,10 @@ truncate' x = (fromIntegral (round (x * 10^6))) / 10^6 specs :: Spec-specs = describe "Postgres Interval Property tests" $- prop "Round trips" $ \time -> runConnAssert $ do- let eg = PgIntervalDb $ PgInterval (truncate' time)- rid <- insert eg- r <- getJust rid- liftIO $ r `shouldBe` eg+specs = do+ describe "Postgres Interval Property tests" $ do+ prop "Round trips" $ \time -> runConnAssert $ do+ let eg = PgIntervalDb $ PgInterval (truncate' time)+ rid <- insert eg+ r <- getJust rid+ liftIO $ r `shouldBe` eg