diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,14 @@ # Changelog for persistent-postgresql +## 2.13.7.0 + +* [#1600](https://github.com/yesodweb/persistent/pull/1600) + * Add `migrateStructured` to `Database.Persist.Postgresql.Internal`. + This allows you to access a structured representation of the proposed migrations + for use in your application. +* [#1547](https://github.com/yesodweb/persistent/pull/1547) + * Bump `libpq` bounds + ## 2.13.6.2 * [#1536](https://github.com/yesodweb/persistent/pull/1536/) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -28,2041 +28,1386 @@ ( withPostgresqlPool , withPostgresqlPoolWithVersion , withPostgresqlPoolWithConf - - , withPostgresqlPoolModified - , withPostgresqlPoolModifiedWithVersion - - , withPostgresqlConn - , withPostgresqlConnWithVersion - - , createPostgresqlPool - , createPostgresqlPoolModified - , createPostgresqlPoolModifiedWithVersion - , createPostgresqlPoolTailored - , createPostgresqlPoolWithConf - , module Database.Persist.Sql - , ConnectionString - , HandleUpdateCollision - , copyField - , copyUnlessNull - , copyUnlessEmpty - , copyUnlessEq - , excludeNotEqualToOriginal - , PostgresConf (..) - , PgInterval (..) - , upsertWhere - , upsertManyWhere - , openSimpleConn - , openSimpleConnWithVersion - , getServerVersion - , getSimpleConn - , tableName - , fieldName - , mockMigration - , migrateEnableExtension - , PostgresConfHooks(..) - , defaultPostgresConfHooks - - , RawPostgresql(..) - , createRawPostgresqlPool - , createRawPostgresqlPoolModified - , createRawPostgresqlPoolModifiedWithVersion - , createRawPostgresqlPoolWithConf - , createBackend - ) where - -import qualified Database.PostgreSQL.LibPQ as LibPQ - -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.FromField as PGFF -import qualified Database.PostgreSQL.Simple.Internal as PG -import Database.PostgreSQL.Simple.Ok (Ok(..)) -import qualified Database.PostgreSQL.Simple.Transaction as PG -import qualified Database.PostgreSQL.Simple.Types as PG - -import Control.Arrow -import Control.Exception (Exception, throw, throwIO) -import Control.Monad -import Control.Monad.Except -import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO) -import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT) -#if !MIN_VERSION_base(4,12,0) -import Control.Monad.Trans.Reader (withReaderT) -#endif -import Control.Monad.Trans.Writer (WriterT(..), runWriterT) -import qualified Data.List.NonEmpty as NEL -import Data.Proxy (Proxy(..)) - -import Data.Acquire (Acquire, mkAcquire, with) -import Data.Aeson -import Data.Aeson.Types (modifyFailure) -import qualified Data.Attoparsec.Text as AT -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Data (Data) -import Data.Either (partitionEithers) -import Data.Function (on) -import Data.Int (Int64) -import Data.IORef -import Data.List as List (find, foldl', groupBy, sort) -import qualified Data.List as List -import Data.List.NonEmpty (NonEmpty) -import qualified Data.Map as Map -import Data.Maybe -import Data.Monoid ((<>)) -import qualified Data.Monoid as Monoid -import Data.Pool (Pool) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import Data.Text.Read (rational) -import System.Environment (getEnvironment) - -#if MIN_VERSION_base(4,12,0) -import Database.Persist.Compatible -#endif -import qualified Data.Vault.Strict as Vault -import Database.Persist.Postgresql.Internal -import Database.Persist.Sql -import qualified Database.Persist.Sql.Util as Util -import Database.Persist.SqlBackend -import Database.Persist.SqlBackend.StatementCache - (StatementCache, mkSimpleStatementCache, mkStatementCache) -import System.IO.Unsafe (unsafePerformIO) - --- | A @libpq@ connection string. A simple example of connection --- string would be @\"host=localhost port=5432 user=test --- dbname=test password=test\"@. Please read libpq's --- documentation at --- --- for more details on how to create such strings. -type ConnectionString = ByteString - --- | PostgresServerVersionError exception. This is thrown when persistent --- is unable to find the version of the postgreSQL server. -data PostgresServerVersionError = PostgresServerVersionError String - -instance Show PostgresServerVersionError where - show (PostgresServerVersionError uniqueMsg) = - "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 --- have been released. --- The provided action should use 'runSqlConn' and *not* 'runReaderT' because --- the former brackets the database action with transaction begin/commit. -withPostgresqlPool :: (MonadLoggerIO m, MonadUnliftIO m) - => ConnectionString - -- ^ Connection string to the database. - -> Int - -- ^ Number of connections to be kept open in - -- the pool. - -> (Pool SqlBackend -> m a) - -- ^ Action to be executed that uses the - -- connection pool. - -> m a -withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci - --- | Same as 'withPostgresPool', but takes a callback for obtaining --- the server version (to work around an Amazon Redshift bug). --- --- @since 2.6.2 -withPostgresqlPoolWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) - => (PG.Connection -> IO (Maybe Double)) - -- ^ Action to perform to get the server version. - -> ConnectionString - -- ^ Connection string to the database. - -> Int - -- ^ Number of connections to be kept open in - -- the pool. - -> (Pool SqlBackend -> m a) - -- ^ Action to be executed that uses the - -- connection pool. - -> m a -withPostgresqlPoolWithVersion getVerDouble ci = do - let getVer = oldGetVersionToNew getVerDouble - withSqlPool $ open' (const $ return ()) getVer id ci - --- | Same as 'withPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. --- --- @since 2.11.0.0 -withPostgresqlPoolWithConf :: (MonadUnliftIO m, MonadLoggerIO m) - => PostgresConf -- ^ Configuration for connecting to Postgres - -> PostgresConfHooks -- ^ Record of callback functions - -> (Pool SqlBackend -> m a) - -- ^ Action to be executed that uses the - -- connection pool. - -> m a -withPostgresqlPoolWithConf conf hooks = do - let getVer = pgConfHooksGetServerVersion hooks - modConn = pgConfHooksAfterCreate hooks - let logFuncToBackend = open' modConn getVer id (pgConnStr conf) - withSqlPoolWithConfig logFuncToBackend (postgresConfToConnectionPoolConfig conf) - --- | Same as 'withPostgresqlPool', but with the 'createPostgresqlPoolModified' --- feature. --- --- @since 2.13.5.0 -withPostgresqlPoolModified - :: (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. - -> (Pool SqlBackend -> m t) - -> m t -withPostgresqlPoolModified = withPostgresqlPoolModifiedWithVersion getServerVersion - --- | Same as 'withPostgresqlPool', but with the --- 'createPostgresqlPoolModifiedWithVersion' feature. --- --- @since 2.13.5.0 -withPostgresqlPoolModifiedWithVersion - :: (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. - -> Int -- ^ Number of connections to be kept open in the pool. - -> (Pool SqlBackend -> m t) - -> m t -withPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do - withSqlPool (open' modConn (oldGetVersionToNew getVerDouble) id ci) - --- | Create a PostgreSQL connection pool. Note that it's your --- responsibility to properly close the connection pool when --- unneeded. Use 'withPostgresqlPool' for an automatic resource --- control. -createPostgresqlPool :: (MonadUnliftIO m, MonadLoggerIO m) - => ConnectionString - -- ^ Connection string to the database. - -> Int - -- ^ Number of connections to be kept open - -- in the pool. - -> m (Pool SqlBackend) -createPostgresqlPool = createPostgresqlPoolModified (const $ return ()) - --- | Same as 'createPostgresqlPool', but additionally takes a callback function --- for some connection-specific tweaking to be performed after connection --- creation. This could be used, for example, to change the schema. For more --- information, see: --- --- --- --- @since 2.1.3 -createPostgresqlPoolModified - :: (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. - -> m (Pool SqlBackend) -createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServerVersion - --- | Same as other similarly-named functions in this module, but takes callbacks for obtaining --- the server version (to work around an Amazon Redshift bug) and connection-specific tweaking --- (to change the schema). --- --- @since 2.6.2 -createPostgresqlPoolModifiedWithVersion - :: (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. - -> Int -- ^ Number of connections to be kept open in the pool. - -> m (Pool SqlBackend) -createPostgresqlPoolModifiedWithVersion = createPostgresqlPoolTailored open' - --- | Same as 'createPostgresqlPoolModifiedWithVersion', but takes a custom connection-creation --- function. --- --- The only time you should reach for this function is if you need to write custom logic for creating --- a connection to the database. --- --- @since 2.13.6 -createPostgresqlPoolTailored - :: (MonadUnliftIO m, MonadLoggerIO m) - => - ( (PG.Connection -> IO ()) - -> (PG.Connection -> IO (NonEmpty Word)) - -> ((PG.Connection -> SqlBackend) -> PG.Connection -> SqlBackend) - -> ConnectionString -> LogFunc -> IO SqlBackend - ) -- ^ Action that creates a postgresql connection (please see documentation on the un-exported @open'@ function in this same module. - -> (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. - -> Int -- ^ Number of connections to be kept open in the pool. - -> m (Pool SqlBackend) -createPostgresqlPoolTailored createConnection getVerDouble modConn ci = do - let getVer = oldGetVersionToNew getVerDouble - createSqlPool $ createConnection modConn getVer id ci - --- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. --- --- @since 2.11.0.0 -createPostgresqlPoolWithConf - :: (MonadUnliftIO m, MonadLoggerIO m) - => PostgresConf -- ^ Configuration for connecting to Postgres - -> PostgresConfHooks -- ^ Record of callback functions - -> m (Pool SqlBackend) -createPostgresqlPoolWithConf conf hooks = do - let getVer = pgConfHooksGetServerVersion hooks - modConn = pgConfHooksAfterCreate hooks - createSqlPoolWithConfig (open' modConn getVer id (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf) - -postgresConfToConnectionPoolConfig :: PostgresConf -> ConnectionPoolConfig -postgresConfToConnectionPoolConfig conf = - ConnectionPoolConfig - { connectionPoolConfigStripes = pgPoolStripes conf - , connectionPoolConfigIdleTimeout = fromInteger $ pgPoolIdleTimeout conf - , connectionPoolConfigSize = pgPoolSize conf - } - --- | 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, MonadLoggerIO m) - => ConnectionString -> (SqlBackend -> m a) -> m a -withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion - --- | Same as 'withPostgresqlConn', but takes a callback for obtaining --- the server version (to work around an Amazon Redshift bug). --- --- @since 2.6.2 -withPostgresqlConnWithVersion :: (MonadUnliftIO m, MonadLoggerIO m) - => (PG.Connection -> IO (Maybe Double)) - -> ConnectionString - -> (SqlBackend -> m a) - -> m a -withPostgresqlConnWithVersion getVerDouble = do - let getVer = oldGetVersionToNew getVerDouble - withSqlConn . open' (const $ return ()) getVer id - -open' - :: (PG.Connection -> IO ()) - -> (PG.Connection -> IO (NonEmpty Word)) - -> ((PG.Connection -> SqlBackend) -> PG.Connection -> backend) - -- ^ How to construct the actual backend type desired. For most uses, - -- this is just 'id', since the desired backend type is 'SqlBackend'. - -- But some callers want a @'RawPostgresql' 'SqlBackend'@, and will - -- pass in 'withRawConnection'. - -> ConnectionString -> LogFunc -> IO backend -open' modConn getVer constructor cstr logFunc = do - conn <- PG.connectPostgreSQL cstr - modConn conn - ver <- getVer conn - smap <- newIORef mempty - return $ constructor (createBackend logFunc ver smap) conn - --- | Gets the PostgreSQL server version --- --- @since 2.13.6 -getServerVersion :: PG.Connection -> IO (Maybe Double) -getServerVersion conn = do - [PG.Only version] <- PG.query_ conn "show server_version"; - let version' = rational version - --- λ> rational "9.8.3" - --- Right (9.8,".3") - --- λ> rational "9.8.3.5" - --- Right (9.8,".3.5") - case version' of - Right (a,_) -> return $ Just a - Left err -> throwIO $ PostgresServerVersionError err - -getServerVersionNonEmpty :: PG.Connection -> IO (NonEmpty Word) -getServerVersionNonEmpty conn = do - [PG.Only version] <- PG.query_ conn "show server_version"; - case AT.parseOnly parseVersion (T.pack version) of - Left err -> throwIO $ PostgresServerVersionError $ "Parse failure on: " <> version <> ". Error: " <> err - Right versionComponents -> case NEL.nonEmpty versionComponents of - Nothing -> throwIO $ PostgresServerVersionError $ "Empty Postgres version string: " <> version - Just neVersion -> pure neVersion - - where - -- Partially copied from the `versions` package - -- Typically server_version gives e.g. 12.3 - -- In Persistent's CI, we get "12.4 (Debian 12.4-1.pgdg100+1)", so we ignore the trailing data. - parseVersion = AT.decimal `AT.sepBy` AT.char '.' - --- | Choose upsert sql generation function based on postgresql version. --- PostgreSQL version >= 9.5 supports native upsert feature, --- so depending upon that we have to choose how the sql query is generated. --- upsertFunction :: Double -> Maybe (EntityDef -> Text -> Text) -upsertFunction :: a -> NonEmpty Word -> Maybe a -upsertFunction f version = if (version >= postgres9dot5) - then Just f - else Nothing - where - -postgres9dot5 :: NonEmpty Word -postgres9dot5 = 9 NEL.:| [5] - --- | If the user doesn't supply a Postgres version, we assume this version. --- --- This is currently below any version-specific features Persistent uses. -minimumPostgresVersion :: NonEmpty Word -minimumPostgresVersion = 9 NEL.:| [4] - -oldGetVersionToNew :: (PG.Connection -> IO (Maybe Double)) -> (PG.Connection -> IO (NonEmpty Word)) -oldGetVersionToNew oldFn = \conn -> do - mDouble <- oldFn conn - case mDouble of - Nothing -> pure minimumPostgresVersion - Just double -> do - let (major, minor) = properFraction double - pure $ major NEL.:| [floor minor] - --- | Generate a 'SqlBackend' from a 'PG.Connection'. -openSimpleConn :: LogFunc -> PG.Connection -> IO SqlBackend -openSimpleConn = openSimpleConnWithVersion getServerVersion - --- | Generate a 'SqlBackend' from a 'PG.Connection', but takes a callback for --- obtaining the server version. --- --- @since 2.9.1 -openSimpleConnWithVersion :: (PG.Connection -> IO (Maybe Double)) -> LogFunc -> PG.Connection -> IO SqlBackend -openSimpleConnWithVersion getVerDouble logFunc conn = do - smap <- newIORef mempty - serverVersion <- oldGetVersionToNew getVerDouble conn - return $ createBackend logFunc serverVersion smap conn - -underlyingConnectionKey :: Vault.Key PG.Connection -underlyingConnectionKey = unsafePerformIO Vault.newKey -{-# NOINLINE underlyingConnectionKey #-} - --- | Access underlying connection, returning 'Nothing' if the 'SqlBackend' --- provided isn't backed by postgresql-simple. --- --- @since 2.13.0 -getSimpleConn :: (BackendCompatible SqlBackend backend) => backend -> Maybe PG.Connection -getSimpleConn = Vault.lookup underlyingConnectionKey <$> getConnVault - --- | Create the backend given a logging function, server version, mutable statement cell, --- and connection. --- --- @since 2.13.6 -createBackend :: LogFunc -> NonEmpty Word - -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend -createBackend logFunc serverVersion smap conn = - maybe id setConnPutManySql (upsertFunction putManySql serverVersion) $ - maybe id setConnUpsertSql (upsertFunction upsertSql' serverVersion) $ - setConnInsertManySql insertManySql' $ - maybe id setConnRepsertManySql (upsertFunction repsertManySql serverVersion) $ - modifyConnVault (Vault.insert underlyingConnectionKey conn) $ mkSqlBackend MkSqlBackendArgs - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connClose = PG.close conn - , connMigrateSql = migrate' - , connBegin = \_ mIsolation -> case mIsolation of - Nothing -> PG.begin conn - Just iso -> PG.beginLevel (case iso of - ReadUncommitted -> PG.ReadCommitted -- PG Upgrades uncommitted reads to committed anyways - ReadCommitted -> PG.ReadCommitted - RepeatableRead -> PG.RepeatableRead - Serializable -> PG.Serializable) conn - , connCommit = const $ PG.commit conn - , connRollback = const $ PG.rollback conn - , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . getEntityDBName - , connEscapeRawName = escape - , connNoLimit = "LIMIT ALL" - , connRDBMS = "postgresql" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" - , connLogFunc = logFunc - } - -prepare' :: PG.Connection -> Text -> IO Statement -prepare' conn sql = do - let query = PG.Query (T.encodeUtf8 sql) - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = execute' conn query - , stmtQuery = withStmt' conn query - } - -insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult -insertSql' ent vals = - case getEntityId ent of - EntityIdNaturalKey _pdef -> - ISRManyKeys sql vals - EntityIdField field -> - ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB field)) - where - (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) - sql = T.concat - [ "INSERT INTO " - , escapeE $ getEntityDBName ent - , if null (getEntityFields ent) - then " DEFAULT VALUES" - else T.concat - [ "(" - , T.intercalate "," fieldNames - , ") VALUES(" - , T.intercalate "," placeholders - , ")" - ] - ] - -upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text -upsertSql' ent uniqs updateVal = - T.concat - [ "INSERT INTO " - , escapeE (getEntityDBName ent) - , "(" - , T.intercalate "," fieldNames - , ") VALUES (" - , T.intercalate "," placeholders - , ") ON CONFLICT (" - , T.intercalate "," $ map (escapeF . snd) (NEL.toList uniqs) - , ") DO UPDATE SET " - , updateVal - , " WHERE " - , wher - , " RETURNING ??" - ] - where - (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) - - wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs - - singleClause :: FieldNameDB -> Text - singleClause field = escapeE (getEntityDBName 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 escapeF) - sql = T.concat - [ "INSERT INTO " - , escapeE (getEntityDBName ent) - , "(" - , T.intercalate "," fieldNames - , ") VALUES (" - , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," placeholders - , ") RETURNING " - , Util.commaSeparated $ NEL.toList $ Util.dbIdColumnsEsc escapeF ent - ] - - -execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64 -execute' conn query vals = PG.execute conn query (map P vals) - -withStmt' :: MonadIO m - => PG.Connection - -> PG.Query - -> [PersistValue] - -> Acquire (ConduitM () [PersistValue] m ()) -withStmt' conn query vals = - pull `fmap` mkAcquire openS closeS - where - openS = do - -- Construct raw query - rawquery <- PG.formatQuery conn query (map P vals) - - -- Take raw connection - (rt, rr, rc, ids) <- PG.withConnection conn $ \rawconn -> do - -- Execute query - mret <- LibPQ.exec rawconn rawquery - case mret of - Nothing -> do - merr <- LibPQ.errorMessage rawconn - fail $ case merr of - Nothing -> "Postgresql.withStmt': unknown error" - Just e -> "Postgresql.withStmt': " ++ B8.unpack e - Just ret -> do - -- Check result status - status <- LibPQ.resultStatus ret - case status of - LibPQ.TuplesOk -> return () - _ -> PG.throwResultError "Postgresql.withStmt': bad result status " ret status - - -- Get number and type of columns - cols <- LibPQ.nfields ret - oids <- forM [0..cols-1] $ \col -> fmap ((,) col) (LibPQ.ftype ret col) - -- Ready to go! - rowRef <- newIORef (LibPQ.Row 0) - rowCount <- LibPQ.ntuples ret - return (ret, rowRef, rowCount, oids) - let getters - = map (\(col, oid) -> getGetter oid $ PG.Field rt col oid) ids - return (rt, rr, rc, getters) - - closeS (ret, _, _, _) = LibPQ.unsafeFreeResult ret - - pull x = do - y <- liftIO $ pullS x - case y of - Nothing -> return () - Just z -> yield z >> pull x - - pullS (ret, rowRef, rowCount, getters) = do - row <- atomicModifyIORef rowRef (\r -> (r+1, r)) - if row == rowCount - then return Nothing - else fmap Just $ forM (zip getters [0..]) $ \(getter, col) -> do - mbs <- LibPQ.getvalue' ret row col - case mbs of - Nothing -> - -- getvalue' verified that the value is NULL. - -- However, that does not mean that there are - -- no NULL values inside the value (e.g., if - -- we're dealing with an array of optional values). - return PersistNull - Just bs -> do - ok <- PGFF.runConversion (getter mbs) conn - bs `seq` case ok of - Errors (exc:_) -> throw exc - Errors [] -> error "Got an Errors, but no exceptions" - Ok v -> return v - -doesTableExist :: (Text -> IO Statement) - -> EntityNameDB - -> IO Bool -doesTableExist getter (EntityNameDB name) = do - stmt <- getter sql - with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) - where - sql = "SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'" - <> " AND schemaname != 'information_schema' AND tablename=?" - vals = [PersistText name] - - start = await >>= maybe (error "No results when checking doesTableExist") start' - start' [PersistInt64 0] = finish False - start' [PersistInt64 1] = finish True - start' res = error $ "doesTableExist returned unexpected result: " ++ show res - finish x = await >>= maybe (return x) (error "Too many rows returned in doesTableExist") - -migrate' :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] CautiousMigration) -migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ do - old <- getColumns getter entity newcols' - case partitionEithers old of - ([], old'') -> do - exists' <- - if null old - then doesTableExist getter name - else return True - return $ Right $ migrationText exists' old'' - (errs, _) -> return $ Left errs - where - name = getEntityDBName entity - (newcols', udefs, fdefs) = postgresMkColumns allDefs entity - migrationText exists' old'' - | not exists' = - createText newcols fdefs udspair - | otherwise = - let (acs, ats) = - getAlters allDefs entity (newcols, udspair) old' - acs' = map (AlterColumn name) acs - ats' = map (AlterTable name) ats - in - acs' ++ ats' - where - old' = partitionEithers old'' - newcols = filter (not . safeToRemove entity . cName) newcols' - udspair = map udToPair udefs - -- Check for table existence if there are no columns, workaround - -- for https://github.com/yesodweb/persistent/issues/152 - - createText newcols fdefs_ udspair = - (addTable newcols entity) : uniques ++ references ++ foreignsAlt - where - uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] - references = - mapMaybe - (\Column { cName, cReference } -> - getAddReference allDefs entity cName =<< cReference - ) - newcols - foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs_ - -mkForeignAlt - :: EntityDef - -> ForeignDef - -> Maybe AlterDB -mkForeignAlt entity fdef = pure $ AlterColumn tableName_ addReference - where - tableName_ = getEntityDBName entity - addReference = - AddReference - (foreignRefTableDBName fdef) - constraintName - childfields - escapedParentFields - (foreignFieldCascade fdef) - constraintName = - foreignConstraintNameDBName fdef - (childfields, parentfields) = - unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - escapedParentFields = - 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! - , escapeE name - , "(" - , idtxt - , if null nonIdCols then "" else "," - , T.intercalate "," $ map showColumn nonIdCols - , ")" - ] - where - nonIdCols = - case entityPrimary entity of - Just _ -> - cols - _ -> - filter keepField cols - where - keepField c = - Just (cName c) /= fmap fieldDB (getEntityIdField entity) - && not (safeToRemove entity (cName c)) - - name = - getEntityDBName entity - idtxt = - case getEntityId entity of - EntityIdNaturalKey pdef -> - T.concat - [ " PRIMARY KEY (" - , T.intercalate "," $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef - , ")" - ] - EntityIdField field -> - let defText = defaultAttribute $ fieldAttrs field - sType = fieldSqlType field - in T.concat - [ escapeF $ fieldDB field - , maySerial sType defText - , " PRIMARY KEY UNIQUE" - , mayDefault defText - ] - -maySerial :: SqlType -> Maybe Text -> Text -maySerial SqlInt64 Nothing = " SERIAL8 " -maySerial sType _ = " " <> showSqlType sType - -mayDefault :: Maybe Text -> Text -mayDefault def = case def of - Nothing -> "" - Just d -> " DEFAULT " <> d - -type SafeToRemove = Bool - -data AlterColumn - = 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 - -data AlterTable - = AddUniqueConstraint ConstraintNameDB [FieldNameDB] - | DropConstraint ConstraintNameDB - deriving Show - -data AlterDB = AddTable Text - | 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 (ConstraintNameDB, [FieldNameDB]))] -getColumns getter def cols = do - let sqlv = T.concat - [ "SELECT " - , "column_name " - , ",is_nullable " - , ",COALESCE(domain_name, udt_name)" -- See DOMAINS below - , ",column_default " - , ",generation_expression " - , ",numeric_precision " - , ",numeric_scale " - , ",character_maximum_length " - , "FROM information_schema.columns " - , "WHERE table_catalog=current_database() " - , "AND table_schema=current_schema() " - , "AND table_name=? " - ] - --- DOMAINS Postgres supports the concept of domains, which are data types --- with optional constraints. An app might make an "email" domain over the --- varchar type, with a CHECK that the emails are valid In this case the --- generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN --- foo TYPE email This code exists to use the domain name (email), instead --- of the underlying type (varchar). This is tested in --- EquivalentTypeTest.hs - - stmt <- getter sqlv - let vals = - [ PersistText $ unEntityNameDB $ getEntityDBName def - ] - columns <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| processColumns .| CL.consume) - let sqlc = T.concat - [ "SELECT " - , "c.constraint_name, " - , "c.column_name " - , "FROM information_schema.key_column_usage AS c, " - , "information_schema.table_constraints AS k " - , "WHERE c.table_catalog=current_database() " - , "AND c.table_catalog=k.table_catalog " - , "AND c.table_schema=current_schema() " - , "AND c.table_schema=k.table_schema " - , "AND c.table_name=? " - , "AND c.table_name=k.table_name " - , "AND c.constraint_name=k.constraint_name " - , "AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') " - , "ORDER BY c.constraint_name, c.column_name" - ] - - stmt' <- getter sqlc - - us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) - return $ columns ++ us - where - refMap = - fmap (\cr -> (crTableName cr, crConstraintName cr)) - $ Map.fromList - $ List.foldl' ref [] cols - where - ref rs c = - maybe rs (\r -> (unFieldNameDB $ cName c, r) : rs) (cReference c) - getAll = - CL.mapM $ \x -> - pure $ case x of - [PersistText con, PersistText col] -> - (con, col) - [PersistByteString con, PersistByteString col] -> - (T.decodeUtf8 con, T.decodeUtf8 col) - o -> - error $ "unexpected datatype returned for postgres o="++show o - helperU = do - rows <- getAll .| CL.consume - return $ map (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) - $ groupBy ((==) `on` fst) rows - processColumns = - CL.mapM $ \x'@((PersistText cname) : _) -> do - col <- liftIO $ getColumn getter (getEntityDBName def) x' (Map.lookup cname refMap) - pure $ case col of - Left e -> Left e - Right c -> Right $ Left c - --- | Check if a column name is listed as the "safe to remove" in the entity --- list. -safeToRemove :: EntityDef -> FieldNameDB -> Bool -safeToRemove def (FieldNameDB colName) - = any (elem FieldAttrSafeToRemove . fieldAttrs) - $ filter ((== FieldNameDB colName) . fieldDB) - $ allEntityFields - where - allEntityFields = - getEntityFieldsDatabase def <> case getEntityId def of - EntityIdField fdef -> - [fdef] - _ -> - [] - -getAlters :: [EntityDef] - -> EntityDef - -> ([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 -> 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 - :: [(ConstraintNameDB, [FieldNameDB])] - -> [(ConstraintNameDB, [FieldNameDB])] - -> [AlterTable] - getAltersU [] old = - map DropConstraint $ filter (not . isManual) $ map fst old - getAltersU ((name, cols):news) old = - case lookup name old of - Nothing -> - AddUniqueConstraint name cols : getAltersU news old - Just ocols -> - let old' = filter (\(x, _) -> x /= name) old - in if sort cols == sort ocols - then getAltersU news old' - else DropConstraint name - : AddUniqueConstraint name cols - : getAltersU news old' - - -- Don't drop constraints which were manually added. - isManual (ConstraintNameDB x) = "__manual_" `T.isPrefixOf` x - -getColumn - :: (Text -> IO Statement) - -> EntityNameDB - -> [PersistValue] - -> Maybe (EntityNameDB, ConstraintNameDB) - -> IO (Either Text Column) -getColumn getter tableName' [ PersistText columnName - , PersistText isNullable - , PersistText typeName - , defaultValue - , generationExpression - , numericPrecision - , numericScale - , maxlen - ] refName_ = runExceptT $ do - defaultValue' <- - case defaultValue of - PersistNull -> - pure Nothing - PersistText t -> - pure $ Just t - _ -> - throwError $ T.pack $ "Invalid default column: " ++ show defaultValue - - generationExpression' <- - case generationExpression of - PersistNull -> - pure Nothing - PersistText t -> - pure $ Just t - _ -> - throwError $ T.pack $ "Invalid generated column: " ++ show generationExpression - - let typeStr = - case maxlen of - PersistInt64 n -> - T.concat [typeName, "(", T.pack (show n), ")"] - _ -> - typeName - - t <- getType typeStr - - let cname = FieldNameDB columnName - - ref <- lift $ fmap join $ traverse (getRef cname) refName_ - - return Column - { cName = cname - , cNull = isNullable == "YES" - , cSqlType = t - , cDefault = fmap stripSuffixes defaultValue' - , cGenerated = fmap stripSuffixes generationExpression' - , cDefaultConstraintName = Nothing - , cMaxLen = Nothing - , cReference = fmap (\(a,b,c,d) -> ColumnReference a b (mkCascade c d)) ref - } - - where - - mkCascade updText delText = - FieldCascade - { fcOnUpdate = parseCascade updText - , fcOnDelete = parseCascade delText - } - - parseCascade txt = - case txt of - "NO ACTION" -> - Nothing - "CASCADE" -> - Just Cascade - "SET NULL" -> - Just SetNull - "SET DEFAULT" -> - Just SetDefault - "RESTRICT" -> - Just Restrict - _ -> - error $ "Unexpected value in parseCascade: " <> show txt - - stripSuffixes t = - loop' - [ "::character varying" - , "::text" - ] - where - loop' [] = t - loop' (p:ps) = - case T.stripSuffix p t of - Nothing -> loop' ps - Just t' -> t' - - getRef cname (_, refName') = do - let sql = T.concat - [ "SELECT DISTINCT " - , "ccu.table_name, " - , "tc.constraint_name, " - , "rc.update_rule, " - , "rc.delete_rule " - , "FROM information_schema.constraint_column_usage ccu " - , "INNER JOIN information_schema.key_column_usage kcu " - , " ON ccu.constraint_name = kcu.constraint_name " - , "INNER JOIN information_schema.table_constraints tc " - , " ON tc.constraint_name = kcu.constraint_name " - , "LEFT JOIN information_schema.referential_constraints AS rc" - , " ON rc.constraint_name = ccu.constraint_name " - , "WHERE tc.constraint_type='FOREIGN KEY' " - , "AND kcu.ordinal_position=1 " - , "AND kcu.table_name=? " - , "AND kcu.column_name=? " - , "AND tc.constraint_name=?" - ] - stmt <- getter sql - cntrs <- - with - (stmtQuery stmt - [ PersistText $ unEntityNameDB tableName' - , PersistText $ unFieldNameDB cname - , PersistText $ unConstraintNameDB refName' - ] - ) - (\src -> runConduit $ src .| CL.consume) - case cntrs of - [] -> - return Nothing - [[PersistText table, PersistText constraint, PersistText updRule, PersistText 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 (unEntityNameDB tableName') - , " and column: " - , T.unpack (unFieldNameDB cname) - , " but got: " - , show xs - ] - - getType "int4" = pure SqlInt32 - getType "int8" = pure SqlInt64 - getType "varchar" = pure SqlString - getType "text" = pure SqlString - getType "date" = pure SqlDay - getType "bool" = pure SqlBool - getType "timestamptz" = pure SqlDayTime - getType "float4" = pure SqlReal - getType "float8" = pure SqlReal - getType "bytea" = pure SqlBlob - getType "time" = pure SqlTime - getType "numeric" = getNumeric numericPrecision numericScale - getType a = pure $ SqlOther a - - getNumeric (PersistInt64 a) (PersistInt64 b) = - pure $ SqlNumeric (fromIntegral a) (fromIntegral b) - - getNumeric PersistNull PersistNull = throwError $ T.concat - [ "No precision and scale were specified for the column: " - , columnName - , " in table: " - , 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)." - ] - - getNumeric a b = throwError $ T.concat - [ "Can not get numeric field precision for the column: " - , columnName - , " in table: " - , unEntityNameDB tableName' - , ". Expected an integer for both precision and scale, " - , "got: " - , T.pack $ show a - , " and " - , T.pack $ show b - , ", respectively." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] - -getColumn _ _ columnName _ = - return $ Left $ T.pack $ "Invalid result from information_schema: " ++ show columnName - --- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer -sqlTypeEq :: SqlType -> SqlType -> Bool -sqlTypeEq x y = - let - -- Non exhaustive helper to map postgres aliases to the same name. Based on - -- https://www.postgresql.org/docs/9.5/datatype.html. - -- This prevents needless `ALTER TYPE`s when the type is the same. - normalize "int8" = "bigint" - normalize "serial8" = "bigserial" - normalize v = v - in - normalize (T.toCaseFold (showSqlType x)) == normalize (T.toCaseFold (showSqlType y)) - -findAlters - :: [EntityDef] - -- ^ The list of all entity definitions that persistent is aware of. - -> EntityDef - -- ^ The entity definition for the entity that we're working on. - -> Column - -- ^ The column that we're searching for potential alterations for. - -> [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 -> - ([Add' col], cols) - Just (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') -> - let refDrop Nothing = [] - refDrop (Just ColumnReference {crConstraintName=cname}) = - [DropReference cname] - - refAdd Nothing = [] - refAdd (Just colRef) = - case find ((== crTableName colRef) . getEntityDBName) defs of - Just refdef - | Just _oldName /= fmap fieldDB (getEntityIdField edef) - -> - [AddReference - (crTableName colRef) - (crConstraintName colRef) - [name] - (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef) - (crFieldCascade colRef) - ] - Just _ -> [] - Nothing -> - error $ "could not find the entityDef for reftable[" - ++ show (crTableName colRef) ++ "]" - modRef = - if equivalentRef ref ref' - then [] - else refDrop ref' ++ refAdd ref - modNull = case (isNull, isNull') of - (True, False) -> do - guard $ Just name /= fmap fieldDB (getEntityIdField edef) - pure (IsNull col) - (False, True) -> - let up = case def of - Nothing -> id - Just s -> (:) (Update' col s) - in up [NotNull col] - _ -> [] - modType - | sqlTypeEq sqltype sqltype' = [] - -- When converting from Persistent pre-2.0 databases, we - -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is - -- treated as UTC. - | sqltype == SqlDayTime && sqltype' == SqlOther "timestamp" = - [ChangeType col sqltype $ T.concat - [ " USING " - , escapeF name - , " AT TIME ZONE 'UTC'" - ]] - | otherwise = [ChangeType col sqltype ""] - modDef = - if def == def' - || isJust (T.stripPrefix "nextval" =<< def') - then [] - else - case def of - Nothing -> [NoDefault col] - Just s -> [Default col s] - dropSafe = - if safeToRemove edef name - then error "wtf" [Drop col True] - else [] - in - ( modRef ++ modDef ++ modNull ++ modType ++ dropSafe - , filter (\c -> cName c /= name) cols - ) - --- We check if we should alter a foreign key. This is almost an equality check, --- except we consider 'Nothing' and 'Just Restrict' equivalent. -equivalentRef :: Maybe ColumnReference -> Maybe ColumnReference -> Bool -equivalentRef Nothing Nothing = True -equivalentRef (Just cr1) (Just cr2) = - crTableName cr1 == crTableName cr2 - && crConstraintName cr1 == crConstraintName cr2 - && eqCascade (fcOnUpdate $ crFieldCascade cr1) (fcOnUpdate $ crFieldCascade cr2) - && eqCascade (fcOnDelete $ crFieldCascade cr1) (fcOnDelete $ crFieldCascade cr2) - where - eqCascade :: Maybe CascadeAction -> Maybe CascadeAction -> Bool - eqCascade Nothing Nothing = True - eqCascade Nothing (Just Restrict) = True - eqCascade (Just Restrict) Nothing = True - eqCascade (Just cs1) (Just cs2) = cs1 == cs2 - eqCascade _ _ = False -equivalentRef _ _ = False - --- | Get the references to be added to a table for the given column. -getAddReference - :: [EntityDef] - -> EntityDef - -> FieldNameDB - -> ColumnReference - -> Maybe AlterDB -getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do - guard $ Just cname /= fmap fieldDB (getEntityIdField entity) - pure $ AlterColumn - table - (AddReference s constraintName [cname] id_ (crFieldCascade cr) - ) - where - table = getEntityDBName entity - id_ = - fromMaybe - (error $ "Could not find ID of entity " ++ show s) - $ do - entDef <- find ((== s) . getEntityDBName) allDefs - return $ NEL.toList $ Util.dbIdColumnsEsc escapeF entDef - -showColumn :: Column -> Text -showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = T.concat - [ escapeF n - , " " - , showSqlType sqlType' - , " " - , if nu then "NULL" else "NOT NULL" - , case def of - Nothing -> "" - Just s -> " DEFAULT " <> s - , case gen of - Nothing -> "" - Just s -> " GENERATED ALWAYS AS (" <> s <> ") STORED" - ] - -showSqlType :: SqlType -> Text -showSqlType SqlString = "VARCHAR" -showSqlType SqlInt32 = "INT4" -showSqlType SqlInt64 = "INT8" -showSqlType SqlReal = "DOUBLE PRECISION" -showSqlType (SqlNumeric s prec) = T.concat [ "NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")" ] -showSqlType SqlDay = "DATE" -showSqlType SqlTime = "TIME" -showSqlType SqlDayTime = "TIMESTAMP WITH TIME ZONE" -showSqlType SqlBlob = "BYTEA" -showSqlType SqlBool = "BOOLEAN" - --- Added for aliasing issues re: https://github.com/yesodweb/yesod/issues/682 -showSqlType (SqlOther (T.toLower -> "integer")) = "INT4" - -showSqlType (SqlOther t) = t - -showAlterDb :: AlterDB -> (Bool, Text) -showAlterDb (AddTable s) = (False, s) -showAlterDb (AlterColumn t ac) = - (isUnsafe ac, showAlter t ac) - where - isUnsafe (Drop _ safeRemove) = not safeRemove - isUnsafe _ = False -showAlterDb (AlterTable t at) = (False, showAlterTable t at) - -showAlterTable :: EntityNameDB -> AlterTable -> Text -showAlterTable table (AddUniqueConstraint cname cols) = T.concat - [ "ALTER TABLE " - , escapeE table - , " ADD CONSTRAINT " - , escapeC cname - , " UNIQUE(" - , T.intercalate "," $ map escapeF cols - , ")" - ] -showAlterTable table (DropConstraint cname) = T.concat - [ "ALTER TABLE " - , escapeE table - , " DROP CONSTRAINT " - , escapeC cname - ] - -showAlter :: EntityNameDB -> AlterColumn -> Text -showAlter table (ChangeType c t extra) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " TYPE " - , showSqlType t - , extra - ] -showAlter table (IsNull c) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " DROP NOT NULL" - ] -showAlter table (NotNull c) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " SET NOT NULL" - ] -showAlter table (Add' col) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ADD COLUMN " - , showColumn col - ] -showAlter table (Drop c _) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " DROP COLUMN " - , escapeF (cName c) - ] -showAlter table (Default c s) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " SET DEFAULT " - , s - ] -showAlter table (NoDefault c) = T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " DROP DEFAULT" - ] -showAlter table (Update' c s) = T.concat - [ "UPDATE " - , escapeE table - , " SET " - , escapeF (cName c) - , "=" - , s - , " WHERE " - , escapeF (cName c) - , " IS NULL" - ] -showAlter table (AddReference reftable fkeyname t2 id2 cascade) = T.concat - [ "ALTER TABLE " - , escapeE table - , " ADD CONSTRAINT " - , escapeC fkeyname - , " FOREIGN KEY(" - , T.intercalate "," $ map escapeF t2 - , ") REFERENCES " - , escapeE reftable - , "(" - , T.intercalate "," id2 - , ")" - ] <> renderFieldCascade cascade -showAlter table (DropReference cname) = T.concat - [ "ALTER TABLE " - , escapeE table - , " DROP CONSTRAINT " - , escapeC cname - ] - --- | Get the SQL string for the table that a PersistEntity represents. --- Useful for raw SQL queries. -tableName :: (PersistEntity record) => record -> Text -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 = escapeF . fieldDBName - -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 "" = "" - go ('"':xs) = "\"\"" ++ go xs - go (x:xs) = x : go xs - --- | Information required to connect to a PostgreSQL database --- using @persistent@'s generic facilities. These values are the --- same that are given to 'withPostgresqlPool'. -data PostgresConf = PostgresConf - { pgConnStr :: ConnectionString - -- ^ The connection string. - - -- TODO: Currently stripes, idle timeout, and pool size are all separate fields - -- When Persistent next does a large breaking release (3.0?), we should consider making these just a single ConnectionPoolConfig value - -- - -- Currently there the idle timeout is an Integer, rather than resource-pool's NominalDiffTime type. - -- This is because the time package only recently added the Read instance for NominalDiffTime. - -- Future TODO: Consider removing the Read instance, and/or making the idle timeout a NominalDiffTime. - - , pgPoolStripes :: Int - -- ^ How many stripes to divide the pool into. See "Data.Pool" for details. - -- @since 2.11.0.0 - , pgPoolIdleTimeout :: Integer -- Ideally this would be a NominalDiffTime, but that type lacks a Read instance https://github.com/haskell/time/issues/130 - -- ^ How long connections can remain idle before being disposed of, in seconds. - -- @since 2.11.0.0 - , pgPoolSize :: Int - -- ^ How many connections should be held in the connection pool. - } deriving (Show, Read, Data) - -instance FromJSON PostgresConf where - parseJSON v = modifyFailure ("Persistent: error loading PostgreSQL conf: " ++) $ - flip (withObject "PostgresConf") v $ \o -> do - let defaultPoolConfig = defaultConnectionPoolConfig - database <- o .: "database" - host <- o .: "host" - port <- o .:? "port" .!= 5432 - user <- o .: "user" - password <- o .: "password" - poolSize <- o .:? "poolsize" .!= (connectionPoolConfigSize defaultPoolConfig) - poolStripes <- o .:? "stripes" .!= (connectionPoolConfigStripes defaultPoolConfig) - poolIdleTimeout <- o .:? "idleTimeout" .!= (floor $ connectionPoolConfigIdleTimeout defaultPoolConfig) - let ci = PG.ConnectInfo - { PG.connectHost = host - , PG.connectPort = port - , PG.connectUser = user - , PG.connectPassword = password - , PG.connectDatabase = database - } - cstr = PG.postgreSQLConnectionString ci - return $ PostgresConf cstr poolStripes poolIdleTimeout poolSize -instance PersistConfig PostgresConf where - type PersistConfigBackend PostgresConf = SqlPersistT - type PersistConfigPool PostgresConf = ConnectionPool - createPoolConfig conf = runNoLoggingT $ createPostgresqlPoolWithConf conf defaultPostgresConfHooks - runPool _ = runSqlPool - loadConfig = parseJSON - - applyEnv c0 = do - env <- getEnvironment - return $ addUser env - $ addPass env - $ addDatabase env - $ addPort env - $ addHost env c0 - where - addParam param val c = - c { pgConnStr = B8.concat [pgConnStr c, " ", param, "='", pgescape val, "'"] } - - pgescape = B8.pack . go - where - go ('\'':rest) = '\\' : '\'' : go rest - go ('\\':rest) = '\\' : '\\' : go rest - go ( x :rest) = x : go rest - go [] = [] - - maybeAddParam param envvar env = - maybe id (addParam param) $ - lookup envvar env - - addHost = maybeAddParam "host" "PGHOST" - addPort = maybeAddParam "port" "PGPORT" - addUser = maybeAddParam "user" "PGUSER" - addPass = maybeAddParam "password" "PGPASS" - addDatabase = maybeAddParam "dbname" "PGDATABASE" - --- | Hooks for configuring the Persistent/its connection to Postgres --- --- @since 2.11.0 -data PostgresConfHooks = PostgresConfHooks - { pgConfHooksGetServerVersion :: PG.Connection -> IO (NonEmpty Word) - -- ^ Function to get the version of Postgres - -- - -- The default implementation queries the server with "show server_version". - -- Some variants of Postgres, such as Redshift, don't support showing the version. - -- It's recommended you return a hardcoded version in those cases. - -- - -- @since 2.11.0 - , pgConfHooksAfterCreate :: PG.Connection -> IO () - -- ^ Action to perform after a connection is created. - -- - -- Typical uses of this are modifying the connection (e.g. to set the schema) or logging a connection being created. - -- - -- The default implementation does nothing. - -- - -- @since 2.11.0 - } - --- | Default settings for 'PostgresConfHooks'. See the individual fields of 'PostgresConfHooks' for the default values. --- --- @since 2.11.0 -defaultPostgresConfHooks :: PostgresConfHooks -defaultPostgresConfHooks = PostgresConfHooks - { pgConfHooksGetServerVersion = getServerVersionNonEmpty - , pgConfHooksAfterCreate = const $ pure () - } - - -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 ConstraintNameDB $ T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"] - - where - - -- Postgres automatically truncates too long foreign keys to a combination of - -- truncatedTableName + "_" + truncatedColumnName + "_fkey" - -- This works fine for normal use cases, but it creates an issue for Persistent - -- Because after running the migrations, Persistent sees the truncated foreign key constraint - -- doesn't have the expected name, and suggests that you migrate again - -- To workaround this, we copy the Postgres truncation approach before sending foreign key constraints to it. - -- - -- I believe this will also be an issue for extremely long table names, - -- but it's just much more likely to exist with foreign key constraints because they're usually tablename * 2 in length - - -- Approximation of the algorithm Postgres uses to truncate identifiers - -- See makeObjectName https://github.com/postgres/postgres/blob/5406513e997f5ee9de79d4076ae91c04af0c52f6/src/backend/commands/indexcmds.c#L2074-L2080 - shortenNames :: Int -> (Int, Int) -> (Int, Int) - shortenNames overhead (x, y) - | x + y + overhead <= maximumIdentifierLength = (x, y) - | x > y = shortenNames overhead (x - 1, y) - | otherwise = shortenNames overhead (x, y - 1) - --- | Postgres' default maximum identifier length in bytes --- (You can re-compile Postgres with a new limit, but I'm assuming that virtually noone does this). --- See https://www.postgresql.org/docs/11/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS -maximumIdentifierLength :: Int -maximumIdentifierLength = 63 - -udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) -udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud) - -mockMigrate :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] [(Bool, Text)]) -mockMigrate allDefs _ entity = fmap (fmap $ map showAlterDb) $ do - case partitionEithers [] of - ([], old'') -> return $ Right $ migrationText False old'' - (errs, _) -> return $ Left errs - where - name = getEntityDBName entity - migrationText exists' old'' = - if not exists' - then createText newcols fdefs udspair - else let (acs, ats) = getAlters allDefs entity (newcols, udspair) old' - acs' = map (AlterColumn name) acs - ats' = map (AlterTable name) ats - in acs' ++ ats' - where - old' = partitionEithers old'' - (newcols', udefs, fdefs) = postgresMkColumns allDefs entity - newcols = filter (not . safeToRemove entity . cName) newcols' - udspair = map udToPair udefs - -- Check for table existence if there are no columns, workaround - -- for https://github.com/yesodweb/persistent/issues/152 - - createText newcols fdefs udspair = - (addTable newcols entity) : uniques ++ references ++ foreignsAlt - where - uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] - references = - mapMaybe - (\Column { cName, cReference } -> - getAddReference allDefs entity cName =<< cReference - ) - newcols - foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs - --- | Mock a migration even when the database is not present. --- This function performs the same functionality of 'printMigration' --- with the difference that an actual database is not needed. -mockMigration :: Migration -> IO () -mockMigration mig = do - smap <- newIORef mempty - let sqlbackend = - mkSqlBackend MkSqlBackendArgs - { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - } - , connInsertSql = undefined - , connStmtMap = smap - , connClose = undefined - , connMigrateSql = mockMigrate - , connBegin = undefined - , connCommit = undefined - , connRollback = undefined - , connEscapeFieldName = escapeF - , connEscapeTableName = escapeE . getEntityDBName - , connEscapeRawName = escape - , connNoLimit = undefined - , connRDBMS = undefined - , connLimitOffset = undefined - , connLogFunc = undefined - } - result = runReaderT $ runWriterT $ runWriterT mig - resp <- result sqlbackend - mapM_ T.putStrLn $ map snd $ snd resp - -putManySql :: EntityDef -> Int -> Text -putManySql ent n = putManySql' conflictColumns fields ent n - where - fields = getEntityFields ent - conflictColumns = concatMap (map (escapeF . snd) . NEL.toList . uniqueFields) (getEntityUniques ent) - -repsertManySql :: EntityDef -> Int -> Text -repsertManySql ent n = putManySql' conflictColumns fields ent n - where - fields = NEL.toList $ keyAndEntityFields ent - conflictColumns = NEL.toList $ escapeF . fieldDB <$> getEntityKeyFields ent - --- | This type is used to determine how to update rows using Postgres' --- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via --- 'upsertWhere' and 'upsertManyWhere' in this library. --- --- @since 2.12.1.0 -data HandleUpdateCollision record where - -- | Copy the field directly from the record. - CopyField :: EntityField record typ -> HandleUpdateCollision record - -- | Only copy the field if it is not equal to the provided value. - CopyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record - --- | Copy the field into the database only if the value in the --- corresponding record is non-@NULL@. --- --- @since 2.12.1.0 -copyUnlessNull :: PersistField typ => EntityField record (Maybe typ) -> HandleUpdateCollision record -copyUnlessNull field = CopyUnlessEq field Nothing - --- | Copy the field into the database only if the value in the --- corresponding record is non-empty, where "empty" means the Monoid --- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. --- --- The resulting 'HandleUpdateCollision' type is useful for the --- 'upsertManyWhere' function. --- --- @since 2.12.1.0 -copyUnlessEmpty :: (Monoid.Monoid typ, PersistField typ) => EntityField record typ -> HandleUpdateCollision record -copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty - --- | Copy the field into the database only if the field is not equal to the --- provided value. This is useful to avoid copying weird nullary data into --- the database. --- --- The resulting 'HandleUpdateCollision' type is useful for the --- 'upsertMany' function. --- --- @since 2.12.1.0 -copyUnlessEq :: PersistField typ => EntityField record typ -> typ -> HandleUpdateCollision record -copyUnlessEq = CopyUnlessEq - --- | Copy the field directly from the record. --- --- @since 2.12.1.0 -copyField :: PersistField typ => EntityField record typ -> HandleUpdateCollision record -copyField = CopyField - --- | Postgres specific 'upsertWhere'. This method does the following: --- It will insert a record if no matching unique key exists. --- If a unique key exists, it will update the relevant field with a user-supplied value, however, --- it will only do this update on a user-supplied condition. --- For example, here's how this method could be called like such: --- --- @ --- upsertWhere record [recordField =. newValue] [recordField /= newValue] --- @ --- --- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value --- assuming the condition in the last block is met. --- --- @since 2.12.1.0 -upsertWhere - :: ( backend ~ PersistEntityBackend record - , PersistEntity record - , PersistEntityBackend record ~ SqlBackend - , MonadIO m - , PersistStore backend - , BackendCompatible SqlBackend backend - , OnlyOneUniqueKey record - ) - => record - -> [Update record] - -> [Filter record] - -> ReaderT backend m () -upsertWhere record updates filts = - upsertManyWhere [record] [] updates filts - --- | Postgres specific 'upsertManyWhere'. This method does the following: --- It will insert a record if no matching unique key exists. --- If a unique key exists, it will update the relevant field with a user-supplied value, however, --- it will only do this update on a user-supplied condition. --- For example, here's how this method could be called like such: --- --- upsertManyWhere [record] [recordField =. newValue] [recordField !=. newValue] --- --- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value --- assuming the condition in the last block is met. --- --- @since 2.12.1.0 -upsertManyWhere - :: forall record backend m. - ( backend ~ PersistEntityBackend record - , BackendCompatible SqlBackend backend - , PersistEntityBackend record ~ SqlBackend - , PersistEntity record - , OnlyOneUniqueKey record - , MonadIO m - ) - => [record] - -- ^ A list of the records you want to insert, or update - -> [HandleUpdateCollision record] - -- ^ A list of the fields you want to copy over. - -> [Update record] - -- ^ A list of the updates to apply that aren't dependent on the record - -- being inserted. - -> [Filter record] - -- ^ A filter condition that dictates the scope of the updates - -> ReaderT backend m () -upsertManyWhere [] _ _ _ = return () -upsertManyWhere records fieldValues updates filters = do - conn <- asks projectBackend - let uniqDef = onlyOneUniqueDef (Proxy :: Proxy record) - uncurry rawExecute $ - mkBulkUpsertQuery records conn fieldValues updates filters uniqDef - --- | Exclude any record field if it doesn't match the filter record. Used only in `upsertWhere` and --- `upsertManyWhere` --- --- TODO: we could probably make a sum type for the `Filter` record that's passed into the `upsertWhere` and --- `upsertManyWhere` methods that has similar behavior to the HandleCollisionUpdate type. --- --- @since 2.12.1.0 -excludeNotEqualToOriginal - :: (PersistField typ, PersistEntity rec) - => EntityField rec typ - -> Filter rec -excludeNotEqualToOriginal field = - Filter - { filterField = - field - , filterFilter = - Ne - , filterValue = - UnsafeValue $ - PersistLiteral_ - Unescaped - bsForExcludedField - } - where - bsForExcludedField = - T.encodeUtf8 - $ "EXCLUDED." - <> fieldName field - --- | This creates the query for 'upsertManyWhere'. If you --- provide an empty list of updates to perform, then it will generate --- a dummy/no-op update using the first field of the record. This avoids --- duplicate key exceptions. -mkBulkUpsertQuery - :: (PersistEntity record, PersistEntityBackend record ~ SqlBackend, OnlyOneUniqueKey record) - => [record] - -- ^ A list of the records you want to insert, or update - -> SqlBackend - -> [HandleUpdateCollision record] - -- ^ A list of the fields you want to copy over. - -> [Update record] - -- ^ A list of the updates to apply that aren't dependent on the record being inserted. - -> [Filter record] - -- ^ A filter condition that dictates the scope of the updates - -> UniqueDef - -- ^ The specific uniqueness constraint to use on the record. Postgres - -- rquires that we use exactly one relevant constraint, and it can't do - -- a catch-all. How frustrating! - -> (Text, [PersistValue]) -mkBulkUpsertQuery records conn fieldValues updates filters uniqDef = - (q, recordValues <> updsValues <> copyUnlessValues <> whereVals) - where - mfieldDef x = case x of - CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) - CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val) - (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues - fieldDbToText = escapeF . fieldDB - entityDef' = entityDef records - conflictColumns = - map (escapeF . snd) $ NEL.toList $ uniqueFields uniqDef - firstField = case entityFieldNames of - [] -> error "The entity you're trying to insert does not have any fields." - (field:_) -> field - entityFieldNames = map fieldDbToText (getEntityFields entityDef') - nameOfTable = escapeE . getEntityDBName $ entityDef' - copyUnlessValues = map snd fieldsToMaybeCopy - recordValues = concatMap (map toPersistValue . toPersistFields) records - recordPlaceholders = - Util.commaSeparated - $ map (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) - $ records - mkCondFieldSet n _ = - T.concat - [ n - , "=COALESCE(" - , "NULLIF(" - , "EXCLUDED." - , n - , "," - , "?" - , ")" - , "," - , nameOfTable - , "." - , n - ,")" - ] - condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy - fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames - upds = map (Util.mkUpdateText' (escapeF) (\n -> T.concat [nameOfTable, ".", n])) updates - updsValues = map (\(Update _ val _) -> toPersistValue val) updates - (wher, whereVals) = - if null filters - then ("", []) - else (filterClauseWithVals (Just PrefixTableName) conn filters) - updateText = - case fieldSets <> upds <> condFieldSets of - [] -> - -- This case is really annoying, and probably unlikely to be - -- actually hit - someone would have had to call something like - -- `upsertManyWhere [] [] []`, but that would have been caught - -- by the prior case. - -- Would be nice to have something like a `NonEmpty (These ...)` - -- instead of multiple lists... - T.concat [firstField, "=", nameOfTable, ".", firstField] - xs -> - Util.commaSeparated xs - q = T.concat - [ "INSERT INTO " - , nameOfTable - , Util.parenWrapped . Util.commaSeparated $ entityFieldNames - , " VALUES " - , recordPlaceholders - , " ON CONFLICT " - , Util.parenWrapped $ Util.commaSeparated $ conflictColumns - , " DO UPDATE SET " - , updateText - , wher - ] - -putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text -putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q - where - fieldDbToText = escapeF . fieldDB - mkAssignment f = T.concat [f, "=EXCLUDED.", f] - - table = escapeE . getEntityDBName $ ent - columns = Util.commaSeparated $ map fieldDbToText fields - placeholders = map (const "?") fields - updates = map (mkAssignment . fieldDbToText) fields - - q = T.concat - [ "INSERT INTO " - , table - , Util.parenWrapped columns - , " VALUES " - , Util.commaSeparated . replicate n - . Util.parenWrapped . Util.commaSeparated $ placeholders - , " ON CONFLICT " - , Util.parenWrapped . Util.commaSeparated $ conflictColumns - , " DO UPDATE SET " - , Util.commaSeparated updates - ] - - --- | Enable a Postgres extension. See https://www.postgresql.org/docs/current/static/contrib.html --- for a list. -migrateEnableExtension :: Text -> Migration -migrateEnableExtension extName = WriterT $ WriterT $ do - res :: [Single Int] <- - rawSql "SELECT COUNT(*) FROM pg_catalog.pg_extension WHERE extname = ?" [PersistText extName] - if res == [Single 0] - then return (((), []) , [(False, "CREATe EXTENSION \"" <> extName <> "\"")]) - else return (((), []), []) - -postgresMkColumns :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -postgresMkColumns allDefs t = - mkColumns allDefs t - $ setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides - --- | Wrapper for persistent SqlBackends that carry the corresponding --- `Postgresql.Connection`. --- --- @since 2.13.1.0 -data RawPostgresql backend = RawPostgresql - { persistentBackend :: backend - -- ^ The persistent backend - -- - -- @since 2.13.1.0 - , rawPostgresqlConnection :: PG.Connection - -- ^ The underlying `PG.Connection` - -- - -- @since 2.13.1.0 - } - -instance BackendCompatible (RawPostgresql b) (RawPostgresql b) where - projectBackend = id - -instance BackendCompatible b (RawPostgresql b) where - projectBackend = persistentBackend - -withRawConnection - :: (PG.Connection -> SqlBackend) - -> PG.Connection - -> RawPostgresql SqlBackend -withRawConnection f conn = RawPostgresql - { persistentBackend = f conn - , rawPostgresqlConnection = conn - } - --- | Create a PostgreSQL connection pool which also exposes the --- raw connection. The raw counterpart to 'createPostgresqlPool'. --- --- @since 2.13.1.0 -createRawPostgresqlPool :: (MonadUnliftIO m, MonadLoggerIO m) - => ConnectionString - -- ^ Connection string to the database. - -> Int - -- ^ Number of connections to be kept open - -- in the pool. - -> m (Pool (RawPostgresql SqlBackend)) -createRawPostgresqlPool = createRawPostgresqlPoolModified (const $ return ()) - --- | The raw counterpart to 'createPostgresqlPoolModified'. --- --- @since 2.13.1.0 -createRawPostgresqlPoolModified - :: (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. - -> m (Pool (RawPostgresql SqlBackend)) -createRawPostgresqlPoolModified = createRawPostgresqlPoolModifiedWithVersion getServerVersion - --- | The raw counterpart to 'createPostgresqlPoolModifiedWithVersion'. --- --- @since 2.13.1.0 -createRawPostgresqlPoolModifiedWithVersion - :: (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. - -> Int -- ^ Number of connections to be kept open in the pool. - -> m (Pool (RawPostgresql SqlBackend)) -createRawPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do - let getVer = oldGetVersionToNew getVerDouble - createSqlPool $ open' modConn getVer withRawConnection ci - --- | The raw counterpart to 'createPostgresqlPoolWithConf'. --- --- @since 2.13.1.0 -createRawPostgresqlPoolWithConf - :: (MonadUnliftIO m, MonadLoggerIO m) - => PostgresConf -- ^ Configuration for connecting to Postgres - -> PostgresConfHooks -- ^ Record of callback functions - -> m (Pool (RawPostgresql SqlBackend)) -createRawPostgresqlPoolWithConf conf hooks = do - let getVer = pgConfHooksGetServerVersion hooks - modConn = pgConfHooksAfterCreate hooks - createSqlPoolWithConfig (open' modConn getVer withRawConnection (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf) - -#if MIN_VERSION_base(4,12,0) -instance (PersistCore b) => PersistCore (RawPostgresql b) where - newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (Compatible b (RawPostgresql b)) } - -makeCompatibleKeyInstances [t| forall b. Compatible b (RawPostgresql b) |] -#else -instance (PersistCore b) => PersistCore (RawPostgresql b) where - newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (RawPostgresql b) } - -deriving instance (Show (BackendKey b)) => Show (BackendKey (RawPostgresql b)) -deriving instance (Read (BackendKey b)) => Read (BackendKey (RawPostgresql b)) -deriving instance (Eq (BackendKey b)) => Eq (BackendKey (RawPostgresql b)) -deriving instance (Ord (BackendKey b)) => Ord (BackendKey (RawPostgresql b)) -deriving instance (Num (BackendKey b)) => Num (BackendKey (RawPostgresql b)) -deriving instance (Integral (BackendKey b)) => Integral (BackendKey (RawPostgresql b)) -deriving instance (PersistField (BackendKey b)) => PersistField (BackendKey (RawPostgresql b)) -deriving instance (PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (RawPostgresql b)) -deriving instance (Real (BackendKey b)) => Real (BackendKey (RawPostgresql b)) -deriving instance (Enum (BackendKey b)) => Enum (BackendKey (RawPostgresql b)) -deriving instance (Bounded (BackendKey b)) => Bounded (BackendKey (RawPostgresql b)) -deriving instance (ToJSON (BackendKey b)) => ToJSON (BackendKey (RawPostgresql b)) -deriving instance (FromJSON (BackendKey b)) => FromJSON (BackendKey (RawPostgresql b)) -#endif - - -#if MIN_VERSION_base(4,12,0) -$(pure []) - -makeCompatibleInstances [t| forall b. Compatible b (RawPostgresql b) |] -#else -instance HasPersistBackend b => HasPersistBackend (RawPostgresql b) where - type BaseBackend (RawPostgresql b) = BaseBackend b - persistBackend = persistBackend . persistentBackend - -instance (PersistStoreRead b) => PersistStoreRead (RawPostgresql b) where - get = withReaderT persistentBackend . get - getMany = withReaderT persistentBackend . getMany - -instance (PersistQueryRead b) => PersistQueryRead (RawPostgresql b) where - selectSourceRes filts opts = withReaderT persistentBackend $ selectSourceRes filts opts - selectFirst filts opts = withReaderT persistentBackend $ selectFirst filts opts - selectKeysRes filts opts = withReaderT persistentBackend $ selectKeysRes filts opts - count = withReaderT persistentBackend . count - exists = withReaderT persistentBackend . exists - -instance (PersistQueryWrite b) => PersistQueryWrite (RawPostgresql b) where - updateWhere filts updates = withReaderT persistentBackend $ updateWhere filts updates - deleteWhere = withReaderT persistentBackend . deleteWhere - -instance (PersistUniqueRead b) => PersistUniqueRead (RawPostgresql b) where - getBy = withReaderT persistentBackend . getBy - -instance (PersistStoreWrite b) => PersistStoreWrite (RawPostgresql b) where - insert = withReaderT persistentBackend . insert - insert_ = withReaderT persistentBackend . insert_ - insertMany = withReaderT persistentBackend . insertMany - insertMany_ = withReaderT persistentBackend . insertMany_ - insertEntityMany = withReaderT persistentBackend . insertEntityMany - insertKey k = withReaderT persistentBackend . insertKey k - repsert k = withReaderT persistentBackend . repsert k - repsertMany = withReaderT persistentBackend . repsertMany - replace k = withReaderT persistentBackend . replace k - delete = withReaderT persistentBackend . delete - update k = withReaderT persistentBackend . update k - updateGet k = withReaderT persistentBackend . updateGet k - -instance (PersistUniqueWrite b) => PersistUniqueWrite (RawPostgresql b) where - deleteBy = withReaderT persistentBackend . deleteBy - insertUnique = withReaderT persistentBackend . insertUnique - upsert rec = withReaderT persistentBackend . upsert rec - upsertBy uniq rec = withReaderT persistentBackend . upsertBy uniq rec - putMany = withReaderT persistentBackend . putMany -#endif - + , withPostgresqlPoolModified + , withPostgresqlPoolModifiedWithVersion + , withPostgresqlConn + , withPostgresqlConnWithVersion + , createPostgresqlPool + , createPostgresqlPoolModified + , createPostgresqlPoolModifiedWithVersion + , createPostgresqlPoolTailored + , createPostgresqlPoolWithConf + , module Database.Persist.Sql + , ConnectionString + , HandleUpdateCollision + , copyField + , copyUnlessNull + , copyUnlessEmpty + , copyUnlessEq + , excludeNotEqualToOriginal + , PostgresConf (..) + , PgInterval (..) + , upsertWhere + , upsertManyWhere + , openSimpleConn + , openSimpleConnWithVersion + , getServerVersion + , getSimpleConn + , tableName + , fieldName + , mockMigration + , migrateEnableExtension + , PostgresConfHooks (..) + , defaultPostgresConfHooks + , RawPostgresql (..) + , createRawPostgresqlPool + , createRawPostgresqlPoolModified + , createRawPostgresqlPoolModifiedWithVersion + , createRawPostgresqlPoolWithConf + , createBackend + ) where + +import qualified Database.PostgreSQL.LibPQ as LibPQ + +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.Internal as PG +import Database.PostgreSQL.Simple.Ok (Ok (..)) +import qualified Database.PostgreSQL.Simple.Transaction as PG +import qualified Database.PostgreSQL.Simple.Types as PG + +import Control.Exception (Exception, throw, throwIO) +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) +import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) +import Control.Monad.Trans.Reader (ReaderT (..), asks, runReaderT) +#if !MIN_VERSION_base(4,12,0) +import Control.Monad.Trans.Reader (withReaderT) +#endif +import Control.Monad.Trans.Writer (WriterT (..), runWriterT) +import qualified Data.List.NonEmpty as NEL +import Data.Proxy (Proxy (..)) + +import Data.Acquire (Acquire, mkAcquire) +import Data.Aeson +import Data.Aeson.Types (modifyFailure) +import qualified Data.Attoparsec.Text as AT +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import Data.Conduit +import Data.Data (Data) +import Data.Either (partitionEithers) +import Data.IORef +import Data.Int (Int64) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.Map as Map +import qualified Data.Monoid as Monoid +import Data.Pool (Pool) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Text.Read (rational) +import System.Environment (getEnvironment) + +#if MIN_VERSION_base(4,12,0) +import Database.Persist.Compatible +#endif +import qualified Data.Vault.Strict as Vault +import Database.Persist.Postgresql.Internal +import Database.Persist.Sql +import qualified Database.Persist.Sql.Util as Util +import Database.Persist.SqlBackend +import System.IO.Unsafe (unsafePerformIO) + +-- | A @libpq@ connection string. A simple example of connection +-- string would be @\"host=localhost port=5432 user=test +-- dbname=test password=test\"@. Please read libpq's +-- documentation at +-- +-- for more details on how to create such strings. +type ConnectionString = ByteString + +-- | PostgresServerVersionError exception. This is thrown when persistent +-- is unable to find the version of the postgreSQL server. +data PostgresServerVersionError = PostgresServerVersionError String + +instance Show PostgresServerVersionError where + show (PostgresServerVersionError uniqueMsg) = + "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 +-- have been released. +-- The provided action should use 'runSqlConn' and *not* 'runReaderT' because +-- the former brackets the database action with transaction begin/commit. +withPostgresqlPool + :: (MonadLoggerIO m, MonadUnliftIO m) + => ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open in + -- the pool. + -> (Pool SqlBackend -> m a) + -- ^ Action to be executed that uses the + -- connection pool. + -> m a +withPostgresqlPool ci = withPostgresqlPoolWithVersion getServerVersion ci + +-- | Same as 'withPostgresPool', but takes a callback for obtaining +-- the server version (to work around an Amazon Redshift bug). +-- +-- @since 2.6.2 +withPostgresqlPoolWithVersion + :: (MonadUnliftIO m, MonadLoggerIO m) + => (PG.Connection -> IO (Maybe Double)) + -- ^ Action to perform to get the server version. + -> ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open in + -- the pool. + -> (Pool SqlBackend -> m a) + -- ^ Action to be executed that uses the + -- connection pool. + -> m a +withPostgresqlPoolWithVersion getVerDouble ci = do + let + getVer = oldGetVersionToNew getVerDouble + withSqlPool $ open' (const $ return ()) getVer id ci + +-- | Same as 'withPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. +-- +-- @since 2.11.0.0 +withPostgresqlPoolWithConf + :: (MonadUnliftIO m, MonadLoggerIO m) + => PostgresConf + -- ^ Configuration for connecting to Postgres + -> PostgresConfHooks + -- ^ Record of callback functions + -> (Pool SqlBackend -> m a) + -- ^ Action to be executed that uses the + -- connection pool. + -> m a +withPostgresqlPoolWithConf conf hooks = do + let + getVer = pgConfHooksGetServerVersion hooks + modConn = pgConfHooksAfterCreate hooks + let + logFuncToBackend = open' modConn getVer id (pgConnStr conf) + withSqlPoolWithConfig logFuncToBackend (postgresConfToConnectionPoolConfig conf) + +-- | Same as 'withPostgresqlPool', but with the 'createPostgresqlPoolModified' +-- feature. +-- +-- @since 2.13.5.0 +withPostgresqlPoolModified + :: (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. + -> (Pool SqlBackend -> m t) + -> m t +withPostgresqlPoolModified = withPostgresqlPoolModifiedWithVersion getServerVersion + +-- | Same as 'withPostgresqlPool', but with the +-- 'createPostgresqlPoolModifiedWithVersion' feature. +-- +-- @since 2.13.5.0 +withPostgresqlPoolModifiedWithVersion + :: (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. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> (Pool SqlBackend -> m t) + -> m t +withPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do + withSqlPool (open' modConn (oldGetVersionToNew getVerDouble) id ci) + +-- | Create a PostgreSQL connection pool. Note that it's your +-- responsibility to properly close the connection pool when +-- unneeded. Use 'withPostgresqlPool' for an automatic resource +-- control. +createPostgresqlPool + :: (MonadUnliftIO m, MonadLoggerIO m) + => ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open + -- in the pool. + -> m (Pool SqlBackend) +createPostgresqlPool = createPostgresqlPoolModified (const $ return ()) + +-- | Same as 'createPostgresqlPool', but additionally takes a callback function +-- for some connection-specific tweaking to be performed after connection +-- creation. This could be used, for example, to change the schema. For more +-- information, see: +-- +-- +-- +-- @since 2.1.3 +createPostgresqlPoolModified + :: (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. + -> m (Pool SqlBackend) +createPostgresqlPoolModified = createPostgresqlPoolModifiedWithVersion getServerVersion + +-- | Same as other similarly-named functions in this module, but takes callbacks for obtaining +-- the server version (to work around an Amazon Redshift bug) and connection-specific tweaking +-- (to change the schema). +-- +-- @since 2.6.2 +createPostgresqlPoolModifiedWithVersion + :: (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. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> m (Pool SqlBackend) +createPostgresqlPoolModifiedWithVersion = createPostgresqlPoolTailored open' + +-- | Same as 'createPostgresqlPoolModifiedWithVersion', but takes a custom connection-creation +-- function. +-- +-- The only time you should reach for this function is if you need to write custom logic for creating +-- a connection to the database. +-- +-- @since 2.13.6 +createPostgresqlPoolTailored + :: (MonadUnliftIO m, MonadLoggerIO m) + => ( (PG.Connection -> IO ()) + -> (PG.Connection -> IO (NonEmpty Word)) + -> ((PG.Connection -> SqlBackend) -> PG.Connection -> SqlBackend) + -> ConnectionString + -> LogFunc + -> IO SqlBackend + ) + -- ^ Action that creates a postgresql connection (please see documentation on the un-exported @open'@ function in this same module. + -> (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. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> m (Pool SqlBackend) +createPostgresqlPoolTailored createConnection getVerDouble modConn ci = do + let + getVer = oldGetVersionToNew getVerDouble + createSqlPool $ createConnection modConn getVer id ci + +-- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. +-- +-- @since 2.11.0.0 +createPostgresqlPoolWithConf + :: (MonadUnliftIO m, MonadLoggerIO m) + => PostgresConf + -- ^ Configuration for connecting to Postgres + -> PostgresConfHooks + -- ^ Record of callback functions + -> m (Pool SqlBackend) +createPostgresqlPoolWithConf conf hooks = do + let + getVer = pgConfHooksGetServerVersion hooks + modConn = pgConfHooksAfterCreate hooks + createSqlPoolWithConfig + (open' modConn getVer id (pgConnStr conf)) + (postgresConfToConnectionPoolConfig conf) + +postgresConfToConnectionPoolConfig :: PostgresConf -> ConnectionPoolConfig +postgresConfToConnectionPoolConfig conf = + ConnectionPoolConfig + { connectionPoolConfigStripes = pgPoolStripes conf + , connectionPoolConfigIdleTimeout = fromInteger $ pgPoolIdleTimeout conf + , connectionPoolConfigSize = pgPoolSize conf + } + +-- | 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, MonadLoggerIO m) + => ConnectionString + -> (SqlBackend -> m a) + -> m a +withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion + +-- | Same as 'withPostgresqlConn', but takes a callback for obtaining +-- the server version (to work around an Amazon Redshift bug). +-- +-- @since 2.6.2 +withPostgresqlConnWithVersion + :: (MonadUnliftIO m, MonadLoggerIO m) + => (PG.Connection -> IO (Maybe Double)) + -> ConnectionString + -> (SqlBackend -> m a) + -> m a +withPostgresqlConnWithVersion getVerDouble = do + let + getVer = oldGetVersionToNew getVerDouble + withSqlConn . open' (const $ return ()) getVer id + +open' + :: (PG.Connection -> IO ()) + -> (PG.Connection -> IO (NonEmpty Word)) + -> ((PG.Connection -> SqlBackend) -> PG.Connection -> backend) + -- ^ How to construct the actual backend type desired. For most uses, + -- this is just 'id', since the desired backend type is 'SqlBackend'. + -- But some callers want a @'RawPostgresql' 'SqlBackend'@, and will + -- pass in 'withRawConnection'. + -> ConnectionString + -> LogFunc + -> IO backend +open' modConn getVer constructor cstr logFunc = do + conn <- PG.connectPostgreSQL cstr + modConn conn + ver <- getVer conn + smap <- newIORef mempty + return $ constructor (createBackend logFunc ver smap) conn + +-- | Gets the PostgreSQL server version +-- +-- @since 2.13.6 +getServerVersion :: PG.Connection -> IO (Maybe Double) +getServerVersion conn = do + [PG.Only version] <- PG.query_ conn "show server_version" + let + version' = rational version + --- λ> rational "9.8.3" + --- Right (9.8,".3") + --- λ> rational "9.8.3.5" + --- Right (9.8,".3.5") + case version' of + Right (a, _) -> return $ Just a + Left err -> throwIO $ PostgresServerVersionError err + +getServerVersionNonEmpty :: PG.Connection -> IO (NonEmpty Word) +getServerVersionNonEmpty conn = do + [PG.Only version] <- PG.query_ conn "show server_version" + case AT.parseOnly parseVersion (T.pack version) of + Left err -> + throwIO $ + PostgresServerVersionError $ + "Parse failure on: " <> version <> ". Error: " <> err + Right versionComponents -> case NEL.nonEmpty versionComponents of + Nothing -> + throwIO $ + PostgresServerVersionError $ + "Empty Postgres version string: " <> version + Just neVersion -> pure neVersion + where + -- Partially copied from the `versions` package + -- Typically server_version gives e.g. 12.3 + -- In Persistent's CI, we get "12.4 (Debian 12.4-1.pgdg100+1)", so we ignore the trailing data. + parseVersion = AT.decimal `AT.sepBy` AT.char '.' + +-- | Choose upsert sql generation function based on postgresql version. +-- PostgreSQL version >= 9.5 supports native upsert feature, +-- so depending upon that we have to choose how the sql query is generated. +-- upsertFunction :: Double -> Maybe (EntityDef -> Text -> Text) +upsertFunction :: a -> NonEmpty Word -> Maybe a +upsertFunction f version = + if (version >= postgres9dot5) + then Just f + else Nothing + where + +postgres9dot5 :: NonEmpty Word +postgres9dot5 = 9 NEL.:| [5] + +-- | If the user doesn't supply a Postgres version, we assume this version. +-- +-- This is currently below any version-specific features Persistent uses. +minimumPostgresVersion :: NonEmpty Word +minimumPostgresVersion = 9 NEL.:| [4] + +oldGetVersionToNew + :: (PG.Connection -> IO (Maybe Double)) -> (PG.Connection -> IO (NonEmpty Word)) +oldGetVersionToNew oldFn = \conn -> do + mDouble <- oldFn conn + case mDouble of + Nothing -> pure minimumPostgresVersion + Just double -> do + let + (major, minor) = properFraction double + pure $ major NEL.:| [floor minor] + +-- | Generate a 'SqlBackend' from a 'PG.Connection'. +openSimpleConn :: LogFunc -> PG.Connection -> IO SqlBackend +openSimpleConn = openSimpleConnWithVersion getServerVersion + +-- | Generate a 'SqlBackend' from a 'PG.Connection', but takes a callback for +-- obtaining the server version. +-- +-- @since 2.9.1 +openSimpleConnWithVersion + :: (PG.Connection -> IO (Maybe Double)) + -> LogFunc + -> PG.Connection + -> IO SqlBackend +openSimpleConnWithVersion getVerDouble logFunc conn = do + smap <- newIORef mempty + serverVersion <- oldGetVersionToNew getVerDouble conn + return $ createBackend logFunc serverVersion smap conn + +underlyingConnectionKey :: Vault.Key PG.Connection +underlyingConnectionKey = unsafePerformIO Vault.newKey +{-# NOINLINE underlyingConnectionKey #-} + +-- | Access underlying connection, returning 'Nothing' if the 'SqlBackend' +-- provided isn't backed by postgresql-simple. +-- +-- @since 2.13.0 +getSimpleConn + :: (BackendCompatible SqlBackend backend) => backend -> Maybe PG.Connection +getSimpleConn = Vault.lookup underlyingConnectionKey <$> getConnVault + +-- | Create the backend given a logging function, server version, mutable statement cell, +-- and connection. +-- +-- @since 2.13.6 +createBackend + :: LogFunc + -> NonEmpty Word + -> IORef (Map.Map Text Statement) + -> PG.Connection + -> SqlBackend +createBackend logFunc serverVersion smap conn = + maybe id setConnPutManySql (upsertFunction putManySql serverVersion) $ + maybe id setConnUpsertSql (upsertFunction upsertSql' serverVersion) $ + setConnInsertManySql insertManySql' $ + maybe id setConnRepsertManySql (upsertFunction repsertManySql serverVersion) $ + modifyConnVault (Vault.insert underlyingConnectionKey conn) $ + mkSqlBackend + MkSqlBackendArgs + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connClose = PG.close conn + , connMigrateSql = migrate' + , connBegin = \_ mIsolation -> case mIsolation of + Nothing -> PG.begin conn + Just iso -> + PG.beginLevel + ( case iso of + ReadUncommitted -> PG.ReadCommitted -- PG Upgrades uncommitted reads to committed anyways + ReadCommitted -> PG.ReadCommitted + RepeatableRead -> PG.RepeatableRead + Serializable -> PG.Serializable + ) + conn + , connCommit = const $ PG.commit conn + , connRollback = const $ PG.rollback conn + , connEscapeFieldName = escapeF + , connEscapeTableName = escapeE . getEntityDBName + , connEscapeRawName = escape + , connNoLimit = "LIMIT ALL" + , connRDBMS = "postgresql" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" + , connLogFunc = logFunc + } + +prepare' :: PG.Connection -> Text -> IO Statement +prepare' conn sql = do + let + query = PG.Query (T.encodeUtf8 sql) + return + Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = execute' conn query + , stmtQuery = withStmt' conn query + } + +insertSql' :: EntityDef -> [PersistValue] -> InsertSqlResult +insertSql' ent vals = + case getEntityId ent of + EntityIdNaturalKey _pdef -> + ISRManyKeys sql vals + EntityIdField field -> + ISRSingle (sql <> " RETURNING " <> escapeF (fieldDB field)) + where + (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) + sql = + T.concat + [ "INSERT INTO " + , escapeE $ getEntityDBName ent + , if null (getEntityFields ent) + then " DEFAULT VALUES" + else + T.concat + [ "(" + , T.intercalate "," fieldNames + , ") VALUES(" + , T.intercalate "," placeholders + , ")" + ] + ] + +upsertSql' :: EntityDef -> NonEmpty (FieldNameHS, FieldNameDB) -> Text -> Text +upsertSql' ent uniqs updateVal = + T.concat + [ "INSERT INTO " + , escapeE (getEntityDBName ent) + , "(" + , T.intercalate "," fieldNames + , ") VALUES (" + , T.intercalate "," placeholders + , ") ON CONFLICT (" + , T.intercalate "," $ map (escapeF . snd) (NEL.toList uniqs) + , ") DO UPDATE SET " + , updateVal + , " WHERE " + , wher + , " RETURNING ??" + ] + where + (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escapeF) + + wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs + + singleClause :: FieldNameDB -> Text + singleClause field = escapeE (getEntityDBName 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 escapeF) + sql = + T.concat + [ "INSERT INTO " + , escapeE (getEntityDBName ent) + , "(" + , T.intercalate "," fieldNames + , ") VALUES (" + , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," placeholders + , ") RETURNING " + , Util.commaSeparated $ NEL.toList $ Util.dbIdColumnsEsc escapeF ent + ] + +execute' :: PG.Connection -> PG.Query -> [PersistValue] -> IO Int64 +execute' conn query vals = PG.execute conn query (map P vals) + +withStmt' + :: (MonadIO m) + => PG.Connection + -> PG.Query + -> [PersistValue] + -> Acquire (ConduitM () [PersistValue] m ()) +withStmt' conn query vals = + pull `fmap` mkAcquire openS closeS + where + openS = do + -- Construct raw query + rawquery <- PG.formatQuery conn query (map P vals) + + -- Take raw connection + (rt, rr, rc, ids) <- PG.withConnection conn $ \rawconn -> do + -- Execute query + mret <- LibPQ.exec rawconn rawquery + case mret of + Nothing -> do + merr <- LibPQ.errorMessage rawconn + fail $ case merr of + Nothing -> "Postgresql.withStmt': unknown error" + Just e -> "Postgresql.withStmt': " ++ B8.unpack e + Just ret -> do + -- Check result status + status <- LibPQ.resultStatus ret + case status of + LibPQ.TuplesOk -> return () + _ -> PG.throwResultError "Postgresql.withStmt': bad result status " ret status + + -- Get number and type of columns + cols <- LibPQ.nfields ret + oids <- forM [0 .. cols - 1] $ \col -> fmap ((,) col) (LibPQ.ftype ret col) + -- Ready to go! + rowRef <- newIORef (LibPQ.Row 0) + rowCount <- LibPQ.ntuples ret + return (ret, rowRef, rowCount, oids) + let + getters = + map (\(col, oid) -> getGetter oid $ PG.Field rt col oid) ids + return (rt, rr, rc, getters) + + closeS (ret, _, _, _) = LibPQ.unsafeFreeResult ret + + pull x = do + y <- liftIO $ pullS x + case y of + Nothing -> return () + Just z -> yield z >> pull x + + pullS (ret, rowRef, rowCount, getters) = do + row <- atomicModifyIORef rowRef (\r -> (r + 1, r)) + if row == rowCount + then return Nothing + else fmap Just $ forM (zip getters [0 ..]) $ \(getter, col) -> do + mbs <- LibPQ.getvalue' ret row col + case mbs of + Nothing -> + -- getvalue' verified that the value is NULL. + -- However, that does not mean that there are + -- no NULL values inside the value (e.g., if + -- we're dealing with an array of optional values). + return PersistNull + Just bs -> do + ok <- PGFF.runConversion (getter mbs) conn + bs `seq` case ok of + Errors (exc : _) -> throw exc + Errors [] -> error "Got an Errors, but no exceptions" + Ok v -> return v + +migrate' + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] CautiousMigration) +migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ migrateStructured allDefs getter entity + +-- | Get the SQL string for the table that a PersistEntity represents. +-- Useful for raw SQL queries. +tableName :: (PersistEntity record) => record -> Text +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 = escapeF . fieldDBName + +-- | Information required to connect to a PostgreSQL database +-- using @persistent@'s generic facilities. These values are the +-- same that are given to 'withPostgresqlPool'. +data PostgresConf = PostgresConf + { pgConnStr :: ConnectionString + -- ^ The connection string. + , -- TODO: Currently stripes, idle timeout, and pool size are all separate fields + -- When Persistent next does a large breaking release (3.0?), we should consider making these just a single ConnectionPoolConfig value + -- + -- Currently there the idle timeout is an Integer, rather than resource-pool's NominalDiffTime type. + -- This is because the time package only recently added the Read instance for NominalDiffTime. + -- Future TODO: Consider removing the Read instance, and/or making the idle timeout a NominalDiffTime. + + pgPoolStripes :: Int + -- ^ How many stripes to divide the pool into. See "Data.Pool" for details. + -- @since 2.11.0.0 + , pgPoolIdleTimeout :: Integer -- Ideally this would be a NominalDiffTime, but that type lacks a Read instance https://github.com/haskell/time/issues/130 + + -- ^ How long connections can remain idle before being disposed of, in seconds. + -- @since 2.11.0.0 + , pgPoolSize :: Int + -- ^ How many connections should be held in the connection pool. + } + deriving (Show, Read, Data) + +instance FromJSON PostgresConf where + parseJSON v = modifyFailure ("Persistent: error loading PostgreSQL conf: " ++) $ + flip (withObject "PostgresConf") v $ \o -> do + let + defaultPoolConfig = defaultConnectionPoolConfig + database <- o .: "database" + host <- o .: "host" + port <- o .:? "port" .!= 5432 + user <- o .: "user" + password <- o .: "password" + poolSize <- o .:? "poolsize" .!= (connectionPoolConfigSize defaultPoolConfig) + poolStripes <- + o .:? "stripes" .!= (connectionPoolConfigStripes defaultPoolConfig) + poolIdleTimeout <- + o + .:? "idleTimeout" + .!= (floor $ connectionPoolConfigIdleTimeout defaultPoolConfig) + let + ci = + PG.ConnectInfo + { PG.connectHost = host + , PG.connectPort = port + , PG.connectUser = user + , PG.connectPassword = password + , PG.connectDatabase = database + } + cstr = PG.postgreSQLConnectionString ci + return $ PostgresConf cstr poolStripes poolIdleTimeout poolSize +instance PersistConfig PostgresConf where + type PersistConfigBackend PostgresConf = SqlPersistT + type PersistConfigPool PostgresConf = ConnectionPool + createPoolConfig conf = runNoLoggingT $ createPostgresqlPoolWithConf conf defaultPostgresConfHooks + runPool _ = runSqlPool + loadConfig = parseJSON + + applyEnv c0 = do + env <- getEnvironment + return $ + addUser env $ + addPass env $ + addDatabase env $ + addPort env $ + addHost env c0 + where + addParam param val c = + c{pgConnStr = B8.concat [pgConnStr c, " ", param, "='", pgescape val, "'"]} + + pgescape = B8.pack . go + where + go ('\'' : rest) = '\\' : '\'' : go rest + go ('\\' : rest) = '\\' : '\\' : go rest + go (x : rest) = x : go rest + go [] = [] + + maybeAddParam param envvar env = + maybe id (addParam param) $ + lookup envvar env + + addHost = maybeAddParam "host" "PGHOST" + addPort = maybeAddParam "port" "PGPORT" + addUser = maybeAddParam "user" "PGUSER" + addPass = maybeAddParam "password" "PGPASS" + addDatabase = maybeAddParam "dbname" "PGDATABASE" + +-- | Hooks for configuring the Persistent/its connection to Postgres +-- +-- @since 2.11.0 +data PostgresConfHooks = PostgresConfHooks + { pgConfHooksGetServerVersion :: PG.Connection -> IO (NonEmpty Word) + -- ^ Function to get the version of Postgres + -- + -- The default implementation queries the server with "show server_version". + -- Some variants of Postgres, such as Redshift, don't support showing the version. + -- It's recommended you return a hardcoded version in those cases. + -- + -- @since 2.11.0 + , pgConfHooksAfterCreate :: PG.Connection -> IO () + -- ^ Action to perform after a connection is created. + -- + -- Typical uses of this are modifying the connection (e.g. to set the schema) or logging a connection being created. + -- + -- The default implementation does nothing. + -- + -- @since 2.11.0 + } + +-- | Default settings for 'PostgresConfHooks'. See the individual fields of 'PostgresConfHooks' for the default values. +-- +-- @since 2.11.0 +defaultPostgresConfHooks :: PostgresConfHooks +defaultPostgresConfHooks = + PostgresConfHooks + { pgConfHooksGetServerVersion = getServerVersionNonEmpty + , pgConfHooksAfterCreate = const $ pure () + } + +mockMigrate + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) +mockMigrate allDefs _ entity = + fmap (fmap $ map showAlterDb) $ + return $ + Right $ + mockMigrateStructured allDefs entity + +-- | Mock a migration even when the database is not present. +-- This function performs the same functionality of 'printMigration' +-- with the difference that an actual database is not needed. +mockMigration :: Migration -> IO () +mockMigration mig = do + smap <- newIORef mempty + let + sqlbackend = + mkSqlBackend + MkSqlBackendArgs + { connPrepare = \_ -> do + return + Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + } + , connInsertSql = undefined + , connStmtMap = smap + , connClose = undefined + , connMigrateSql = mockMigrate + , connBegin = undefined + , connCommit = undefined + , connRollback = undefined + , connEscapeFieldName = escapeF + , connEscapeTableName = escapeE . getEntityDBName + , connEscapeRawName = escape + , connNoLimit = undefined + , connRDBMS = undefined + , connLimitOffset = undefined + , connLogFunc = undefined + } + result = runReaderT $ runWriterT $ runWriterT mig + resp <- result sqlbackend + mapM_ T.putStrLn $ map snd $ snd resp + +putManySql :: EntityDef -> Int -> Text +putManySql ent n = putManySql' conflictColumns fields ent n + where + fields = getEntityFields ent + conflictColumns = + concatMap + (map (escapeF . snd) . NEL.toList . uniqueFields) + (getEntityUniques ent) + +repsertManySql :: EntityDef -> Int -> Text +repsertManySql ent n = putManySql' conflictColumns fields ent n + where + fields = NEL.toList $ keyAndEntityFields ent + conflictColumns = NEL.toList $ escapeF . fieldDB <$> getEntityKeyFields ent + +-- | This type is used to determine how to update rows using Postgres' +-- @INSERT ... ON CONFLICT KEY UPDATE@ functionality, exposed via +-- 'upsertWhere' and 'upsertManyWhere' in this library. +-- +-- @since 2.12.1.0 +data HandleUpdateCollision record where + -- | Copy the field directly from the record. + CopyField :: EntityField record typ -> HandleUpdateCollision record + -- | Only copy the field if it is not equal to the provided value. + CopyUnlessEq + :: (PersistField typ) + => EntityField record typ + -> typ + -> HandleUpdateCollision record + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-@NULL@. +-- +-- @since 2.12.1.0 +copyUnlessNull + :: (PersistField typ) + => EntityField record (Maybe typ) + -> HandleUpdateCollision record +copyUnlessNull field = CopyUnlessEq field Nothing + +-- | Copy the field into the database only if the value in the +-- corresponding record is non-empty, where "empty" means the Monoid +-- definition for 'mempty'. Useful for 'Text', 'String', 'ByteString', etc. +-- +-- The resulting 'HandleUpdateCollision' type is useful for the +-- 'upsertManyWhere' function. +-- +-- @since 2.12.1.0 +copyUnlessEmpty + :: (Monoid.Monoid typ, PersistField typ) + => EntityField record typ + -> HandleUpdateCollision record +copyUnlessEmpty field = CopyUnlessEq field Monoid.mempty + +-- | Copy the field into the database only if the field is not equal to the +-- provided value. This is useful to avoid copying weird nullary data into +-- the database. +-- +-- The resulting 'HandleUpdateCollision' type is useful for the +-- 'upsertMany' function. +-- +-- @since 2.12.1.0 +copyUnlessEq + :: (PersistField typ) + => EntityField record typ + -> typ + -> HandleUpdateCollision record +copyUnlessEq = CopyUnlessEq + +-- | Copy the field directly from the record. +-- +-- @since 2.12.1.0 +copyField + :: (PersistField typ) => EntityField record typ -> HandleUpdateCollision record +copyField = CopyField + +-- | Postgres specific 'upsertWhere'. This method does the following: +-- It will insert a record if no matching unique key exists. +-- If a unique key exists, it will update the relevant field with a user-supplied value, however, +-- it will only do this update on a user-supplied condition. +-- For example, here's how this method could be called like such: +-- +-- @ +-- upsertWhere record [recordField =. newValue] [recordField /= newValue] +-- @ +-- +-- Called thusly, this method will insert a new record (if none exists) OR update a recordField with a new value +-- assuming the condition in the last block is met. +-- +-- @since 2.12.1.0 +upsertWhere + :: ( backend ~ PersistEntityBackend record + , PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , MonadIO m + , PersistStore backend + , BackendCompatible SqlBackend backend + , OnlyOneUniqueKey record + ) + => record + -> [Update record] + -> [Filter record] + -> ReaderT backend m () +upsertWhere record updates filts = + upsertManyWhere [record] [] updates filts + +-- | Postgres specific 'upsertManyWhere'. +-- +-- The first argument is a list of new records to insert. +-- +-- If there's unique key collisions for some or all of the proposed insertions, +-- you can use the second argument to specify which fields, under which +-- conditions (using 'HandleUpdateCollision' strategies,) will be copied from +-- each proposed, conflicting new record onto its corresponding row already present +-- in the database. Helpers such as 'copyField', 'copyUnlessEq', +-- 'copyUnlessNull' and 'copyUnlessEmpty' are exported from this module to help +-- with this, as well as the constructors for 'HandleUpdateCollision'. +-- For example, you may have a patch of updates to apply, some of which are NULL +-- to represent "no change"; you'd use 'copyUnlessNull' for each applicable +-- field in this case so any new values in the patch which are NULL don't +-- accidentally overwrite existing values in the database which are non-NULL. +-- +-- Further updates to the matching records already in the database can be +-- specified in the third argument, these are arbitrary updates independent of +-- the new records proposed for insertion. For example, you can use this to +-- update a timestamp or a counter for all conflicting rows. +-- +-- You can use the fourth argument to provide arbitrary conditions to constrain +-- the above updates. This way, you can choose to only alter a subset of the +-- conflicting existing rows while leaving the others alone. For example, you +-- may want to copy fields from new records and update a timestamp only when the +-- corresponding existing row hasn't been soft-deleted. +-- +-- +-- For example, +-- +-- @ +-- upsertManyWhere +-- [record] -- (1) +-- [ copyField recordField1 -- (2) +-- , copyUnlessEq recordField2 -- (3) +-- , copyUnlessNull recordField3 -- (4) +-- ] +-- [recordField4 =. arbitraryValue] -- (5) +-- [recordField4 !=. anotherValue] -- (6) +-- @ +-- +-- 1. new records to insert if there's no conflicts +-- 2. for each conflicting existing row, replace the value of recordField1 with the one present in the conflicting new record +-- 3. only replace the existing value if it's different from the one present in the conflicting new record +-- 4. only replace the existing value if the new value is non-NULL (i.e. don't replace existing values with NULLs.) +-- +-- 5. update recordField4 with an arbitrary new value +-- 6. only apply the above updates for conflicting rows that meet this condition +-- +-- Called thusly, this method will insert a new record (if none exists) OR it +-- will copy three fields (@recordField1@, @recordField2@, @recordField3@) from +-- the record proposed from insertion onto the existing row in the database +-- following three different 'HandleUpdateCollision' strategies, it will /also/ +-- update @recordField4@ with an arbitrary @arbitraryValue@. Both sets of updates +-- will only be applied if the row already present in the database has a +-- @recordField4@ whose value is not @arbitraryValue@. The corresponding SQL might +-- look like this: +-- +-- @ +-- INSERT INTO table(recordField1, recordField2, recordField3, recordField4, recordField5) +-- VALUES +-- (newValue1, newValue2, newValue3, newValue4, newValue5) +-- ON CONFLICT (recordField2, recordField3) -- let's imagine these two columns define a unique constraint +-- DO UPDATE +-- SET +-- recordField1 = EXCLUDED.newValue1, -- EXCLUDED points to the new, conflicting, record; so we're always replacing the old value. +-- recordField2 = COALESCE(NULLIF(EXCLUDED.newValue2, table.recordField2), table.recordField2), -- if the values are the same, the NULLIF returns NULL and we coalesce into setting the column to the value it already had (i.e. no change) +-- recordField3 = COALESCE(NULLIF(EXCLUDED.newValue3, NULL), table.recordField3), -- if the new value is not null, it will be set; if it's null, we coalesce into not changing the existing value. +-- recordField4 = arbitraryValue -- an arbitrary update independent of what's in the EXCLUDED (new) record +-- WHERE +-- recordField4 <> anotherValue -- only do the above updates if the value for the existing row's recordField4 is not "anotherValue" +-- @ +-- +-- @since 2.12.1.0 +upsertManyWhere + :: forall record backend m + . ( backend ~ PersistEntityBackend record + , BackendCompatible SqlBackend backend + , PersistEntityBackend record ~ SqlBackend + , PersistEntity record + , OnlyOneUniqueKey record + , MonadIO m + ) + => [record] + -- ^ A list of the records you want to insert, or update + -> [HandleUpdateCollision record] + -- ^ A list of the fields you want to copy over. + -> [Update record] + -- ^ A list of the updates to apply that aren't dependent on the record + -- being inserted. + -> [Filter record] + -- ^ A filter condition that dictates the scope of the updates + -> ReaderT backend m () +upsertManyWhere [] _ _ _ = return () +upsertManyWhere records fieldValues updates filters = do + conn <- asks projectBackend + let + uniqDef = onlyOneUniqueDef (Proxy :: Proxy record) + uncurry rawExecute $ + mkBulkUpsertQuery records conn fieldValues updates filters uniqDef + +-- | Exclude any record field if it doesn't match the filter record. Used only in `upsertWhere` and +-- `upsertManyWhere` +-- +-- TODO: we could probably make a sum type for the `Filter` record that's passed into the `upsertWhere` and +-- `upsertManyWhere` methods that has similar behavior to the HandleCollisionUpdate type. +-- +-- @since 2.12.1.0 +excludeNotEqualToOriginal + :: (PersistField typ, PersistEntity rec) + => EntityField rec typ + -> Filter rec +excludeNotEqualToOriginal field = + Filter + { filterField = + field + , filterFilter = + Ne + , filterValue = + UnsafeValue $ + PersistLiteral_ + Unescaped + bsForExcludedField + } + where + bsForExcludedField = + T.encodeUtf8 $ + "EXCLUDED." + <> fieldName field + +-- | This creates the query for 'upsertManyWhere'. If you +-- provide an empty list of updates to perform, then it will generate +-- a dummy/no-op update using the first field of the record. This avoids +-- duplicate key exceptions. +mkBulkUpsertQuery + :: ( PersistEntity record + , PersistEntityBackend record ~ SqlBackend + , OnlyOneUniqueKey record + ) + => [record] + -- ^ A list of the records you want to insert, or update + -> SqlBackend + -> [HandleUpdateCollision record] + -- ^ A list of the fields you want to copy over. + -> [Update record] + -- ^ A list of the updates to apply that aren't dependent on the record being inserted. + -> [Filter record] + -- ^ A filter condition that dictates the scope of the updates + -> UniqueDef + -- ^ The specific uniqueness constraint to use on the record. Postgres + -- rquires that we use exactly one relevant constraint, and it can't do + -- a catch-all. How frustrating! + -> (Text, [PersistValue]) +mkBulkUpsertQuery records conn fieldValues updates filters uniqDef = + (q, recordValues <> updsValues <> copyUnlessValues <> whereVals) + where + mfieldDef x = case x of + CopyField rec -> Right (fieldDbToText (persistFieldDef rec)) + CopyUnlessEq rec val -> Left (fieldDbToText (persistFieldDef rec), toPersistValue val) + (fieldsToMaybeCopy, updateFieldNames) = partitionEithers $ map mfieldDef fieldValues + fieldDbToText = escapeF . fieldDB + entityDef' = entityDef records + conflictColumns = + map (escapeF . snd) $ NEL.toList $ uniqueFields uniqDef + firstField = case entityFieldNames of + [] -> error "The entity you're trying to insert does not have any fields." + (field : _) -> field + entityFieldNames = map fieldDbToText (getEntityFields entityDef') + nameOfTable = escapeE . getEntityDBName $ entityDef' + copyUnlessValues = map snd fieldsToMaybeCopy + recordValues = concatMap (map toPersistValue . toPersistFields) records + recordPlaceholders = + Util.commaSeparated + $ map + (Util.parenWrapped . Util.commaSeparated . map (const "?") . toPersistFields) + $ records + mkCondFieldSet n _ = + T.concat + [ n + , "=COALESCE(" + , "NULLIF(" + , "EXCLUDED." + , n + , "," + , "?" + , ")" + , "," + , nameOfTable + , "." + , n + , ")" + ] + condFieldSets = map (uncurry mkCondFieldSet) fieldsToMaybeCopy + fieldSets = map (\n -> T.concat [n, "=EXCLUDED.", n, ""]) updateFieldNames + upds = + map + (Util.mkUpdateText' (escapeF) (\n -> T.concat [nameOfTable, ".", n])) + updates + updsValues = map (\(Update _ val _) -> toPersistValue val) updates + (wher, whereVals) = + if null filters + then ("", []) + else (filterClauseWithVals (Just PrefixTableName) conn filters) + updateText = + case fieldSets <> upds <> condFieldSets of + [] -> + -- This case is really annoying, and probably unlikely to be + -- actually hit - someone would have had to call something like + -- `upsertManyWhere [] [] []`, but that would have been caught + -- by the prior case. + -- Would be nice to have something like a `NonEmpty (These ...)` + -- instead of multiple lists... + T.concat [firstField, "=", nameOfTable, ".", firstField] + xs -> + Util.commaSeparated xs + q = + T.concat + [ "INSERT INTO " + , nameOfTable + , Util.parenWrapped . Util.commaSeparated $ entityFieldNames + , " VALUES " + , recordPlaceholders + , " ON CONFLICT " + , Util.parenWrapped $ Util.commaSeparated $ conflictColumns + , " DO UPDATE SET " + , updateText + , wher + ] + +putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text +putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q + where + fieldDbToText = escapeF . fieldDB + mkAssignment f = T.concat [f, "=EXCLUDED.", f] + + table = escapeE . getEntityDBName $ ent + columns = Util.commaSeparated $ map fieldDbToText fields + placeholders = map (const "?") fields + updates = map (mkAssignment . fieldDbToText) fields + + q = + T.concat + [ "INSERT INTO " + , table + , Util.parenWrapped columns + , " VALUES " + , Util.commaSeparated + . replicate n + . Util.parenWrapped + . Util.commaSeparated + $ placeholders + , " ON CONFLICT " + , Util.parenWrapped . Util.commaSeparated $ conflictColumns + , " DO UPDATE SET " + , Util.commaSeparated updates + ] + +-- | Enable a Postgres extension. See https://www.postgresql.org/docs/current/static/contrib.html +-- for a list. +migrateEnableExtension :: Text -> Migration +migrateEnableExtension extName = WriterT $ WriterT $ do + res :: [Single Int] <- + rawSql + "SELECT COUNT(*) FROM pg_catalog.pg_extension WHERE extname = ?" + [PersistText extName] + if res == [Single 0] + then return (((), []), [(False, "CREATe EXTENSION \"" <> extName <> "\"")]) + else return (((), []), []) + +-- | Wrapper for persistent SqlBackends that carry the corresponding +-- `Postgresql.Connection`. +-- +-- @since 2.13.1.0 +data RawPostgresql backend = RawPostgresql + { persistentBackend :: backend + -- ^ The persistent backend + -- + -- @since 2.13.1.0 + , rawPostgresqlConnection :: PG.Connection + -- ^ The underlying `PG.Connection` + -- + -- @since 2.13.1.0 + } + +instance BackendCompatible (RawPostgresql b) (RawPostgresql b) where + projectBackend = id + +instance BackendCompatible b (RawPostgresql b) where + projectBackend = persistentBackend + +withRawConnection + :: (PG.Connection -> SqlBackend) + -> PG.Connection + -> RawPostgresql SqlBackend +withRawConnection f conn = + RawPostgresql + { persistentBackend = f conn + , rawPostgresqlConnection = conn + } + +-- | Create a PostgreSQL connection pool which also exposes the +-- raw connection. The raw counterpart to 'createPostgresqlPool'. +-- +-- @since 2.13.1.0 +createRawPostgresqlPool + :: (MonadUnliftIO m, MonadLoggerIO m) + => ConnectionString + -- ^ Connection string to the database. + -> Int + -- ^ Number of connections to be kept open + -- in the pool. + -> m (Pool (RawPostgresql SqlBackend)) +createRawPostgresqlPool = createRawPostgresqlPoolModified (const $ return ()) + +-- | The raw counterpart to 'createPostgresqlPoolModified'. +-- +-- @since 2.13.1.0 +createRawPostgresqlPoolModified + :: (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. + -> m (Pool (RawPostgresql SqlBackend)) +createRawPostgresqlPoolModified = createRawPostgresqlPoolModifiedWithVersion getServerVersion + +-- | The raw counterpart to 'createPostgresqlPoolModifiedWithVersion'. +-- +-- @since 2.13.1.0 +createRawPostgresqlPoolModifiedWithVersion + :: (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. + -> Int + -- ^ Number of connections to be kept open in the pool. + -> m (Pool (RawPostgresql SqlBackend)) +createRawPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do + let + getVer = oldGetVersionToNew getVerDouble + createSqlPool $ open' modConn getVer withRawConnection ci + +-- | The raw counterpart to 'createPostgresqlPoolWithConf'. +-- +-- @since 2.13.1.0 +createRawPostgresqlPoolWithConf + :: (MonadUnliftIO m, MonadLoggerIO m) + => PostgresConf + -- ^ Configuration for connecting to Postgres + -> PostgresConfHooks + -- ^ Record of callback functions + -> m (Pool (RawPostgresql SqlBackend)) +createRawPostgresqlPoolWithConf conf hooks = do + let + getVer = pgConfHooksGetServerVersion hooks + modConn = pgConfHooksAfterCreate hooks + createSqlPoolWithConfig + (open' modConn getVer withRawConnection (pgConnStr conf)) + (postgresConfToConnectionPoolConfig conf) + +#if MIN_VERSION_base(4,12,0) +instance (PersistCore b) => PersistCore (RawPostgresql b) where + newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (Compatible b (RawPostgresql b)) } + +makeCompatibleKeyInstances [t| forall b. Compatible b (RawPostgresql b) |] +#else +instance (PersistCore b) => PersistCore (RawPostgresql b) where + newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (RawPostgresql b) } + +deriving instance (Show (BackendKey b)) => Show (BackendKey (RawPostgresql b)) +deriving instance (Read (BackendKey b)) => Read (BackendKey (RawPostgresql b)) +deriving instance (Eq (BackendKey b)) => Eq (BackendKey (RawPostgresql b)) +deriving instance (Ord (BackendKey b)) => Ord (BackendKey (RawPostgresql b)) +deriving instance (Num (BackendKey b)) => Num (BackendKey (RawPostgresql b)) +deriving instance (Integral (BackendKey b)) => Integral (BackendKey (RawPostgresql b)) +deriving instance (PersistField (BackendKey b)) => PersistField (BackendKey (RawPostgresql b)) +deriving instance (PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (RawPostgresql b)) +deriving instance (Real (BackendKey b)) => Real (BackendKey (RawPostgresql b)) +deriving instance (Enum (BackendKey b)) => Enum (BackendKey (RawPostgresql b)) +deriving instance (Bounded (BackendKey b)) => Bounded (BackendKey (RawPostgresql b)) +deriving instance (ToJSON (BackendKey b)) => ToJSON (BackendKey (RawPostgresql b)) +deriving instance (FromJSON (BackendKey b)) => FromJSON (BackendKey (RawPostgresql b)) +#endif + +#if MIN_VERSION_base(4,12,0) +$(pure []) + +makeCompatibleInstances [t| forall b. Compatible b (RawPostgresql b) |] +#else +instance HasPersistBackend b => HasPersistBackend (RawPostgresql b) where + type BaseBackend (RawPostgresql b) = BaseBackend b + persistBackend = persistBackend . persistentBackend + +instance (PersistStoreRead b) => PersistStoreRead (RawPostgresql b) where + get = withReaderT persistentBackend . get + getMany = withReaderT persistentBackend . getMany + +instance (PersistQueryRead b) => PersistQueryRead (RawPostgresql b) where + selectSourceRes filts opts = withReaderT persistentBackend $ selectSourceRes filts opts + selectFirst filts opts = withReaderT persistentBackend $ selectFirst filts opts + selectKeysRes filts opts = withReaderT persistentBackend $ selectKeysRes filts opts + count = withReaderT persistentBackend . count + exists = withReaderT persistentBackend . exists + +instance (PersistQueryWrite b) => PersistQueryWrite (RawPostgresql b) where + updateWhere filts updates = withReaderT persistentBackend $ updateWhere filts updates + deleteWhere = withReaderT persistentBackend . deleteWhere + +instance (PersistUniqueRead b) => PersistUniqueRead (RawPostgresql b) where + getBy = withReaderT persistentBackend . getBy + +instance (PersistStoreWrite b) => PersistStoreWrite (RawPostgresql b) where + insert = withReaderT persistentBackend . insert + insert_ = withReaderT persistentBackend . insert_ + insertMany = withReaderT persistentBackend . insertMany + insertMany_ = withReaderT persistentBackend . insertMany_ + insertEntityMany = withReaderT persistentBackend . insertEntityMany + insertKey k = withReaderT persistentBackend . insertKey k + repsert k = withReaderT persistentBackend . repsert k + repsertMany = withReaderT persistentBackend . repsertMany + replace k = withReaderT persistentBackend . replace k + delete = withReaderT persistentBackend . delete + update k = withReaderT persistentBackend . update k + updateGet k = withReaderT persistentBackend . updateGet k + +instance (PersistUniqueWrite b) => PersistUniqueWrite (RawPostgresql b) where + deleteBy = withReaderT persistentBackend . deleteBy + insertUnique = withReaderT persistentBackend . insertUnique + upsert rec = withReaderT persistentBackend . upsert rec + upsertBy uniq rec = withReaderT persistentBackend . upsertBy uniq rec + putMany = withReaderT persistentBackend . putMany +#endif diff --git a/Database/Persist/Postgresql/Internal.hs b/Database/Persist/Postgresql/Internal.hs --- a/Database/Persist/Postgresql/Internal.hs +++ b/Database/Persist/Postgresql/Internal.hs @@ -1,284 +1,1281 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Database.Persist.Postgresql.Internal - ( P(..) - , PgInterval(..) - , getGetter - ) where - -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.FromField as PGFF -import qualified Database.PostgreSQL.Simple.Internal as PG -import qualified Database.PostgreSQL.Simple.ToField as PGTF -import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS -import qualified Database.PostgreSQL.Simple.Types as PG - -import qualified Blaze.ByteString.Builder.Char8 as BBB -import qualified Data.Attoparsec.ByteString.Char8 as P -import Data.Bits ((.&.)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as B8 -import Data.Char (ord) -import Data.Data (Typeable) -import Data.Fixed (Fixed(..), Pico) -import Data.Int (Int64) -import qualified Data.IntMap as I -import Data.Maybe (fromMaybe) -import Data.String.Conversions.Monomorphic (toStrictByteString) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time (NominalDiffTime, localTimeToUTC, utc) - -import Database.Persist.Sql - --- | Newtype used to avoid orphan instances for @postgresql-simple@ classes. --- --- @since 2.13.2.0 -newtype P = P { unP :: PersistValue } - -instance PGTF.ToField P where - toField (P (PersistText t)) = PGTF.toField t - toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) - toField (P (PersistInt64 i)) = PGTF.toField i - toField (P (PersistDouble d)) = PGTF.toField d - toField (P (PersistRational r)) = PGTF.Plain $ - BBB.fromString $ - show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field - toField (P (PersistBool b)) = PGTF.toField b - toField (P (PersistDay d)) = PGTF.toField d - toField (P (PersistTimeOfDay t)) = PGTF.toField t - toField (P (PersistUTCTime t)) = PGTF.toField t - 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 (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" - -instance PGFF.FromField P where - fromField field mdata = fmap P $ case mdata of - -- If we try to simply decode based on oid, we will hit unexpected null - -- errors. - Nothing -> pure PersistNull - data' -> getGetter (PGFF.typeOid field) field data' - -newtype Unknown = Unknown { unUnknown :: ByteString } - deriving (Eq, Show, Read, Ord) - -instance PGFF.FromField Unknown where - fromField f mdata = - case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField Unknown" - Just dat -> return (Unknown dat) - -instance PGTF.ToField Unknown where - toField (Unknown a) = PGTF.Escape a - -newtype UnknownLiteral = UnknownLiteral { unUnknownLiteral :: ByteString } - deriving (Eq, Show, Read, Ord, Typeable) - -instance PGFF.FromField UnknownLiteral where - fromField f mdata = - case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "Database.Persist.Postgresql/PGFF.FromField UnknownLiteral" - Just dat -> return (UnknownLiteral dat) - -instance PGTF.ToField UnknownLiteral where - toField (UnknownLiteral a) = PGTF.Plain $ BB.byteString a - -type Getter a = PGFF.FieldParser a - -convertPV :: PGFF.FromField a => (a -> b) -> Getter b -convertPV f = (fmap f .) . PGFF.fromField - -builtinGetters :: I.IntMap (Getter PersistValue) -builtinGetters = I.fromList - [ (k PS.bool, convertPV PersistBool) - , (k PS.bytea, convertPV (PersistByteString . unBinary)) - , (k PS.char, convertPV PersistText) - , (k PS.name, convertPV PersistText) - , (k PS.int8, convertPV PersistInt64) - , (k PS.int2, convertPV PersistInt64) - , (k PS.int4, convertPV PersistInt64) - , (k PS.text, convertPV PersistText) - , (k PS.xml, convertPV (PersistByteString . unUnknown)) - , (k PS.float4, convertPV PersistDouble) - , (k PS.float8, convertPV PersistDouble) - , (k PS.money, convertPV PersistRational) - , (k PS.bpchar, convertPV PersistText) - , (k PS.varchar, convertPV PersistText) - , (k PS.date, convertPV PersistDay) - , (k PS.time, convertPV PersistTimeOfDay) - , (k PS.timestamp, convertPV (PersistUTCTime. localTimeToUTC utc)) - , (k PS.timestamptz, convertPV PersistUTCTime) - , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs)) - , (k PS.bit, convertPV PersistInt64) - , (k PS.varbit, convertPV PersistInt64) - , (k PS.numeric, convertPV PersistRational) - , (k PS.void, \_ _ -> return PersistNull) - , (k PS.json, convertPV (PersistByteString . unUnknown)) - , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) - , (k PS.unknown, convertPV (PersistByteString . unUnknown)) - - -- Array types: same order as above. - -- The OIDs were taken from pg_type. - , (1000, listOf PersistBool) - , (1001, listOf (PersistByteString . unBinary)) - , (1002, listOf PersistText) - , (1003, listOf PersistText) - , (1016, listOf PersistInt64) - , (1005, listOf PersistInt64) - , (1007, listOf PersistInt64) - , (1009, listOf PersistText) - , (143, listOf (PersistByteString . unUnknown)) - , (1021, listOf PersistDouble) - , (1022, listOf PersistDouble) - , (1023, listOf PersistUTCTime) - , (1024, listOf PersistUTCTime) - , (791, listOf PersistRational) - , (1014, listOf PersistText) - , (1015, listOf PersistText) - , (1182, listOf PersistDay) - , (1183, listOf PersistTimeOfDay) - , (1115, listOf PersistUTCTime) - , (1185, listOf PersistUTCTime) - , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs)) - , (1561, listOf PersistInt64) - , (1563, listOf PersistInt64) - , (1231, listOf PersistRational) - -- no array(void) type - , (2951, listOf (PersistLiteralEscaped . unUnknown)) - , (199, listOf (PersistByteString . unUnknown)) - , (3807, listOf (PersistByteString . unUnknown)) - -- no array(unknown) either - ] - where - k (PGFF.typoid -> i) = PG.oid2int i - -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert - -- the values to Haskell-land. The @Maybe@ is important - -- because the usual way of checking NULLs - -- (c.f. withStmt') won't check for NULL inside - -- arrays---or any other compound structure for that matter. - listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) - where nullable = maybe PersistNull - --- | Get the field parser corresponding to the given 'PG.Oid'. --- --- For example, pass in the 'PG.Oid' of 'PS.bool', and you will get back a --- field parser which parses boolean values in the table into 'PersistBool's. --- --- @since 2.13.2.0 -getGetter :: PG.Oid -> Getter PersistValue -getGetter oid - = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters - where defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) - -unBinary :: PG.Binary a -> a -unBinary (PG.Binary x) = x - --- | Represent Postgres interval using NominalDiffTime --- --- @since 2.11.0.0 -newtype PgInterval = PgInterval { getPgInterval :: NominalDiffTime } - deriving (Eq, Show) - -pgIntervalToBs :: PgInterval -> ByteString -pgIntervalToBs = toStrictByteString . show . getPgInterval - -instance PGTF.ToField PgInterval where - toField (PgInterval t) = PGTF.toField t - -instance PGFF.FromField PgInterval where - fromField f mdata = - if PGFF.typeOid f /= PS.typoid PS.interval - then PGFF.returnError PGFF.Incompatible f "" - else case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" - Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of - Left msg -> PGFF.returnError PGFF.ConversionFailed f msg - Right t -> return $ PgInterval t - - where - toPico :: Integer -> Pico - toPico = MkFixed - - -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser - twoDigits :: P.Parser Int - twoDigits = do - a <- P.digit - b <- P.digit - let c2d c = ord c .&. 15 - return $! c2d a * 10 + c2d b - - -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser - seconds :: P.Parser Pico - seconds = do - real <- twoDigits - mc <- P.peekChar - case mc of - Just '.' -> do - t <- P.anyChar *> P.takeWhile1 P.isDigit - return $! parsePicos (fromIntegral real) t - _ -> return $! fromIntegral real - where - parsePicos :: Int64 -> B8.ByteString -> Pico - parsePicos a0 t = toPico (fromIntegral (t' * 10^n)) - where n = max 0 (12 - B8.length t) - t' = B8.foldl' (\a c -> 10 * a + fromIntegral (ord c .&. 15)) a0 - (B8.take 12 t) - - parseSign :: P.Parser Bool - parseSign = P.choice [P.char '-' >> return True, return False] - - -- Db stores it in [-]HHH:MM:SS.[SSSS] - -- For example, nominalDay is stored as 24:00:00 - interval :: P.Parser (Bool, Int, Int, Pico) - interval = do - s <- parseSign - h <- P.decimal <* P.char ':' - m <- twoDigits <* P.char ':' - ss <- seconds - if m < 60 && ss <= 60 - then return (s, h, m, ss) - else fail "Invalid interval" - - nominalDiffTime :: P.Parser NominalDiffTime - nominalDiffTime = do - (s, h, m, ss) <- interval - let pico = ss + 60 * (fromIntegral m) + 60 * 60 * (fromIntegral (abs h)) - return . fromRational . toRational $ if s then (-pico) else pico - -fromPersistValueError :: Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" - -> Text -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". - -> PersistValue -- ^ Incorrect value - -> Text -- ^ Error message -fromPersistValueError haskellType databaseType received = T.concat - [ "Failed to parse Haskell type `" - , haskellType - , "`; expected " - , databaseType - , " from database, but received: " - , T.pack (show received) - , ". Potential solution: Check that your database schema matches your Persistent model definitions." - ] - -instance PersistField PgInterval where - toPersistValue = PersistLiteralEscaped . pgIntervalToBs - 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 - fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x - -instance PersistFieldSql PgInterval where - sqlType _ = SqlOther "interval" - - +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Database.Persist.Postgresql.Internal + ( P (..) + , PgInterval (..) + , getGetter + , AlterDB (..) + , AlterTable (..) + , AlterColumn (..) + , SafeToRemove + , migrateStructured + , mockMigrateStructured + , addTable + , findAlters + , maySerial + , mayDefault + , showSqlType + , showColumn + , showAlter + , showAlterDb + , showAlterTable + , getAddReference + , udToPair + , safeToRemove + , postgresMkColumns + , getAlters + , escapeE + , escapeF + , escape + ) where + +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.Internal as PG +import qualified Database.PostgreSQL.Simple.ToField as PGTF +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS +import qualified Database.PostgreSQL.Simple.Types as PG + +import qualified Blaze.ByteString.Builder.Char8 as BBB +import Control.Arrow +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Unlift (MonadIO (..)) +import Control.Monad.Trans.Class (lift) +import Data.Acquire (with) +import qualified Data.Attoparsec.ByteString.Char8 as P +import Data.Bits ((.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BB +import qualified Data.ByteString.Char8 as B8 +import Data.Char (ord) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Data (Typeable) +import Data.Either (partitionEithers) +import Data.Fixed (Fixed (..), Pico) +import Data.Function (on) +import Data.Int (Int64) +import qualified Data.IntMap as I +import Data.List as List (find, foldl', groupBy, sort) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import Data.Maybe +import Data.String.Conversions.Monomorphic (toStrictByteString) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time (NominalDiffTime, localTimeToUTC, utc) +import Database.Persist.Sql +import qualified Database.Persist.Sql.Util as Util + +-- | Newtype used to avoid orphan instances for @postgresql-simple@ classes. +-- +-- @since 2.13.2.0 +newtype P = P {unP :: PersistValue} + +instance PGTF.ToField P where + toField (P (PersistText t)) = PGTF.toField t + toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) + toField (P (PersistInt64 i)) = PGTF.toField i + toField (P (PersistDouble d)) = PGTF.toField d + toField (P (PersistRational r)) = + PGTF.Plain $ + BBB.fromString $ + show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field + toField (P (PersistBool b)) = PGTF.toField b + toField (P (PersistDay d)) = PGTF.toField d + toField (P (PersistTimeOfDay t)) = PGTF.toField t + toField (P (PersistUTCTime t)) = PGTF.toField t + 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 (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" + +instance PGFF.FromField P where + fromField field mdata = fmap P $ case mdata of + -- If we try to simply decode based on oid, we will hit unexpected null + -- errors. + Nothing -> pure PersistNull + data' -> getGetter (PGFF.typeOid field) field data' + +newtype Unknown = Unknown {unUnknown :: ByteString} + deriving (Eq, Show, Read, Ord) + +instance PGFF.FromField Unknown where + fromField f mdata = + case mdata of + Nothing -> + PGFF.returnError + PGFF.UnexpectedNull + f + "Database.Persist.Postgresql/PGFF.FromField Unknown" + Just dat -> return (Unknown dat) + +instance PGTF.ToField Unknown where + toField (Unknown a) = PGTF.Escape a + +newtype UnknownLiteral = UnknownLiteral {unUnknownLiteral :: ByteString} + deriving (Eq, Show, Read, Ord, Typeable) + +instance PGFF.FromField UnknownLiteral where + fromField f mdata = + case mdata of + Nothing -> + PGFF.returnError + PGFF.UnexpectedNull + f + "Database.Persist.Postgresql/PGFF.FromField UnknownLiteral" + Just dat -> return (UnknownLiteral dat) + +instance PGTF.ToField UnknownLiteral where + toField (UnknownLiteral a) = PGTF.Plain $ BB.byteString a + +type Getter a = PGFF.FieldParser a + +convertPV :: (PGFF.FromField a) => (a -> b) -> Getter b +convertPV f = (fmap f .) . PGFF.fromField + +builtinGetters :: I.IntMap (Getter PersistValue) +builtinGetters = + I.fromList + [ (k PS.bool, convertPV PersistBool) + , (k PS.bytea, convertPV (PersistByteString . unBinary)) + , (k PS.char, convertPV PersistText) + , (k PS.name, convertPV PersistText) + , (k PS.int8, convertPV PersistInt64) + , (k PS.int2, convertPV PersistInt64) + , (k PS.int4, convertPV PersistInt64) + , (k PS.text, convertPV PersistText) + , (k PS.xml, convertPV (PersistByteString . unUnknown)) + , (k PS.float4, convertPV PersistDouble) + , (k PS.float8, convertPV PersistDouble) + , (k PS.money, convertPV PersistRational) + , (k PS.bpchar, convertPV PersistText) + , (k PS.varchar, convertPV PersistText) + , (k PS.date, convertPV PersistDay) + , (k PS.time, convertPV PersistTimeOfDay) + , (k PS.timestamp, convertPV (PersistUTCTime . localTimeToUTC utc)) + , (k PS.timestamptz, convertPV PersistUTCTime) + , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs)) + , (k PS.bit, convertPV PersistInt64) + , (k PS.varbit, convertPV PersistInt64) + , (k PS.numeric, convertPV PersistRational) + , (k PS.void, \_ _ -> return PersistNull) + , (k PS.json, convertPV (PersistByteString . unUnknown)) + , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) + , (k PS.unknown, convertPV (PersistByteString . unUnknown)) + , -- Array types: same order as above. + -- The OIDs were taken from pg_type. + (1000, listOf PersistBool) + , (1001, listOf (PersistByteString . unBinary)) + , (1002, listOf PersistText) + , (1003, listOf PersistText) + , (1016, listOf PersistInt64) + , (1005, listOf PersistInt64) + , (1007, listOf PersistInt64) + , (1009, listOf PersistText) + , (143, listOf (PersistByteString . unUnknown)) + , (1021, listOf PersistDouble) + , (1022, listOf PersistDouble) + , (1023, listOf PersistUTCTime) + , (1024, listOf PersistUTCTime) + , (791, listOf PersistRational) + , (1014, listOf PersistText) + , (1015, listOf PersistText) + , (1182, listOf PersistDay) + , (1183, listOf PersistTimeOfDay) + , (1115, listOf PersistUTCTime) + , (1185, listOf PersistUTCTime) + , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs)) + , (1561, listOf PersistInt64) + , (1563, listOf PersistInt64) + , (1231, listOf PersistRational) + , -- no array(void) type + (2951, listOf (PersistLiteralEscaped . unUnknown)) + , (199, listOf (PersistByteString . unUnknown)) + , (3807, listOf (PersistByteString . unUnknown)) + -- no array(unknown) either + ] + where + k (PGFF.typoid -> i) = PG.oid2int i + -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert + -- the values to Haskell-land. The @Maybe@ is important + -- because the usual way of checking NULLs + -- (c.f. withStmt') won't check for NULL inside + -- arrays---or any other compound structure for that matter. + listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) + where + nullable = maybe PersistNull + +-- | Get the field parser corresponding to the given 'PG.Oid'. +-- +-- For example, pass in the 'PG.Oid' of 'PS.bool', and you will get back a +-- field parser which parses boolean values in the table into 'PersistBool's. +-- +-- @since 2.13.2.0 +getGetter :: PG.Oid -> Getter PersistValue +getGetter oid = + fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters + where + defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) + +unBinary :: PG.Binary a -> a +unBinary (PG.Binary x) = x + +-- | Represent Postgres interval using NominalDiffTime +-- +-- @since 2.11.0.0 +newtype PgInterval = PgInterval {getPgInterval :: NominalDiffTime} + deriving (Eq, Show) + +pgIntervalToBs :: PgInterval -> ByteString +pgIntervalToBs = toStrictByteString . show . getPgInterval + +instance PGTF.ToField PgInterval where + toField (PgInterval t) = PGTF.toField t + +instance PGFF.FromField PgInterval where + fromField f mdata = + if PGFF.typeOid f /= PS.typoid PS.interval + then PGFF.returnError PGFF.Incompatible f "" + else case mdata of + Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" + Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of + Left msg -> PGFF.returnError PGFF.ConversionFailed f msg + Right t -> return $ PgInterval t + where + toPico :: Integer -> Pico + toPico = MkFixed + + -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser + twoDigits :: P.Parser Int + twoDigits = do + a <- P.digit + b <- P.digit + let + c2d c = ord c .&. 15 + return $! c2d a * 10 + c2d b + + -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser + seconds :: P.Parser Pico + seconds = do + real <- twoDigits + mc <- P.peekChar + case mc of + Just '.' -> do + t <- P.anyChar *> P.takeWhile1 P.isDigit + return $! parsePicos (fromIntegral real) t + _ -> return $! fromIntegral real + where + parsePicos :: Int64 -> B8.ByteString -> Pico + parsePicos a0 t = toPico (fromIntegral (t' * 10 ^ n)) + where + n = max 0 (12 - B8.length t) + t' = + B8.foldl' + (\a c -> 10 * a + fromIntegral (ord c .&. 15)) + a0 + (B8.take 12 t) + + parseSign :: P.Parser Bool + parseSign = P.choice [P.char '-' >> return True, return False] + + -- Db stores it in [-]HHH:MM:SS.[SSSS] + -- For example, nominalDay is stored as 24:00:00 + interval :: P.Parser (Bool, Int, Int, Pico) + interval = do + s <- parseSign + h <- P.decimal <* P.char ':' + m <- twoDigits <* P.char ':' + ss <- seconds + if m < 60 && ss <= 60 + then return (s, h, m, ss) + else fail "Invalid interval" + + nominalDiffTime :: P.Parser NominalDiffTime + nominalDiffTime = do + (s, h, m, ss) <- interval + let + pico = ss + 60 * (fromIntegral m) + 60 * 60 * (fromIntegral (abs h)) + return . fromRational . toRational $ if s then (-pico) else pico + +fromPersistValueError + :: Text + -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" + -> Text + -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". + -> PersistValue + -- ^ Incorrect value + -> Text + -- ^ Error message +fromPersistValueError haskellType databaseType received = + T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`; expected " + , databaseType + , " from database, but received: " + , T.pack (show received) + , ". Potential solution: Check that your database schema matches your Persistent model definitions." + ] + +instance PersistField PgInterval where + toPersistValue = PersistLiteralEscaped . pgIntervalToBs + 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 + fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x + +instance PersistFieldSql PgInterval where + sqlType _ = SqlOther "interval" + +-- | Indicates whether a Postgres Column is safe to drop. +-- +-- @since 2.17.1.0 +newtype SafeToRemove = SafeToRemove Bool + deriving (Show, Eq) + +-- | Represents a change to a Postgres column in a DB statement. +-- +-- @since 2.17.1.0 +data AlterColumn + = ChangeType Column SqlType Text + | IsNull Column + | NotNull Column + | AddColumn Column + | Drop Column SafeToRemove + | Default Column Text + | NoDefault Column + | UpdateNullToValue Column Text + | AddReference + EntityNameDB + ConstraintNameDB + (NEL.NonEmpty FieldNameDB) + [Text] + FieldCascade + | DropReference ConstraintNameDB + deriving (Show, Eq) + +-- | Represents a change to a Postgres table in a DB statement. +-- +-- @since 2.17.1.0 +data AlterTable + = AddUniqueConstraint ConstraintNameDB [FieldNameDB] + | DropConstraint ConstraintNameDB + deriving (Show, Eq) + +-- | Represents a change to a Postgres DB in a statement. +-- +-- @since 2.17.1.0 +data AlterDB + = AddTable EntityNameDB EntityIdDef [Column] + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable + deriving (Show, Eq) + +-- | Returns a structured representation of all of the +-- DB changes required to migrate the Entity from its +-- current state in the database to the state described in +-- Haskell. +-- +-- @since 2.17.1.0 +migrateStructured + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [AlterDB]) +migrateStructured allDefs getter entity = do + old <- getColumns getter entity newcols' + case partitionEithers old of + ([], old'') -> do + exists' <- + if null old + then doesTableExist getter name + else return True + return $ Right $ migrationText exists' old'' + (errs, _) -> return $ Left errs + where + name = getEntityDBName entity + (newcols', udefs, fdefs) = postgresMkColumns allDefs entity + migrationText exists' old'' + | not exists' = + createText newcols fdefs udspair + | otherwise = + let + (acs, ats) = + getAlters allDefs entity (newcols, udspair) old' + acs' = map (AlterColumn name) acs + ats' = map (AlterTable name) ats + in + acs' ++ ats' + where + old' = partitionEithers old'' + newcols = filter (not . safeToRemove entity . cName) newcols' + udspair = map udToPair udefs + -- Check for table existence if there are no columns, workaround + -- for https://github.com/yesodweb/persistent/issues/152 + + createText newcols fdefs_ udspair = + (addTable newcols entity) : uniques ++ references ++ foreignsAlt + where + uniques = flip concatMap udspair $ \(uname, ucols) -> + [AlterTable name $ AddUniqueConstraint uname ucols] + references = + mapMaybe + ( \Column{cName, cReference} -> + getAddReference allDefs entity cName =<< cReference + ) + newcols + foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs_ + +-- | Returns a structured representation of all of the +-- DB changes required to migrate the Entity to the state +-- described in Haskell, assuming it currently does not +-- exist in the database. +-- +-- @since 2.17.1.0 +mockMigrateStructured + :: [EntityDef] + -> EntityDef + -> [AlterDB] +mockMigrateStructured allDefs entity = migrationText + where + name = getEntityDBName entity + migrationText = createText newcols fdefs udspair + where + (newcols', udefs, fdefs) = postgresMkColumns allDefs entity + newcols = filter (not . safeToRemove entity . cName) newcols' + udspair = map udToPair udefs + -- Check for table existence if there are no columns, workaround + -- for https://github.com/yesodweb/persistent/issues/152 + + createText newcols fdefs udspair = + (addTable newcols entity) : uniques ++ references ++ foreignsAlt + where + uniques = flip concatMap udspair $ \(uname, ucols) -> + [AlterTable name $ AddUniqueConstraint uname ucols] + references = + mapMaybe + ( \Column{cName, cReference} -> + getAddReference allDefs entity cName =<< cReference + ) + newcols + foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs + +-- | Returns a structured representation of all of the +-- DB changes required to migrate the Entity from its current state +-- in the database to the state described in Haskell. +-- +-- @since 2.17.1.0 +addTable :: [Column] -> EntityDef -> AlterDB +addTable cols entity = + AddTable name entityId nonIdCols + where + nonIdCols = + case entityPrimary entity of + Just _ -> + cols + _ -> + filter keepField cols + where + keepField c = + Just (cName c) /= fmap fieldDB (getEntityIdField entity) + && not (safeToRemove entity (cName c)) + entityId = getEntityId entity + name = getEntityDBName entity + +maySerial :: SqlType -> Maybe Text -> Text +maySerial SqlInt64 Nothing = " SERIAL8 " +maySerial sType _ = " " <> showSqlType sType + +mayDefault :: Maybe Text -> Text +mayDefault def = case def of + Nothing -> "" + Just d -> " DEFAULT " <> d + +getAlters + :: [EntityDef] + -> EntityDef + -> ([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 -> Drop x $ SafeToRemove $ safeToRemove def $ cName x) old + getAltersC (new : news) old = + let + (alters, old') = findAlters defs def new old + in + alters ++ getAltersC news old' + + getAltersU + :: [(ConstraintNameDB, [FieldNameDB])] + -> [(ConstraintNameDB, [FieldNameDB])] + -> [AlterTable] + getAltersU [] old = + map DropConstraint $ filter (not . isManual) $ map fst old + getAltersU ((name, cols) : news) old = + case lookup name old of + Nothing -> + AddUniqueConstraint name cols : getAltersU news old + Just ocols -> + let + old' = filter (\(x, _) -> x /= name) old + in + if sort cols == sort ocols + then getAltersU news old' + else + DropConstraint name + : AddUniqueConstraint name cols + : getAltersU news old' + + -- Don't drop constraints which were manually added. + isManual (ConstraintNameDB x) = "__manual_" `T.isPrefixOf` x + +-- | Postgres' default maximum identifier length in bytes +-- (You can re-compile Postgres with a new limit, but I'm assuming that virtually noone does this). +-- See https://www.postgresql.org/docs/11/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS +maximumIdentifierLength :: Int +maximumIdentifierLength = 63 + +-- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer +sqlTypeEq :: SqlType -> SqlType -> Bool +sqlTypeEq x y = + let + -- Non exhaustive helper to map postgres aliases to the same name. Based on + -- https://www.postgresql.org/docs/9.5/datatype.html. + -- This prevents needless `ALTER TYPE`s when the type is the same. + normalize "int8" = "bigint" + normalize "serial8" = "bigserial" + normalize v = v + in + normalize (T.toCaseFold (showSqlType x)) + == normalize (T.toCaseFold (showSqlType y)) + +-- We check if we should alter a foreign key. This is almost an equality check, +-- except we consider 'Nothing' and 'Just Restrict' equivalent. +equivalentRef :: Maybe ColumnReference -> Maybe ColumnReference -> Bool +equivalentRef Nothing Nothing = True +equivalentRef (Just cr1) (Just cr2) = + crTableName cr1 == crTableName cr2 + && crConstraintName cr1 == crConstraintName cr2 + && eqCascade (fcOnUpdate $ crFieldCascade cr1) (fcOnUpdate $ crFieldCascade cr2) + && eqCascade (fcOnDelete $ crFieldCascade cr1) (fcOnDelete $ crFieldCascade cr2) + where + eqCascade :: Maybe CascadeAction -> Maybe CascadeAction -> Bool + eqCascade Nothing Nothing = True + eqCascade Nothing (Just Restrict) = True + eqCascade (Just Restrict) Nothing = True + eqCascade (Just cs1) (Just cs2) = cs1 == cs2 + eqCascade _ _ = False +equivalentRef _ _ = False + +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 + ConstraintNameDB $ + T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"] + where + -- Postgres automatically truncates too long foreign keys to a combination of + -- truncatedTableName + "_" + truncatedColumnName + "_fkey" + -- This works fine for normal use cases, but it creates an issue for Persistent + -- Because after running the migrations, Persistent sees the truncated foreign key constraint + -- doesn't have the expected name, and suggests that you migrate again + -- To workaround this, we copy the Postgres truncation approach before sending foreign key constraints to it. + -- + -- I believe this will also be an issue for extremely long table names, + -- but it's just much more likely to exist with foreign key constraints because they're usually tablename * 2 in length + + -- Approximation of the algorithm Postgres uses to truncate identifiers + -- See makeObjectName https://github.com/postgres/postgres/blob/5406513e997f5ee9de79d4076ae91c04af0c52f6/src/backend/commands/indexcmds.c#L2074-L2080 + shortenNames :: Int -> (Int, Int) -> (Int, Int) + shortenNames overhead (x, y) + | x + y + overhead <= maximumIdentifierLength = (x, y) + | x > y = shortenNames overhead (x - 1, y) + | otherwise = shortenNames overhead (x, y - 1) + +postgresMkColumns + :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) +postgresMkColumns allDefs t = + mkColumns allDefs t $ + setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides + +-- | Check if a column name is listed as the "safe to remove" in the entity +-- list. +safeToRemove :: EntityDef -> FieldNameDB -> Bool +safeToRemove def (FieldNameDB colName) = + any (elem FieldAttrSafeToRemove . fieldAttrs) $ + filter ((== FieldNameDB colName) . fieldDB) $ + allEntityFields + where + allEntityFields = + getEntityFieldsDatabase def <> case getEntityId def of + EntityIdField fdef -> + [fdef] + _ -> + [] + +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) +udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud) + +-- | Get the references to be added to a table for the given column. +getAddReference + :: [EntityDef] + -> EntityDef + -> FieldNameDB + -> ColumnReference + -> Maybe AlterDB +getAddReference allDefs entity cname cr@ColumnReference{crTableName = s, crConstraintName = constraintName} = do + guard $ Just cname /= fmap fieldDB (getEntityIdField entity) + pure $ + AlterColumn + table + (AddReference s constraintName (cname NEL.:| []) id_ (crFieldCascade cr)) + where + table = getEntityDBName entity + id_ = + fromMaybe + (error $ "Could not find ID of entity " ++ show s) + $ do + entDef <- find ((== s) . getEntityDBName) allDefs + return $ NEL.toList $ Util.dbIdColumnsEsc escapeF entDef + +mkForeignAlt + :: EntityDef + -> ForeignDef + -> Maybe AlterDB +mkForeignAlt entity fdef = case NEL.nonEmpty childfields of + Nothing -> Nothing + Just childfields' -> Just $ AlterColumn tableName_ addReference + where + addReference = + AddReference + (foreignRefTableDBName fdef) + constraintName + childfields' + escapedParentFields + (foreignFieldCascade fdef) + where + tableName_ = getEntityDBName entity + constraintName = + foreignConstraintNameDBName fdef + (childfields, parentfields) = + unzip (map (\((_, b), (_, d)) -> (b, d)) (foreignFields fdef)) + escapedParentFields = + map escapeF parentfields + +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 "" = "" + go ('"' : xs) = "\"\"" ++ go xs + go (x : xs) = x : go xs + +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable name entityId nonIdCols) = (False, rawText) + where + idtxt = + case entityId of + EntityIdNaturalKey pdef -> + T.concat + [ " PRIMARY KEY (" + , T.intercalate "," $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef + , ")" + ] + EntityIdField field -> + let + defText = defaultAttribute $ fieldAttrs field + sType = fieldSqlType field + in + T.concat + [ escapeF $ fieldDB field + , maySerial sType defText + , " PRIMARY KEY UNIQUE" + , mayDefault defText + ] + rawText = + T.concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! + , escapeE name + , "(" + , idtxt + , if null nonIdCols then "" else "," + , T.intercalate "," $ map showColumn nonIdCols + , ")" + ] +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, showAlter t ac) + where + isUnsafe (Drop _ (SafeToRemove safeRemove)) = not safeRemove + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, showAlterTable t at) + +showAlterTable :: EntityNameDB -> AlterTable -> Text +showAlterTable table (AddUniqueConstraint cname cols) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ADD CONSTRAINT " + , escapeC cname + , " UNIQUE(" + , T.intercalate "," $ map escapeF cols + , ")" + ] +showAlterTable table (DropConstraint cname) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " DROP CONSTRAINT " + , escapeC cname + ] + +showAlter :: EntityNameDB -> AlterColumn -> Text +showAlter table (ChangeType c t extra) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " TYPE " + , showSqlType t + , extra + ] +showAlter table (IsNull c) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " DROP NOT NULL" + ] +showAlter table (NotNull c) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " SET NOT NULL" + ] +showAlter table (AddColumn col) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ADD COLUMN " + , showColumn col + ] +showAlter table (Drop c _) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " DROP COLUMN " + , escapeF (cName c) + ] +showAlter table (Default c s) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " SET DEFAULT " + , s + ] +showAlter table (NoDefault c) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " DROP DEFAULT" + ] +showAlter table (UpdateNullToValue c s) = + T.concat + [ "UPDATE " + , escapeE table + , " SET " + , escapeF (cName c) + , "=" + , s + , " WHERE " + , escapeF (cName c) + , " IS NULL" + ] +showAlter table (AddReference reftable fkeyname t2 id2 cascade) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ADD CONSTRAINT " + , escapeC fkeyname + , " FOREIGN KEY(" + , T.intercalate "," $ map escapeF $ NEL.toList t2 + , ") REFERENCES " + , escapeE reftable + , "(" + , T.intercalate "," id2 + , ")" + ] + <> renderFieldCascade cascade +showAlter table (DropReference cname) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " DROP CONSTRAINT " + , escapeC cname + ] + +showColumn :: Column -> Text +showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = + T.concat + [ escapeF n + , " " + , showSqlType sqlType' + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " <> s + , case gen of + Nothing -> "" + Just s -> " GENERATED ALWAYS AS (" <> s <> ") STORED" + ] + +showSqlType :: SqlType -> Text +showSqlType SqlString = "VARCHAR" +showSqlType SqlInt32 = "INT4" +showSqlType SqlInt64 = "INT8" +showSqlType SqlReal = "DOUBLE PRECISION" +showSqlType (SqlNumeric s prec) = T.concat ["NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")"] +showSqlType SqlDay = "DATE" +showSqlType SqlTime = "TIME" +showSqlType SqlDayTime = "TIMESTAMP WITH TIME ZONE" +showSqlType SqlBlob = "BYTEA" +showSqlType SqlBool = "BOOLEAN" +-- Added for aliasing issues re: https://github.com/yesodweb/yesod/issues/682 +showSqlType (SqlOther (T.toLower -> "integer")) = "INT4" +showSqlType (SqlOther t) = t + +findAlters + :: [EntityDef] + -- ^ The list of all entity definitions that persistent is aware of. + -> EntityDef + -- ^ The entity definition for the entity that we're working on. + -> Column + -- ^ The column that we're searching for potential alterations for. + -> [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 -> + ([AddColumn col], cols) + Just + (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') -> + let + refDrop Nothing = [] + refDrop (Just ColumnReference{crConstraintName = cname}) = + [DropReference cname] + + refAdd Nothing = [] + refAdd (Just colRef) = + case find ((== crTableName colRef) . getEntityDBName) defs of + Just refdef + | Just _oldName /= fmap fieldDB (getEntityIdField edef) -> + [ AddReference + (crTableName colRef) + (crConstraintName colRef) + (name NEL.:| []) + (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef) + (crFieldCascade colRef) + ] + Just _ -> [] + Nothing -> + error $ + "could not find the entityDef for reftable[" + ++ show (crTableName colRef) + ++ "]" + modRef = + if equivalentRef ref ref' + then [] + else refDrop ref' ++ refAdd ref + modNull = case (isNull, isNull') of + (True, False) -> do + guard $ Just name /= fmap fieldDB (getEntityIdField edef) + pure (IsNull col) + (False, True) -> + let + up = case def of + Nothing -> id + Just s -> (:) (UpdateNullToValue col s) + in + up [NotNull col] + _ -> [] + modType + | sqlTypeEq sqltype sqltype' = [] + -- When converting from Persistent pre-2.0 databases, we + -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is + -- treated as UTC. + | sqltype == SqlDayTime && sqltype' == SqlOther "timestamp" = + [ ChangeType col sqltype $ + T.concat + [ " USING " + , escapeF name + , " AT TIME ZONE 'UTC'" + ] + ] + | otherwise = [ChangeType col sqltype ""] + modDef = + if def == def' + || isJust (T.stripPrefix "nextval" =<< def') + then [] + else case def of + Nothing -> [NoDefault col] + Just s -> [Default col s] + dropSafe = + if safeToRemove edef name + then error "wtf" [Drop col (SafeToRemove True)] + else [] + in + ( modRef ++ modDef ++ modNull ++ modType ++ dropSafe + , filter (\c -> cName c /= name) cols + ) + +-- | Returns all of the columns in the given table currently in the database. +getColumns + :: (Text -> IO Statement) + -> EntityDef + -> [Column] + -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] +getColumns getter def cols = do + let + sqlv = + T.concat + [ "SELECT " + , "column_name " + , ",is_nullable " + , ",COALESCE(domain_name, udt_name)" -- See DOMAINS below + , ",column_default " + , ",generation_expression " + , ",numeric_precision " + , ",numeric_scale " + , ",character_maximum_length " + , "FROM information_schema.columns " + , "WHERE table_catalog=current_database() " + , "AND table_schema=current_schema() " + , "AND table_name=? " + ] + + -- DOMAINS Postgres supports the concept of domains, which are data types + -- with optional constraints. An app might make an "email" domain over the + -- varchar type, with a CHECK that the emails are valid In this case the + -- generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN + -- foo TYPE email This code exists to use the domain name (email), instead + -- of the underlying type (varchar). This is tested in + -- EquivalentTypeTest.hs + + stmt <- getter sqlv + let + vals = + [ PersistText $ unEntityNameDB $ getEntityDBName def + ] + columns <- + with + (stmtQuery stmt vals) + (\src -> runConduit $ src .| processColumns .| CL.consume) + let + sqlc = + T.concat + [ "SELECT " + , "c.constraint_name, " + , "c.column_name " + , "FROM information_schema.key_column_usage AS c, " + , "information_schema.table_constraints AS k " + , "WHERE c.table_catalog=current_database() " + , "AND c.table_catalog=k.table_catalog " + , "AND c.table_schema=current_schema() " + , "AND c.table_schema=k.table_schema " + , "AND c.table_name=? " + , "AND c.table_name=k.table_name " + , "AND c.constraint_name=k.constraint_name " + , "AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') " + , "ORDER BY c.constraint_name, c.column_name" + ] + + stmt' <- getter sqlc + + us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) + return $ columns ++ us + where + refMap = + fmap (\cr -> (crTableName cr, crConstraintName cr)) $ + Map.fromList $ + List.foldl' ref [] cols + where + ref rs c = + maybe rs (\r -> (unFieldNameDB $ cName c, r) : rs) (cReference c) + getAll = + CL.mapM $ \x -> + pure $ case x of + [PersistText con, PersistText col] -> + (con, col) + [PersistByteString con, PersistByteString col] -> + (T.decodeUtf8 con, T.decodeUtf8 col) + o -> + error $ "unexpected datatype returned for postgres o=" ++ show o + helperU = do + rows <- getAll .| CL.consume + return + $ map + (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) + $ groupBy ((==) `on` fst) rows + processColumns = + CL.mapM $ \x'@((PersistText cname) : _) -> do + col <- + liftIO $ getColumn getter (getEntityDBName def) x' (Map.lookup cname refMap) + pure $ case col of + Left e -> Left e + Right c -> Right $ Left c + +getColumn + :: (Text -> IO Statement) + -> EntityNameDB + -> [PersistValue] + -> Maybe (EntityNameDB, ConstraintNameDB) + -> IO (Either Text Column) +getColumn + getter + tableName' + [ PersistText columnName + , PersistText isNullable + , PersistText typeName + , defaultValue + , generationExpression + , numericPrecision + , numericScale + , maxlen + ] + refName_ = runExceptT $ do + defaultValue' <- + case defaultValue of + PersistNull -> + pure Nothing + PersistText t -> + pure $ Just t + _ -> + throwError $ T.pack $ "Invalid default column: " ++ show defaultValue + + generationExpression' <- + case generationExpression of + PersistNull -> + pure Nothing + PersistText t -> + pure $ Just t + _ -> + throwError $ T.pack $ "Invalid generated column: " ++ show generationExpression + + let + typeStr = + case maxlen of + PersistInt64 n -> + T.concat [typeName, "(", T.pack (show n), ")"] + _ -> + typeName + + t <- getType typeStr + + let + cname = FieldNameDB columnName + + ref <- lift $ fmap join $ traverse (getRef cname) refName_ + + return + Column + { cName = cname + , cNull = isNullable == "YES" + , cSqlType = t + , cDefault = fmap stripSuffixes defaultValue' + , cGenerated = fmap stripSuffixes generationExpression' + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = fmap (\(a, b, c, d) -> ColumnReference a b (mkCascade c d)) ref + } + where + mkCascade updText delText = + FieldCascade + { fcOnUpdate = parseCascade updText + , fcOnDelete = parseCascade delText + } + + parseCascade txt = + case txt of + "NO ACTION" -> + Nothing + "CASCADE" -> + Just Cascade + "SET NULL" -> + Just SetNull + "SET DEFAULT" -> + Just SetDefault + "RESTRICT" -> + Just Restrict + _ -> + error $ "Unexpected value in parseCascade: " <> show txt + + stripSuffixes t = + loop' + [ "::character varying" + , "::text" + ] + where + loop' [] = t + loop' (p : ps) = + case T.stripSuffix p t of + Nothing -> loop' ps + Just t' -> t' + + getRef cname (_, refName') = do + let + sql = + T.concat + [ "SELECT DISTINCT " + , "ccu.table_name, " + , "tc.constraint_name, " + , "rc.update_rule, " + , "rc.delete_rule " + , "FROM information_schema.constraint_column_usage ccu " + , "INNER JOIN information_schema.key_column_usage kcu " + , " ON ccu.constraint_name = kcu.constraint_name " + , "INNER JOIN information_schema.table_constraints tc " + , " ON tc.constraint_name = kcu.constraint_name " + , "LEFT JOIN information_schema.referential_constraints AS rc" + , " ON rc.constraint_name = ccu.constraint_name " + , "WHERE tc.constraint_type='FOREIGN KEY' " + , "AND kcu.ordinal_position=1 " + , "AND kcu.table_name=? " + , "AND kcu.column_name=? " + , "AND tc.constraint_name=?" + ] + stmt <- getter sql + cntrs <- + with + ( stmtQuery + stmt + [ PersistText $ unEntityNameDB tableName' + , PersistText $ unFieldNameDB cname + , PersistText $ unConstraintNameDB refName' + ] + ) + (\src -> runConduit $ src .| CL.consume) + case cntrs of + [] -> + return Nothing + [ [ PersistText table + , PersistText constraint + , PersistText updRule + , PersistText 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 (unEntityNameDB tableName') + , " and column: " + , T.unpack (unFieldNameDB cname) + , " but got: " + , show xs + ] + + getType "int4" = pure SqlInt32 + getType "int8" = pure SqlInt64 + getType "varchar" = pure SqlString + getType "text" = pure SqlString + getType "date" = pure SqlDay + getType "bool" = pure SqlBool + getType "timestamptz" = pure SqlDayTime + getType "float4" = pure SqlReal + getType "float8" = pure SqlReal + getType "bytea" = pure SqlBlob + getType "time" = pure SqlTime + getType "numeric" = getNumeric numericPrecision numericScale + getType a = pure $ SqlOther a + + getNumeric (PersistInt64 a) (PersistInt64 b) = + pure $ SqlNumeric (fromIntegral a) (fromIntegral b) + getNumeric PersistNull PersistNull = + throwError $ + T.concat + [ "No precision and scale were specified for the column: " + , columnName + , " in table: " + , 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)." + ] + getNumeric a b = + throwError $ + T.concat + [ "Can not get numeric field precision for the column: " + , columnName + , " in table: " + , unEntityNameDB tableName' + , ". Expected an integer for both precision and scale, " + , "got: " + , T.pack $ show a + , " and " + , T.pack $ show b + , ", respectively." + , " Specify the values as numeric(total_digits, digits_after_decimal_place)." + ] +getColumn _ _ columnName _ = + return $ + Left $ + T.pack $ + "Invalid result from information_schema: " ++ show columnName + +doesTableExist + :: (Text -> IO Statement) + -> EntityNameDB + -> IO Bool +doesTableExist getter (EntityNameDB name) = do + stmt <- getter sql + with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) + where + sql = + "SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'" + <> " AND schemaname != 'information_schema' AND tablename=?" + vals = [PersistText name] + + start = await >>= maybe (error "No results when checking doesTableExist") start' + start' [PersistInt64 0] = finish False + start' [PersistInt64 1] = finish True + start' res = error $ "doesTableExist returned unexpected result: " ++ show res + finish x = await >>= maybe (return x) (error "Too many rows returned in doesTableExist") diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,108 +1,116 @@ -name: persistent-postgresql -version: 2.13.6.2 -license: MIT -license-file: LICENSE -author: Felipe Lessa, Michael Snoyman -maintainer: Michael Snoyman -synopsis: Backend for the persistent library using postgresql. -description: Based on the postgresql-simple package -category: Database, Yesod -stability: Stable -cabal-version: >= 1.10 -build-type: Simple -homepage: http://www.yesodweb.com/book/persistent -bug-reports: https://github.com/yesodweb/persistent/issues +name: persistent-postgresql +version: 2.13.7.0 +license: MIT +license-file: LICENSE +author: Felipe Lessa, Michael Snoyman +maintainer: Michael Snoyman +synopsis: Backend for the persistent library using postgresql. +description: Based on the postgresql-simple package +category: Database, Yesod +stability: Stable +cabal-version: >=1.10 +build-type: Simple +homepage: http://www.yesodweb.com/book/persistent +bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md library - build-depends: base >= 4.9 && < 5 - , persistent >= 2.13.3 && < 3 - , aeson >= 1.0 - , attoparsec - , blaze-builder - , bytestring >= 0.10 - , conduit >= 1.2.12 - , containers >= 0.5 - , monad-logger >= 0.3.25 - , mtl - , postgresql-simple >= 0.6.1 && < 0.8 - , postgresql-libpq >= 0.9.4.2 && < 0.11 - , resourcet >= 1.1.9 - , resource-pool - , string-conversions - , text >= 1.2 - , time >= 1.6 - , transformers >= 0.5 - , unliftio-core - , vault - exposed-modules: Database.Persist.Postgresql - , Database.Persist.Postgresql.Internal - , Database.Persist.Postgresql.JSON - ghc-options: -Wall - default-language: Haskell2010 + build-depends: + aeson >=1.0 + , attoparsec + , base >=4.9 && <5 + , blaze-builder + , bytestring >=0.10 + , conduit >=1.2.12 + , containers >=0.5 + , monad-logger >=0.3.25 + , mtl + , persistent >=2.13.3 && <3 + , postgresql-libpq >=0.9.4.2 && <0.12 + , postgresql-simple >=0.6.1 && <0.8 + , resource-pool + , resourcet >=1.1.9 + , string-conversions + , text >=1.2 + , time >=1.6 + , transformers >=0.5 + , unliftio-core + , vault + exposed-modules: + Database.Persist.Postgresql + Database.Persist.Postgresql.Internal + Database.Persist.Postgresql.JSON + + ghc-options: -Wall + default-language: Haskell2010 + source-repository head type: git - location: git://github.com/yesodweb/persistent.git + location: https://github.com/yesodweb/persistent.git test-suite test - type: exitcode-stdio-1.0 - main-is: main.hs - hs-source-dirs: test - other-modules: PgInit - ArrayAggTest - EquivalentTypeTestPostgres - JSONTest - CustomConstraintTest - PgIntervalTest - UpsertWhere - ImplicitUuidSpec - MigrationReferenceSpec - ghc-options: -Wall + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + other-modules: + ArrayAggTest + CustomConstraintTest + EquivalentTypeTestPostgres + ImplicitUuidSpec + JSONTest + MigrationReferenceSpec + PgInit + PgIntervalTest + UpsertWhere - build-depends: base >= 4.9 && < 5 - , persistent - , persistent-postgresql - , persistent-qq - , persistent-test - , aeson - , bytestring - , containers - , fast-logger - , HUnit - , hspec >= 2.4 - , hspec-expectations - , hspec-expectations-lifted - , monad-logger - , QuickCheck - , quickcheck-instances - , resourcet - , text - , time - , transformers - , path-pieces - , http-api-data - , unliftio-core - , unliftio - , unordered-containers - , vector - default-language: Haskell2010 + ghc-options: -Wall + build-depends: + aeson + , base >=4.9 && <5 + , bytestring + , containers + , fast-logger + , hspec >=2.4 + , hspec-expectations + , hspec-expectations-lifted + , http-api-data + , HUnit + , monad-logger + , path-pieces + , persistent + , persistent-postgresql + , persistent-qq + , persistent-test + , QuickCheck + , quickcheck-instances + , resourcet + , text + , time + , transformers + , unliftio + , unliftio-core + , 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 + buildable: False + main-is: Main.hs + hs-source-dirs: conn-killed + ghc-options: -threaded + build-depends: + base + , bytestring + , monad-logger + , mtl + , persistent + , persistent-postgresql + , resource-pool + , text + , time + , transformers + , unliftio + + default-language: Haskell2010