diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -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 diff --git a/conn-killed/Main.hs b/conn-killed/Main.hs new file mode 100644 --- /dev/null +++ b/conn-killed/Main.hs @@ -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" 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.11.0.1 +version: 2.12.0.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -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 diff --git a/test/ArrayAggTest.hs b/test/ArrayAggTest.hs --- a/test/ArrayAggTest.hs +++ b/test/ArrayAggTest.hs @@ -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" ] diff --git a/test/PgInit.hs b/test/PgInit.hs --- a/test/PgInit.hs +++ b/test/PgInit.hs @@ -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 diff --git a/test/PgIntervalTest.hs b/test/PgIntervalTest.hs --- a/test/PgIntervalTest.hs +++ b/test/PgIntervalTest.hs @@ -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