diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,26 @@ # Changelog for persistent-postgresql +## 2.11.0.0 + +* Foreign Key improvements [#1121] https://github.com/yesodweb/persistent/pull/1121 + * It is now supported to refer to a table with an auto generated Primary Kay + * It is now supported to refer to non-primary fields, using the keyword `References` +* Implement interval support. [#1053](https://github.com/yesodweb/persistent/pull/1053) +* [#1060](https://github.com/yesodweb/persistent/pull/1060) + * The QuasiQuoter now supports `OnDelete` and `OnUpdate` cascade options. +* Handle foreign key constraint names over 63 characters. See [#996](https://github.com/yesodweb/persistent/pull/996) for details. +* Fix a bug in `upsertSql` query which had not been discovered previously because the query wasn't actually used. [#856](https://github.com/yesodweb/persistent/pull/856) +* [#1072](https://github.com/yesodweb/persistent/pull/1072) Refactored `test/JSONTest.hs` to use `hspec` + * added `runConn_` to run a db connection and return result + * Renamed `db` to `runConnAssert` in `test/PgInit.hs` for clarity + * Ran `test/ArrayAggTest.hs` (which was previously written but not being run) +* Remove unnecessary deriving of Typeable [#1114](https://github.com/yesodweb/persistent/pull/1114) +* Add support for configuring the number of stripes and idle timeout for connection pools [#1098](https://github.com/yesodweb/persistent/pull/1098) + * `PostgresConf` has two new fields to configure these values. + * Its `FromJSON` instance will default stripes to 1 and idle timeout to 600 seconds + * If you're constructing a `PostgresConf` manually, this is a breaking change + * Add `createPostgresqlPoolWithConf` and `withPostgresqlPoolWithConf`, which take a `PostgresConf` for the new configuration. + ## 2.10.1.2 * Fix issue with multiple foreign keys on single column. [#1010](https://github.com/yesodweb/persistent/pull/1010) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -1,1290 +1,1753 @@ {-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE ViewPatterns #-} - --- | A postgresql backend for persistent. -module Database.Persist.Postgresql - ( withPostgresqlPool - , withPostgresqlPoolWithVersion - , withPostgresqlConn - , withPostgresqlConnWithVersion - , createPostgresqlPool - , createPostgresqlPoolModified - , createPostgresqlPoolModifiedWithVersion - , module Database.Persist.Sql - , ConnectionString - , PostgresConf (..) - , openSimpleConn - , openSimpleConnWithVersion - , tableName - , fieldName - , mockMigration - , migrateEnableExtension - ) where - -import qualified Database.PostgreSQL.LibPQ as LibPQ - -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.Internal as PG -import qualified Database.PostgreSQL.Simple.FromField as PGFF -import qualified Database.PostgreSQL.Simple.ToField as PGTF -import qualified Database.PostgreSQL.Simple.Transaction as PG -import qualified Database.PostgreSQL.Simple.Types as PG -import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS -import Database.PostgreSQL.Simple.Ok (Ok (..)) - -import Control.Arrow -import Control.Exception (Exception, throw, throwIO) -import Control.Monad (forM) -import Control.Monad.IO.Unlift (MonadIO (..), MonadUnliftIO) -import Control.Monad.Logger (MonadLogger, runNoLoggingT) -import Control.Monad.Trans.Reader (runReaderT) -import Control.Monad.Trans.Writer (WriterT(..), runWriterT) - -import qualified Blaze.ByteString.Builder.Char8 as BBB -import Data.Acquire (Acquire, mkAcquire, with) -import Data.Aeson -import Data.Aeson.Types (modifyFailure) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Data -import Data.Either (partitionEithers) -import Data.Fixed (Pico) -import Data.Function (on) -import Data.Int (Int64) -import qualified Data.IntMap as I -import Data.IORef -import Data.List (find, sort, groupBy) -import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as Map -import Data.Maybe -import Data.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 Data.Time (utc, localTimeToUTC) -import Data.Typeable (Typeable) -import System.Environment (getEnvironment) - -import Database.Persist.Sql -import qualified Database.Persist.Sql.Util as Util - --- | 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 deriving Data.Typeable.Typeable - -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 :: (MonadLogger 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, MonadLogger 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 getVer ci = withSqlPool $ open' (const $ return ()) getVer 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, MonadLogger 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, MonadLogger 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, MonadLogger 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 getVer modConn ci = - createSqlPool $ open' modConn getVer ci - --- | Same as 'withPostgresqlPool', but instead of opening a pool --- of connections, only one connection is opened. --- The provided action should use 'runSqlConn' and *not* 'runReaderT' because --- the former brackets the database action with transaction begin/commit. -withPostgresqlConn :: (MonadUnliftIO m, MonadLogger m) - => ConnectionString -> (SqlBackend -> m a) -> m a -withPostgresqlConn = withPostgresqlConnWithVersion getServerVersion - --- | 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, MonadLogger m) - => (PG.Connection -> IO (Maybe Double)) - -> ConnectionString - -> (SqlBackend -> m a) - -> m a -withPostgresqlConnWithVersion getVer = withSqlConn . open' (const $ return ()) getVer - -open' - :: (PG.Connection -> IO ()) - -> (PG.Connection -> IO (Maybe Double)) - -> ConnectionString -> LogFunc -> IO SqlBackend -open' modConn getVer cstr logFunc = do - conn <- PG.connectPostgreSQL cstr - modConn conn - ver <- getVer conn - smap <- newIORef $ Map.empty - return $ createBackend logFunc ver smap conn - --- | Gets the PostgreSQL server version -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 - --- | 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 -> Double -> Maybe a -upsertFunction f version = if (version >= 9.5) - then Just f - else Nothing - - --- | 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 getVer logFunc conn = do - smap <- newIORef $ Map.empty - serverVersion <- getVer conn - return $ createBackend logFunc serverVersion smap conn - --- | Create the backend given a logging function, server version, mutable statement cell, --- and connection. -createBackend :: LogFunc -> Maybe Double - -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend -createBackend logFunc serverVersion smap conn = do - SqlBackend - { connPrepare = prepare' conn - , connStmtMap = smap - , connInsertSql = insertSql' - , connInsertManySql = Just insertManySql' - , connUpsertSql = serverVersion >>= upsertFunction upsertSql' - , connPutManySql = serverVersion >>= upsertFunction putManySql - , 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 - , connEscapeName = escape - , connNoLimit = "LIMIT ALL" - , connRDBMS = "postgresql" - , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" - , connLogFunc = logFunc - , connMaxParams = Nothing - , connRepsertManySql = serverVersion >>= upsertFunction repsertManySql - } - -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 = - let sql = T.concat - [ "INSERT INTO " - , escape $ entityDB ent - , if null (entityFields ent) - then " DEFAULT VALUES" - else T.concat - [ "(" - , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent - , ") VALUES(" - , T.intercalate "," (map (const "?") $ entityFields ent) - , ")" - ] - ] - in case entityPrimary ent of - Just _pdef -> ISRManyKeys sql vals - Nothing -> ISRSingle (sql <> " RETURNING " <> escape (fieldDB (entityId ent))) - - -upsertSql' :: EntityDef -> NonEmpty UniqueDef -> Text -> Text -upsertSql' ent uniqs updateVal = T.concat - [ "INSERT INTO " - , escape (entityDB ent) - , "(" - , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent - , ") VALUES (" - , T.intercalate "," $ map (const "?") (entityFields ent) - , ") ON CONFLICT (" - , T.intercalate "," $ concat $ map (\x -> map escape (map snd $ uniqueFields x)) (entityUniques ent) - , ") DO UPDATE SET " - , updateVal - , " WHERE " - , wher - , " RETURNING ??" - ] - where - wher = T.intercalate " AND " $ map singleCondition $ NEL.toList uniqs - - singleCondition :: UniqueDef -> Text - singleCondition udef = T.intercalate " AND " (map singleClause $ map snd (uniqueFields udef)) - - singleClause :: DBName -> Text - singleClause field = escape (entityDB ent) <> "." <> (escape field) <> " =?" - --- | SQL for inserting multiple rows at once and returning their primary keys. -insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult -insertManySql' ent valss = - let sql = T.concat - [ "INSERT INTO " - , escape (entityDB ent) - , "(" - , T.intercalate "," $ map (escape . fieldDB) $ entityFields ent - , ") VALUES (" - , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," $ map (const "?") (entityFields ent) - , ") RETURNING " - , Util.commaSeparated $ Util.dbIdColumnsEsc escape ent - ] - in ISRSingle sql - -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 conn 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 - --- | Avoid orphan instances. -newtype P = P 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 (PersistDbSpecific s)) = PGTF.toField (Unknown s) - toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a - toField (P (PersistObjectId _)) = - error "Refusing to serialize a PersistObjectId to a PostgreSQL value" - -newtype Unknown = Unknown { unUnknown :: ByteString } - deriving (Eq, Show, Read, Ord, Typeable) - -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 - -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 PersistText) - , (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.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 PersistText) - , (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) - , (1561, listOf PersistInt64) - , (1563, listOf PersistInt64) - , (1231, listOf PersistRational) - -- no array(void) type - , (2951, listOf (PersistDbSpecific . 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 - -getGetter :: PG.Connection -> PG.Oid -> Getter PersistValue -getGetter _conn oid - = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters - where defaultGetter = convertPV (PersistDbSpecific . unUnknown) - -unBinary :: PG.Binary a -> a -unBinary (PG.Binary x) = x - -doesTableExist :: (Text -> IO Statement) - -> DBName -- ^ table name - -> IO Bool -doesTableExist getter (DBName 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] [(Bool, Text)]) -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 = entityDB entity - (newcols', udefs, fdefs) = mkColumns allDefs entity - migrationText exists old'' = - if not exists - then createText newcols fdefs udspair - else let (acs, ats) = getAlters allDefs entity (newcols, udspair) $ excludeForeignKeys $ 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 - excludeForeignKeys (xs,ys) = (map excludeForeignKey xs,ys) - excludeForeignKey c = case cReference c of - Just (_,fk) -> - case find (\f -> fk == foreignConstraintNameDBName f) fdefs of - Just _ -> c { cReference = Nothing } - Nothing -> c - Nothing -> c - -- Check for table existence if there are no columns, workaround - -- for https://github.com/yesodweb/persistent/issues/152 - - createText newcols fdefs udspair = - (addTable newcols entity) : uniques ++ references ++ foreignsAlt - where - uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] - references = mapMaybe (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> - getAddReference allDefs name refTblName cname (cReference c)) - $ filter (isJust . cReference) newcols - foreignsAlt = flip map fdefs (\fdef -> - let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields))) - -addTable :: [Column] -> EntityDef -> AlterDB -addTable cols entity = AddTable $ T.concat - -- Lower case e: see Database.Persist.Sql.Migration - [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! - , escape name - , "(" - , idtxt - , if null cols then "" else "," - , T.intercalate "," $ map showColumn cols - , ")" - ] - where - name = entityDB entity - idtxt = case entityPrimary entity of - Just pdef -> T.concat [" PRIMARY KEY (", T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef, ")"] - Nothing -> - let defText = defaultAttribute $ fieldAttrs $ entityId entity - sType = fieldSqlType $ entityId entity - in T.concat - [ escape $ fieldDB (entityId entity) - , 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 SqlType Text - | IsNull | NotNull | Add' Column | Drop SafeToRemove - | Default Text | NoDefault | Update' Text - | AddReference DBName [DBName] [Text] | DropReference DBName -type AlterColumn' = (DBName, AlterColumn) - -data AlterTable = AddUniqueConstraint DBName [DBName] - | DropConstraint DBName - -data AlterDB = AddTable Text - | AlterColumn DBName AlterColumn' - | AlterTable DBName AlterTable - --- | Returns all of the columns in the given table currently in the database. -getColumns :: (Text -> IO Statement) - -> EntityDef -> [Column] - -> IO [Either Text (Either Column (DBName, [DBName]))] -getColumns getter def cols = do - let sqlv=T.concat ["SELECT " - ,"column_name " - ,",is_nullable " - ,",COALESCE(domain_name, udt_name)" -- See DOMAINS below - ,",column_default " - ,",numeric_precision " - ,",numeric_scale " - ,",character_maximum_length " - ,"FROM information_schema.columns " - ,"WHERE table_catalog=current_database() " - ,"AND table_schema=current_schema() " - ,"AND table_name=? " - ,"AND column_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 $ unDBName $ entityDB def - , PersistText $ unDBName $ fieldDB (entityId def) - ] - cs <- with (stmtQuery stmt vals) (\src -> runConduit $ src .| helper) - let sqlc = T.concat ["SELECT " - ,"c.constraint_name, " - ,"c.column_name " - ,"FROM information_schema.key_column_usage c, " - ,"information_schema.table_constraints 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.column_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 $ cs ++ us - where - refMap = Map.fromList $ foldl ref [] cols - where ref rs c = case cReference c of - Nothing -> rs - (Just r) -> (unDBName $ cName c, r) : rs - getAll front = do - x <- CL.head - case x of - Nothing -> return $ front [] - Just [PersistText con, PersistText col] -> getAll (front . (:) (con, col)) - Just [PersistByteString con, PersistByteString col] -> getAll (front . (:) (T.decodeUtf8 con, T.decodeUtf8 col)) - Just o -> error $ "unexpected datatype returned for postgres o="++show o - helperU = do - rows <- getAll id - return $ map (Right . Right . (DBName . fst . head &&& map (DBName . snd))) - $ groupBy ((==) `on` fst) rows - helper = do - x <- CL.head - case x of - Nothing -> return [] - Just x'@((PersistText cname):_) -> do - col <- liftIO $ getColumn getter (entityDB def) x' (Map.lookup cname refMap) - let col' = case col of - Left e -> Left e - Right c -> Right $ Left c - cols <- helper - return $ col' : cols - --- | Check if a column name is listed as the "safe to remove" in the entity --- list. -safeToRemove :: EntityDef -> DBName -> Bool -safeToRemove def (DBName colName) - = any (elem "SafeToRemove" . fieldAttrs) - $ filter ((== DBName colName) . fieldDB) - $ entityFields def - -getAlters :: [EntityDef] - -> EntityDef - -> ([Column], [(DBName, [DBName])]) - -> ([Column], [(DBName, [DBName])]) - -> ([AlterColumn'], [AlterTable]) -getAlters defs def (c1, u1) (c2, u2) = - (getAltersC c1 c2, getAltersU u1 u2) - where - getAltersC [] old = map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old - getAltersC (new:news) old = - let (alters, old') = findAlters defs (entityDB def) new old - in alters ++ getAltersC news old' - - getAltersU :: [(DBName, [DBName])] - -> [(DBName, [DBName])] - -> [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 (DBName x) = "__manual_" `T.isPrefixOf` x - -getColumn :: (Text -> IO Statement) - -> DBName -> [PersistValue] - -> Maybe (DBName, DBName) - -> IO (Either Text Column) -getColumn getter tableName' [PersistText columnName, PersistText isNullable, PersistText typeName, defaultValue, numericPrecision, numericScale, maxlen] refName = - case d' of - Left s -> return $ Left s - Right d'' -> - let typeStr = case maxlen of - PersistInt64 n -> T.concat [typeName, "(", T.pack (show n), ")"] - _ -> typeName - in case getType typeStr of - Left s -> return $ Left s - Right t -> do - let cname = DBName columnName - ref <- getRef cname refName - return $ Right Column - { cName = cname - , cNull = isNullable == "YES" - , cSqlType = t - , cDefault = fmap stripSuffixes d'' - , cDefaultConstraintName = Nothing - , cMaxLen = Nothing - , cReference = ref - } - where - 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 _ Nothing = return Nothing - getRef cname (Just (_, refName')) = do - let sql = T.concat ["SELECT DISTINCT " - ,"ccu.table_name, " - ,"tc.constraint_name " - ,"FROM information_schema.constraint_column_usage ccu, " - ,"information_schema.key_column_usage kcu, " - ,"information_schema.table_constraints tc " - ,"WHERE tc.constraint_type='FOREIGN KEY' " - ,"AND kcu.constraint_name=tc.constraint_name " - ,"AND ccu.constraint_name=kcu.constraint_name " - ,"AND kcu.ordinal_position=1 " - ,"AND kcu.table_name=? " - ,"AND kcu.column_name=? " - ,"AND tc.constraint_name=?"] - stmt <- getter sql - cntrs <- with (stmtQuery stmt [PersistText $ unDBName tableName' - ,PersistText $ unDBName cname - ,PersistText $ unDBName refName']) - (\src -> runConduit $ src .| CL.consume) - case cntrs of - [] -> return Nothing - [[PersistText table, PersistText constraint]] -> - return $ Just (DBName table, DBName constraint) - xs -> - error $ mconcat - [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " - , T.unpack (unDBName tableName') - , " and column: " - , T.unpack (unDBName cname) - , " but got: " - , show xs - ] - d' = case defaultValue of - PersistNull -> Right Nothing - PersistText t -> Right $ Just t - _ -> Left $ T.pack $ "Invalid default column: " ++ show defaultValue - getType "int4" = Right SqlInt32 - getType "int8" = Right SqlInt64 - getType "varchar" = Right SqlString - getType "text" = Right SqlString - getType "date" = Right SqlDay - getType "bool" = Right SqlBool - getType "timestamptz" = Right SqlDayTime - getType "float4" = Right SqlReal - getType "float8" = Right SqlReal - getType "bytea" = Right SqlBlob - getType "time" = Right SqlTime - getType "numeric" = getNumeric numericPrecision numericScale - getType a = Right $ SqlOther a - - getNumeric (PersistInt64 a) (PersistInt64 b) = Right $ SqlNumeric (fromIntegral a) (fromIntegral b) - getNumeric PersistNull PersistNull = Left $ T.concat - [ "No precision and scale were specified for the column: " - , columnName - , " in table: " - , unDBName 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 = Left $ T.concat - [ "Can not get numeric field precision for the column: " - , columnName - , " in table: " - , unDBName 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 = - T.toCaseFold (showSqlType x) == T.toCaseFold (showSqlType y) - -findAlters :: [EntityDef] -> DBName -> Column -> [Column] -> ([AlterColumn'], [Column]) -findAlters defs _tablename col@(Column name isNull sqltype def _defConstraintName _maxLen ref) cols = - case filter (\c -> cName c == name) cols of - [] -> ([(name, Add' col)], cols) - Column _ isNull' sqltype' def' _defConstraintName' _maxLen' ref':_ -> - let refDrop Nothing = [] - refDrop (Just (_, cname)) = [(name, DropReference cname)] - refAdd Nothing = [] - refAdd (Just (tname, a)) = - case find ((==tname) . entityDB) defs of - Just refdef -> [(tname, AddReference a [name] (Util.dbIdColumnsEsc escape refdef))] - Nothing -> error $ "could not find the entityDef for reftable[" ++ show tname ++ "]" - modRef = - if fmap snd ref == fmap snd ref' - then [] - else refDrop ref' ++ refAdd ref - modNull = case (isNull, isNull') of - (True, False) -> [(name, IsNull)] - (False, True) -> - let up = case def of - Nothing -> id - Just s -> (:) (name, Update' s) - in up [(name, NotNull)] - _ -> [] - 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" = - [(name, ChangeType sqltype $ T.concat - [ " USING " - , escape name - , " AT TIME ZONE 'UTC'" - ])] - | otherwise = [(name, ChangeType sqltype "")] - modDef = - if def == def' - then [] - else case def of - Nothing -> [(name, NoDefault)] - Just s -> [(name, Default s)] - in (modRef ++ modDef ++ modNull ++ modType, - filter (\c -> cName c /= name) cols) - --- | Get the references to be added to a table for the given column. -getAddReference :: [EntityDef] -> DBName -> DBName -> DBName -> Maybe (DBName, DBName) -> Maybe AlterDB -getAddReference allDefs table reftable cname ref = - case ref of - Nothing -> Nothing - Just (s, constraintName) -> Just $ AlterColumn table (s, AddReference constraintName [cname] id_) - where - id_ = fromMaybe (error $ "Could not find ID of entity " ++ show reftable) - $ do - entDef <- find ((== reftable) . entityDB) allDefs - return $ Util.dbIdColumnsEsc escape entDef - - -showColumn :: Column -> Text -showColumn (Column n nu sqlType' def _defConstraintName _maxLen _ref) = T.concat - [ escape n - , " " - , showSqlType sqlType' - , " " - , if nu then "NULL" else "NOT NULL" - , case def of - Nothing -> "" - Just s -> " DEFAULT " <> s - ] - -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 (c, ac)) = - (isUnsafe ac, showAlter t (c, ac)) - where - isUnsafe (Drop safeRemove) = not safeRemove - isUnsafe _ = False -showAlterDb (AlterTable t at) = (False, showAlterTable t at) - -showAlterTable :: DBName -> AlterTable -> Text -showAlterTable table (AddUniqueConstraint cname cols) = T.concat - [ "ALTER TABLE " - , escape table - , " ADD CONSTRAINT " - , escape cname - , " UNIQUE(" - , T.intercalate "," $ map escape cols - , ")" - ] -showAlterTable table (DropConstraint cname) = T.concat - [ "ALTER TABLE " - , escape table - , " DROP CONSTRAINT " - , escape cname - ] - -showAlter :: DBName -> AlterColumn' -> Text -showAlter table (n, ChangeType t extra) = - T.concat - [ "ALTER TABLE " - , escape table - , " ALTER COLUMN " - , escape n - , " TYPE " - , showSqlType t - , extra - ] -showAlter table (n, IsNull) = - T.concat - [ "ALTER TABLE " - , escape table - , " ALTER COLUMN " - , escape n - , " DROP NOT NULL" - ] -showAlter table (n, NotNull) = - T.concat - [ "ALTER TABLE " - , escape table - , " ALTER COLUMN " - , escape n - , " SET NOT NULL" - ] -showAlter table (_, Add' col) = - T.concat - [ "ALTER TABLE " - , escape table - , " ADD COLUMN " - , showColumn col - ] -showAlter table (n, Drop _) = - T.concat - [ "ALTER TABLE " - , escape table - , " DROP COLUMN " - , escape n - ] -showAlter table (n, Default s) = - T.concat - [ "ALTER TABLE " - , escape table - , " ALTER COLUMN " - , escape n - , " SET DEFAULT " - , s - ] -showAlter table (n, NoDefault) = T.concat - [ "ALTER TABLE " - , escape table - , " ALTER COLUMN " - , escape n - , " DROP DEFAULT" - ] -showAlter table (n, Update' s) = T.concat - [ "UPDATE " - , escape table - , " SET " - , escape n - , "=" - , s - , " WHERE " - , escape n - , " IS NULL" - ] -showAlter table (reftable, AddReference fkeyname t2 id2) = T.concat - [ "ALTER TABLE " - , escape table - , " ADD CONSTRAINT " - , escape fkeyname - , " FOREIGN KEY(" - , T.intercalate "," $ map escape t2 - , ") REFERENCES " - , escape reftable - , "(" - , T.intercalate "," id2 - , ")" - ] -showAlter table (_, DropReference cname) = T.concat - [ "ALTER TABLE " - , escape table - , " DROP CONSTRAINT " - , escape cname - ] - --- | Get the SQL string for the table that a PeristEntity represents. --- Useful for raw SQL queries. -tableName :: (PersistEntity record) => record -> Text -tableName = escape . tableDBName - --- | Get the SQL string for the field that an EntityField represents. --- Useful for raw SQL queries. -fieldName :: (PersistEntity record) => EntityField record typ -> Text -fieldName = escape . fieldDBName - -escape :: DBName -> Text -escape (DBName 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. - , pgPoolSize :: Int - -- ^ How many connections should be held in the connection pool. - } deriving (Show, Read, Data, Typeable) - -instance FromJSON PostgresConf where - parseJSON v = modifyFailure ("Persistent: error loading PostgreSQL conf: " ++) $ - flip (withObject "PostgresConf") v $ \o -> do - database <- o .: "database" - host <- o .: "host" - port <- o .:? "port" .!= 5432 - user <- o .: "user" - password <- o .: "password" - pool <- o .: "poolsize" - 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 pool -instance PersistConfig PostgresConf where - type PersistConfigBackend PostgresConf = SqlPersistT - type PersistConfigPool PostgresConf = ConnectionPool - createPoolConfig (PostgresConf cs size) = runNoLoggingT $ createPostgresqlPool cs size -- FIXME - 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" - -udToPair :: UniqueDef -> (DBName, [DBName]) -udToPair ud = (uniqueDBName ud, map snd $ 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 = entityDB 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) = mkColumns 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 (\c@Column { cName=cname, cReference=Just (refTblName, _) } -> - getAddReference allDefs name refTblName cname (cReference c)) - $ filter (isJust . cReference) newcols - foreignsAlt = flip map fdefs (\fdef -> - let (childfields, parentfields) = unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) - in AlterColumn name (foreignRefTableDBName fdef, AddReference (foreignConstraintNameDBName fdef) childfields (map escape parentfields))) - --- | 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 $ Map.empty - let sqlbackend = SqlBackend { connPrepare = \_ -> do - return Statement - { stmtFinalize = return () - , stmtReset = return () - , stmtExecute = undefined - , stmtQuery = \_ -> return $ return () - }, - connInsertManySql = Nothing, - connInsertSql = undefined, - connUpsertSql = Nothing, - connPutManySql = Nothing, - connStmtMap = smap, - connClose = undefined, - connMigrateSql = mockMigrate, - connBegin = undefined, - connCommit = undefined, - connRollback = undefined, - connEscapeName = escape, - connNoLimit = undefined, - connRDBMS = undefined, - connLimitOffset = undefined, - connLogFunc = undefined, - connMaxParams = Nothing, - connRepsertManySql = Nothing - } - 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 = entityFields ent - conflictColumns = concatMap (map (escape . snd) . uniqueFields) (entityUniques ent) - -repsertManySql :: EntityDef -> Int -> Text -repsertManySql ent n = putManySql' conflictColumns fields ent n - where - fields = keyAndEntityFields ent - conflictColumns = escape . fieldDB <$> entityKeyFields ent - -putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text -putManySql' conflictColumns fields ent n = q - where - fieldDbToText = escape . fieldDB - mkAssignment f = T.concat [f, "=EXCLUDED.", f] - - table = escape . entityDB $ 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 (((), []), []) +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific' + +-- | A postgresql backend for persistent. +module Database.Persist.Postgresql + ( withPostgresqlPool + , withPostgresqlPoolWithVersion + , withPostgresqlConn + , withPostgresqlConnWithVersion + , withPostgresqlPoolWithConf + , createPostgresqlPool + , createPostgresqlPoolModified + , createPostgresqlPoolModifiedWithVersion + , createPostgresqlPoolWithConf + , module Database.Persist.Sql + , ConnectionString + , PostgresConf (..) + , PgInterval (..) + , openSimpleConn + , openSimpleConnWithVersion + , tableName + , fieldName + , mockMigration + , migrateEnableExtension + , PostgresConfHooks(..) + , defaultPostgresConfHooks + ) where + +import qualified Database.PostgreSQL.LibPQ as LibPQ + +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.Internal as PG +import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.ToField as PGTF +import qualified Database.PostgreSQL.Simple.Transaction as PG +import qualified Database.PostgreSQL.Simple.Types as PG +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS +import Database.PostgreSQL.Simple.Ok (Ok (..)) + +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 (MonadLogger, runNoLoggingT) +import Control.Monad.Trans.Reader (runReaderT) +import Control.Monad.Trans.Writer (WriterT(..), runWriterT) + +import qualified Blaze.ByteString.Builder.Char8 as BBB +import Data.Acquire (Acquire, mkAcquire, with) +import Data.Aeson +import Data.Aeson.Types (modifyFailure) +import qualified Data.Attoparsec.Text as AT +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 +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.IORef +import Data.List (find, sort, groupBy, foldl') +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List as List +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map as Map +import Data.Maybe +import Data.Monoid ((<>)) +import Data.Pool (Pool) +import Data.String.Conversions.Monomorphic (toStrictByteString) +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 Data.Time (utc, NominalDiffTime, localTimeToUTC) +import System.Environment (getEnvironment) + +import Database.Persist.Sql +import qualified Database.Persist.Sql.Util as Util + +-- | 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 :: (MonadLogger 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, MonadLogger 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 ci + +-- | Same as 'withPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. +-- +-- @since 2.11.0.0 +withPostgresqlPoolWithConf :: (MonadUnliftIO m, MonadLogger 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 (pgConnStr conf) + withSqlPoolWithConfig logFuncToBackend (postgresConfToConnectionPoolConfig conf) + +-- | 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, MonadLogger 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, MonadLogger 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, MonadLogger 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 getVerDouble modConn ci = do + let getVer = oldGetVersionToNew getVerDouble + createSqlPool $ open' modConn getVer ci + +-- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. +-- +-- @since 2.11.0.0 +createPostgresqlPoolWithConf + :: (MonadUnliftIO m, MonadLogger 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 (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, MonadLogger 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, MonadLogger m) + => (PG.Connection -> IO (Maybe Double)) + -> ConnectionString + -> (SqlBackend -> m a) + -> m a +withPostgresqlConnWithVersion getVerDouble = do + let getVer = oldGetVersionToNew getVerDouble + withSqlConn . open' (const $ return ()) getVer + +open' + :: (PG.Connection -> IO ()) + -> (PG.Connection -> IO (NonEmpty Word)) + -> ConnectionString -> LogFunc -> IO SqlBackend +open' modConn getVer cstr logFunc = do + conn <- PG.connectPostgreSQL cstr + modConn conn + ver <- getVer conn + smap <- newIORef $ Map.empty + return $ createBackend logFunc ver smap conn + +-- | Gets the PostgreSQL server version +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 $ Map.empty + serverVersion <- oldGetVersionToNew getVerDouble conn + return $ createBackend logFunc serverVersion smap conn + +-- | Create the backend given a logging function, server version, mutable statement cell, +-- and connection. +createBackend :: LogFunc -> NonEmpty Word + -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend +createBackend logFunc serverVersion smap conn = do + SqlBackend + { connPrepare = prepare' conn + , connStmtMap = smap + , connInsertSql = insertSql' + , connInsertManySql = Just insertManySql' + , connUpsertSql = upsertFunction upsertSql' serverVersion + , connPutManySql = upsertFunction putManySql serverVersion + , 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 + , connEscapeName = escape + , connNoLimit = "LIMIT ALL" + , connRDBMS = "postgresql" + , connLimitOffset = decorateSQLWithLimitOffset "LIMIT ALL" + , connLogFunc = logFunc + , connMaxParams = Nothing + , connRepsertManySql = upsertFunction repsertManySql serverVersion + } + +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 entityPrimary ent of + Just _pdef -> ISRManyKeys sql vals + Nothing -> ISRSingle (sql <> " RETURNING " <> escape (fieldDB (entityId ent))) + where + (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escape) + sql = T.concat + [ "INSERT INTO " + , escape $ entityDB ent + , if null (entityFields ent) + then " DEFAULT VALUES" + else T.concat + [ "(" + , T.intercalate "," fieldNames + , ") VALUES(" + , T.intercalate "," placeholders + , ")" + ] + ] + + +upsertSql' :: EntityDef -> NonEmpty (HaskellName, DBName) -> Text -> Text +upsertSql' ent uniqs updateVal = + T.concat + [ "INSERT INTO " + , escape (entityDB ent) + , "(" + , T.intercalate "," fieldNames + , ") VALUES (" + , T.intercalate "," placeholders + , ") ON CONFLICT (" + , T.intercalate "," $ map (escape . snd) (NEL.toList uniqs) + , ") DO UPDATE SET " + , updateVal + , " WHERE " + , wher + , " RETURNING ??" + ] + where + (fieldNames, placeholders) = unzip (Util.mkInsertPlaceholders ent escape) + + wher = T.intercalate " AND " $ map (singleClause . snd) $ NEL.toList uniqs + + singleClause :: DBName -> Text + singleClause field = escape (entityDB ent) <> "." <> (escape field) <> " =?" + +-- | SQL for inserting multiple rows at once and returning their primary keys. +insertManySql' :: EntityDef -> [[PersistValue]] -> InsertSqlResult +insertManySql' ent valss = + ISRSingle sql + where + (fieldNames, placeholders)= unzip (Util.mkInsertPlaceholders ent escape) + sql = T.concat + [ "INSERT INTO " + , escape (entityDB ent) + , "(" + , T.intercalate "," fieldNames + , ") VALUES (" + , T.intercalate "),(" $ replicate (length valss) $ T.intercalate "," placeholders + , ") RETURNING " + , Util.commaSeparated $ Util.dbIdColumnsEsc escape 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 conn 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 + +-- | Avoid orphan instances. +newtype P = P 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 (PersistDbSpecific s)) = PGTF.toField (Unknown s) + toField (P (PersistLiteral l)) = PGTF.toField (UnknownLiteral l) + toField (P (PersistLiteralEscaped 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" + +-- | 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 (PersistDbSpecific bs) = fromPersistValue (PersistLiteralEscaped bs) + fromPersistValue x@(PersistLiteralEscaped 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" + +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 PersistText) + , (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 PersistText) + , (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 + +getGetter :: PG.Connection -> PG.Oid -> Getter PersistValue +getGetter _conn oid + = fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters + where defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) + +unBinary :: PG.Binary a -> a +unBinary (PG.Binary x) = x + +doesTableExist :: (Text -> IO Statement) + -> DBName -- ^ table name + -> IO Bool +doesTableExist getter (DBName 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] [(Bool, Text)]) +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 = entityDB 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 = do + pure $ AlterColumn + tableName_ + ( foreignRefTableDBName fdef + , addReference + ) + where + tableName_ = entityDB entity + addReference = + AddReference + constraintName + childfields + escapedParentFields + (foreignFieldCascade fdef) + constraintName = + foreignConstraintNameDBName fdef + (childfields, parentfields) = + unzip (map (\((_,b),(_,d)) -> (b,d)) (foreignFields fdef)) + escapedParentFields = + map escape parentfields + +addTable :: [Column] -> EntityDef -> AlterDB +addTable cols entity = + AddTable $ T.concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! + , escape name + , "(" + , idtxt + , if null nonIdCols then "" else "," + , T.intercalate "," $ map showColumn nonIdCols + , ")" + ] + where + nonIdCols = + case entityPrimary entity of + Just _ -> + cols + _ -> + filter (\c -> cName c /= fieldDB (entityId entity) ) cols + + name = + entityDB entity + idtxt = + case entityPrimary entity of + Just pdef -> + T.concat + [ " PRIMARY KEY (" + , T.intercalate "," $ map (escape . fieldDB) $ compositeFields pdef + , ")" + ] + Nothing -> + let defText = defaultAttribute $ fieldAttrs $ entityId entity + sType = fieldSqlType $ entityId entity + in T.concat + [ escape $ fieldDB (entityId entity) + , 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 SqlType Text + | IsNull | NotNull | Add' Column | Drop SafeToRemove + | Default Text | NoDefault | Update' Text + | AddReference DBName [DBName] [Text] FieldCascade + | DropReference DBName + deriving Show + +type AlterColumn' = (DBName, AlterColumn) + +data AlterTable + = AddUniqueConstraint DBName [DBName] + | DropConstraint DBName + deriving Show + +data AlterDB = AddTable Text + | AlterColumn DBName AlterColumn' + | AlterTable DBName AlterTable + deriving Show + +-- | Returns all of the columns in the given table currently in the database. +getColumns :: (Text -> IO Statement) + -> EntityDef -> [Column] + -> IO [Either Text (Either Column (DBName, [DBName]))] +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 $ unDBName $ entityDB 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 + $ foldl' ref [] cols + where + ref rs c = + maybe rs (\r -> (unDBName $ 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 . (DBName . fst . head &&& map (DBName . snd))) + $ groupBy ((==) `on` fst) rows + processColumns = + CL.mapM $ \x'@((PersistText cname) : _) -> do + col <- liftIO $ getColumn getter (entityDB 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 -> DBName -> Bool +safeToRemove def (DBName colName) + = any (elem FieldAttrSafeToRemove . fieldAttrs) + $ filter ((== DBName colName) . fieldDB) + $ keyAndEntityFields def + +getAlters :: [EntityDef] + -> EntityDef + -> ([Column], [(DBName, [DBName])]) + -> ([Column], [(DBName, [DBName])]) + -> ([AlterColumn'], [AlterTable]) +getAlters defs def (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = + map (\x -> (cName x, Drop $ safeToRemove def $ cName x)) old + getAltersC (new:news) old = + let (alters, old') = findAlters defs def new old + in alters ++ getAltersC news old' + + getAltersU + :: [(DBName, [DBName])] + -> [(DBName, [DBName])] + -> [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 (DBName x) = "__manual_" `T.isPrefixOf` x + +getColumn + :: (Text -> IO Statement) + -> DBName + -> [PersistValue] + -> Maybe (DBName, DBName) + -> 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 = DBName 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 $ unDBName tableName' + , PersistText $ unDBName cname + , PersistText $ unDBName refName' + ] + ) + (\src -> runConduit $ src .| CL.consume) + case cntrs of + [] -> + return Nothing + [[PersistText table, PersistText constraint, PersistText updRule, PersistText delRule]] -> + return $ Just (DBName table, DBName constraint, updRule, delRule) + xs -> + error $ mconcat + [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " + , T.unpack (unDBName tableName') + , " and column: " + , T.unpack (unDBName 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: " + , unDBName 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: " + , unDBName 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 = + T.toCaseFold (showSqlType x) == 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 -> + ([(name, Add' col)], cols) + Just (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') -> + let refDrop Nothing = [] + refDrop (Just ColumnReference {crConstraintName=cname}) = + [(name, DropReference cname)] + + refAdd Nothing = [] + refAdd (Just colRef) = + case find ((== crTableName colRef) . entityDB) defs of + Just refdef + | entityDB edef /= crTableName colRef + && _oldName /= fieldDB (entityId edef) + -> + [ ( crTableName colRef + , AddReference + (crConstraintName colRef) + [name] + (Util.dbIdColumnsEsc escape refdef) + (crFieldCascade colRef) + ) + ] + Just _ -> [] + Nothing -> + error $ "could not find the entityDef for reftable[" + ++ show (crTableName colRef) ++ "]" + modRef = + if fmap crConstraintName ref == fmap crConstraintName ref' + then [] + else refDrop ref' ++ refAdd ref + modNull = case (isNull, isNull') of + (True, False) -> do + guard $ name /= fieldDB (entityId edef) + pure (name, IsNull) + (False, True) -> + let up = case def of + Nothing -> id + Just s -> (:) (name, Update' s) + in up [(name, NotNull)] + _ -> [] + 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" = + [(name, ChangeType sqltype $ T.concat + [ " USING " + , escape name + , " AT TIME ZONE 'UTC'" + ])] + | otherwise = [(name, ChangeType sqltype "")] + modDef = + if def == def' + || isJust (T.stripPrefix "nextval" =<< def') + then [] + else + case def of + Nothing -> [(name, NoDefault)] + Just s -> [(name, Default s)] + in + ( modRef ++ modDef ++ modNull ++ modType + , filter (\c -> cName c /= name) cols + ) + +-- | Get the references to be added to a table for the given column. +getAddReference + :: [EntityDef] + -> EntityDef + -> DBName + -> ColumnReference + -> Maybe AlterDB +getAddReference allDefs entity cname cr@ColumnReference {crTableName = s, crConstraintName=constraintName} = do + guard $ table /= s && cname /= fieldDB (entityId entity) + pure $ AlterColumn + table + ( s + , AddReference constraintName [cname] id_ (crFieldCascade cr) + ) + where + table = entityDB entity + id_ = + fromMaybe + (error $ "Could not find ID of entity " ++ show s) + $ do + entDef <- find ((== s) . entityDB) allDefs + return $ Util.dbIdColumnsEsc escape entDef + +showColumn :: Column -> Text +showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = T.concat + [ escape 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 (c, ac)) = + (isUnsafe ac, showAlter t (c, ac)) + where + isUnsafe (Drop safeRemove) = not safeRemove + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, showAlterTable t at) + +showAlterTable :: DBName -> AlterTable -> Text +showAlterTable table (AddUniqueConstraint cname cols) = T.concat + [ "ALTER TABLE " + , escape table + , " ADD CONSTRAINT " + , escape cname + , " UNIQUE(" + , T.intercalate "," $ map escape cols + , ")" + ] +showAlterTable table (DropConstraint cname) = T.concat + [ "ALTER TABLE " + , escape table + , " DROP CONSTRAINT " + , escape cname + ] + +showAlter :: DBName -> AlterColumn' -> Text +showAlter table (n, ChangeType t extra) = + T.concat + [ "ALTER TABLE " + , escape table + , " ALTER COLUMN " + , escape n + , " TYPE " + , showSqlType t + , extra + ] +showAlter table (n, IsNull) = + T.concat + [ "ALTER TABLE " + , escape table + , " ALTER COLUMN " + , escape n + , " DROP NOT NULL" + ] +showAlter table (n, NotNull) = + T.concat + [ "ALTER TABLE " + , escape table + , " ALTER COLUMN " + , escape n + , " SET NOT NULL" + ] +showAlter table (_, Add' col) = + T.concat + [ "ALTER TABLE " + , escape table + , " ADD COLUMN " + , showColumn col + ] +showAlter table (n, Drop _) = + T.concat + [ "ALTER TABLE " + , escape table + , " DROP COLUMN " + , escape n + ] +showAlter table (n, Default s) = + T.concat + [ "ALTER TABLE " + , escape table + , " ALTER COLUMN " + , escape n + , " SET DEFAULT " + , s + ] +showAlter table (n, NoDefault) = T.concat + [ "ALTER TABLE " + , escape table + , " ALTER COLUMN " + , escape n + , " DROP DEFAULT" + ] +showAlter table (n, Update' s) = T.concat + [ "UPDATE " + , escape table + , " SET " + , escape n + , "=" + , s + , " WHERE " + , escape n + , " IS NULL" + ] +showAlter table (reftable, AddReference fkeyname t2 id2 cascade) = T.concat + [ "ALTER TABLE " + , escape table + , " ADD CONSTRAINT " + , escape fkeyname + , " FOREIGN KEY(" + , T.intercalate "," $ map escape t2 + , ") REFERENCES " + , escape reftable + , "(" + , T.intercalate "," id2 + , ")" + ] <> renderFieldCascade cascade +showAlter table (_, DropReference cname) = T.concat + [ "ALTER TABLE " + , escape table + , " DROP CONSTRAINT " + , escape cname + ] + +-- | Get the SQL string for the table that a PeristEntity represents. +-- Useful for raw SQL queries. +tableName :: (PersistEntity record) => record -> Text +tableName = escape . tableDBName + +-- | Get the SQL string for the field that an EntityField represents. +-- Useful for raw SQL queries. +fieldName :: (PersistEntity record) => EntityField record typ -> Text +fieldName = escape . fieldDBName + +escape :: DBName -> Text +escape (DBName 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 :: DBName -> DBName -> DBName +refName (DBName table) (DBName column) = + let overhead = T.length $ T.concat ["_", "_fkey"] + (fromTable, fromColumn) = shortenNames overhead (T.length table, T.length column) + in DBName $ T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"] + + 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 -> (DBName, [DBName]) +udToPair ud = (uniqueDBName ud, map snd $ 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 = entityDB 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 $ Map.empty + let sqlbackend = SqlBackend { connPrepare = \_ -> do + return Statement + { stmtFinalize = return () + , stmtReset = return () + , stmtExecute = undefined + , stmtQuery = \_ -> return $ return () + }, + connInsertManySql = Nothing, + connInsertSql = undefined, + connUpsertSql = Nothing, + connPutManySql = Nothing, + connStmtMap = smap, + connClose = undefined, + connMigrateSql = mockMigrate, + connBegin = undefined, + connCommit = undefined, + connRollback = undefined, + connEscapeName = escape, + connNoLimit = undefined, + connRDBMS = undefined, + connLimitOffset = undefined, + connLogFunc = undefined, + connMaxParams = Nothing, + connRepsertManySql = Nothing + } + 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 = entityFields ent + conflictColumns = concatMap (map (escape . snd) . uniqueFields) (entityUniques ent) + +repsertManySql :: EntityDef -> Int -> Text +repsertManySql ent n = putManySql' conflictColumns fields ent n + where + fields = keyAndEntityFields ent + conflictColumns = escape . fieldDB <$> entityKeyFields ent + +putManySql' :: [Text] -> [FieldDef] -> EntityDef -> Int -> Text +putManySql' conflictColumns (filter isFieldNotGenerated -> fields) ent n = q + where + fieldDbToText = escape . fieldDB + mkAssignment f = T.concat [f, "=EXCLUDED.", f] + + table = escape . entityDB $ 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 (emptyBackendSpecificOverrides + { backendSpecificForeignKeyName = Just refName + } + ) diff --git a/Database/Persist/Postgresql/JSON.hs b/Database/Persist/Postgresql/JSON.hs --- a/Database/Persist/Postgresql/JSON.hs +++ b/Database/Persist/Postgresql/JSON.hs @@ -333,7 +333,7 @@ -- but needs testing/profiling before changing it. -- (When entering into the DB the type isn't as important as fromPersistValue) toPersistValueJsonB :: ToJSON a => a -> PersistValue -toPersistValueJsonB = PersistDbSpecific . BSL.toStrict . encode +toPersistValueJsonB = PersistLiteralEscaped . BSL.toStrict . encode fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a fromPersistValueJsonB (PersistText t) = diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.10.1.2 +version: 2.11.0.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -16,17 +16,20 @@ library build-depends: base >= 4.9 && < 5 - , persistent >= 2.10 && < 3 + , persistent >= 2.11 && < 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.7 , postgresql-libpq >= 0.9.4.2 && < 0.10 , resourcet >= 1.1.9 , resource-pool + , string-conversions , text >= 1.2 , time >= 1.6 , transformers >= 0.5 @@ -49,6 +52,7 @@ EquivalentTypeTestPostgres JSONTest CustomConstraintTest + PgIntervalTest ghc-options: -Wall build-depends: base >= 4.9 && < 5 diff --git a/test/ArrayAggTest.hs b/test/ArrayAggTest.hs --- a/test/ArrayAggTest.hs +++ b/test/ArrayAggTest.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds, FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -33,11 +33,11 @@ emptyArr :: Value emptyArr = toJSON ([] :: [Value]) -specs :: RunDb SqlBackend IO -> Spec -specs runDb = do +specs :: Spec +specs = do describe "rawSql/array_agg" $ do let runArrayAggTest :: (PersistField [a], Ord a, Show a) => Text -> [a] -> Assertion - runArrayAggTest dbField expected = runDb $ do + runArrayAggTest dbField expected = runConnAssert $ do void $ insertMany [ UserPT "a" $ Just "b" , UserPT "c" $ Just "d" diff --git a/test/CustomConstraintTest.hs b/test/CustomConstraintTest.hs --- a/test/CustomConstraintTest.hs +++ b/test/CustomConstraintTest.hs @@ -1,6 +1,6 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE GADTs, DataKinds, FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -31,12 +31,12 @@ deriving Show |] -specs :: (MonadIO m, MonadFail m) => RunDb SqlBackend m -> Spec -specs runDb = do +specs :: Spec +specs = do describe "custom constraint used in migration" $ do - it "custom constraint is actually created" $ runDb $ do - runMigration customConstraintMigrate - runMigration customConstraintMigrate -- run a second time to ensure the constraint isn't dropped + it "custom constraint is actually created" $ runConnAssert $ do + void $ runMigrationSilent customConstraintMigrate + void $ runMigrationSilent customConstraintMigrate -- run a second time to ensure the constraint isn't dropped let query = T.concat ["SELECT DISTINCT COUNT(*) " ,"FROM information_schema.constraint_column_usage ccu, " ,"information_schema.key_column_usage kcu, " @@ -50,17 +50,17 @@ ,"AND kcu.table_name=? " ,"AND kcu.column_name=? " ,"AND tc.constraint_name=?"] - [Single exists] <- rawSql query [PersistText "custom_constraint1" + [Single exists_] <- rawSql query [PersistText "custom_constraint1" ,PersistText "id" ,PersistText "custom_constraint2" ,PersistText "cc_id" ,PersistText "custom_constraint"] - liftIO $ 1 @?= (exists :: Int) + liftIO $ 1 @?= (exists_ :: Int) - it "allows multiple constraints on a single column" $ runDb $ do - runMigration customConstraintMigrate + it "allows multiple constraints on a single column" $ runConnAssert $ do + void $ runMigrationSilent customConstraintMigrate -- | Here we add another foreign key on the same column where the default one already exists. In practice, this could be a compound key with another field. rawExecute "ALTER TABLE \"custom_constraint3\" ADD CONSTRAINT \"extra_constraint\" FOREIGN KEY(\"cc_id1\") REFERENCES \"custom_constraint1\"(\"id\")" [] -- | This is where the error is thrown in `getColumn` - _ <- getMigration customConstraintMigrate + void $ getMigration customConstraintMigrate pure () diff --git a/test/EquivalentTypeTestPostgres.hs b/test/EquivalentTypeTestPostgres.hs --- a/test/EquivalentTypeTestPostgres.hs +++ b/test/EquivalentTypeTestPostgres.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} diff --git a/test/JSONTest.hs b/test/JSONTest.hs --- a/test/JSONTest.hs +++ b/test/JSONTest.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} +{-# language DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -6,9 +7,10 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -- FIXME +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} module JSONTest where @@ -24,13 +26,15 @@ import PgInit + share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase| TestValue json Value deriving Show |] -cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) => ReaderT backend m () +cleanDB :: (BaseBackend backend ~ SqlBackend, PersistQueryWrite backend, MonadIO m) + => ReaderT backend m () cleanDB = deleteWhere ([] :: [Filter TestValue]) emptyArr :: Value @@ -40,431 +44,637 @@ => Value -> ReaderT backend m (Key TestValue) insert' = insert . TestValue -(=@=) :: MonadIO m => String -> Bool -> m () -s =@= b = liftIO $ assertBool s b matchKeys :: (Show record, Show (Key record), MonadIO m, Eq (Key record)) - => String -> [Key record] -> [Entity record] -> m () -matchKeys s ys xs = do - msg1 =@= (xLen == yLen) - forM_ ys $ \y -> msg2 y =@= (y `elem` ks) - where ks = entityKey <$> xs - xLen = length xs - yLen = length ys - msg1 = mconcat - [ s, "\nexpected: ", show yLen - , "\n but got: ", show xLen - , "\n[xs: ", show xs - , ", ys: ", show ys, "]" - ] - msg2 y = mconcat - [ s, ": " - , "key \"", show y - , "\" not in result:\n ", show ks - ] + => [Key record] -> [Entity record] -> m () +matchKeys ys xs = do + msg1 `assertBoolIO` (xLen == yLen) + forM_ ys $ \y -> msg2 y `assertBoolIO` (y `elem` ks) + where ks = entityKey <$> xs + xLen = length xs + yLen = length ys + msg1 = mconcat + [ "\nexpected: ", show yLen + , "\n but got: ", show xLen + , "\n[xs: ", show xs, "]" + , "\n[ys: ", show ys, "]" + ] + msg2 y = mconcat + [ "key \"", show y + , "\" not in result:\n ", show ks + ] -specs :: Spec -specs = describe "postgresql's JSON operators behave" $ do +setup :: IO TestKeys +setup = asIO $ runConn_ $ do + void $ runMigrationSilent jsonTestMigrate + testKeys - it "migrate, clean table, insert values and check queries" $ asIO $ runConn $ do - runMigration jsonTestMigrate - cleanDB +teardown :: IO () +teardown = asIO $ runConn_ $ do + cleanDB - liftIO $ putStrLn "\n- - - - - Inserting JSON values - - - - -\n" +shouldBeIO :: (Show a, Eq a, MonadIO m) => a -> a -> m () +shouldBeIO x y = liftIO $ shouldBe x y - nullK <- insert' Null +assertBoolIO :: MonadIO m => String -> Bool -> m () +assertBoolIO s b = liftIO $ assertBool s b - boolTK <- insert' $ Bool True - boolFK <- insert' $ toJSON False +testKeys :: (Monad m, MonadIO m) => ReaderT SqlBackend m TestKeys +testKeys = do + nullK <- insert' Null - num0K <- insert' $ Number 0 - num1K <- insert' $ Number 1 - numBigK <- insert' $ toJSON (1234567890 :: Int) - numFloatK <- insert' $ Number 0.0 - numSmallK <- insert' $ Number 0.0000000000000000123 - numFloat2K <- insert' $ Number 1.5 - -- numBigFloatK will turn into 9876543210.123457 because JSON - numBigFloatK <- insert' $ toJSON (9876543210.123456789 :: Double) + boolTK <- insert' $ Bool True + boolFK <- insert' $ toJSON False - strNullK <- insert' $ String "" - strObjK <- insert' $ String "{}" - strArrK <- insert' $ String "[]" - strAK <- insert' $ String "a" - strTestK <- insert' $ toJSON ("testing" :: Text) - str2K <- insert' $ String "2" - strFloatK <- insert' $ String "0.45876" + num0K <- insert' $ Number 0 + num1K <- insert' $ Number 1 + numBigK <- insert' $ toJSON (1234567890 :: Int) + numFloatK <- insert' $ Number 0.0 + numSmallK <- insert' $ Number 0.0000000000000000123 + numFloat2K <- insert' $ Number 1.5 + -- numBigFloatK will turn into 9876543210.123457 because JSON + numBigFloatK <- insert' $ toJSON (9876543210.123456789 :: Double) - arrNullK <- insert' $ Array $ V.fromList [] - arrListK <- insert' $ toJSON ([emptyArr,emptyArr,toJSON [emptyArr,emptyArr]]) - arrList2K <- insert' $ toJSON [emptyArr,toJSON [Number 3,Bool False],toJSON [emptyArr,toJSON [Object mempty]]] - arrFilledK <- insert' $ toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"]] + strNullK <- insert' $ String "" + strObjK <- insert' $ String "{}" + strArrK <- insert' $ String "[]" + strAK <- insert' $ String "a" + strTestK <- insert' $ toJSON ("testing" :: Text) + str2K <- insert' $ String "2" + strFloatK <- insert' $ String "0.45876" - objNullK <- insert' $ Object mempty - objTestK <- insert' $ object ["test" .= Null, "test1" .= String "no"] - objDeepK <- insert' $ object ["c" .= Number 24.986, "foo" .= object ["deep1" .= Bool True]] + arrNullK <- insert' $ Array $ V.fromList [] + arrListK <- insert' $ toJSON [emptyArr,emptyArr,toJSON [emptyArr,emptyArr]] + arrList2K <- insert' $ toJSON [emptyArr,toJSON [Number 3,Bool False] + ,toJSON [emptyArr,toJSON [Object mempty]] + ] + arrFilledK <- insert' $ toJSON [Null, Number 4, String "b" + ,Object mempty, emptyArr + ,object [ "test" .= [Null], "test2" .= String "yes"] + ] + arrList3K <- insert' $ toJSON [toJSON [String "a"], Number 1] + arrList4K <- insert' $ toJSON [String "a", String "b", String "c", String "d"] ----------------------------------------------------------------------------------------- + objNullK <- insert' $ Object mempty + objTestK <- insert' $ object ["test" .= Null, "test1" .= String "no"] + objDeepK <- insert' $ object ["c" .= Number 24.986, "foo" .= object ["deep1" .= Bool True]] + objEmptyK <- insert' $ object ["" .= Number 9001] + objFullK <- insert' $ object ["a" .= Number 1, "b" .= Number 2 + ,"c" .= Number 3, "d" .= Number 4 + ] + return TestKeys{..} - liftIO $ putStrLn "\n- - - - - Starting @> tests - - - - -\n" +data TestKeys = + TestKeys { nullK :: Key TestValue + , boolTK :: Key TestValue + , boolFK :: Key TestValue + , num0K :: Key TestValue + , num1K :: Key TestValue + , numBigK :: Key TestValue + , numFloatK :: Key TestValue + , numSmallK :: Key TestValue + , numFloat2K :: Key TestValue + , numBigFloatK :: Key TestValue + , strNullK :: Key TestValue + , strObjK :: Key TestValue + , strArrK :: Key TestValue + , strAK :: Key TestValue + , strTestK :: Key TestValue + , str2K :: Key TestValue + , strFloatK :: Key TestValue + , arrNullK :: Key TestValue + , arrListK :: Key TestValue + , arrList2K :: Key TestValue + , arrFilledK :: Key TestValue + , objNullK :: Key TestValue + , objTestK :: Key TestValue + , objDeepK :: Key TestValue + , arrList3K :: Key TestValue + , arrList4K :: Key TestValue + , objEmptyK :: Key TestValue + , objFullK :: Key TestValue + } deriving (Eq, Ord, Show) - -- An empty Object matches any object - selectList [TestValueJson @>. Object mempty] [] - >>= matchKeys "1" [objNullK,objTestK,objDeepK] +specs :: Spec +specs = afterAll_ teardown $ do + beforeAll setup $ do + describe "Testing JSON operators" $ do + describe "@>. object queries" $ do + it "matches an empty Object with any object" $ + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. Object mempty] [] + [objNullK, objTestK, objDeepK, objEmptyK, objFullK] `matchKeys` vals - -- {"test":null,"test1":"no"} @> {"test":null} == True - selectList [TestValueJson @>. object ["test" .= Null]] [] - >>= matchKeys "2" [objTestK] + it "matches a subset of object properties" $ + -- {test: null, test1: no} @>. {test: null} == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. object ["test" .= Null]] [] + [objTestK] `matchKeys` vals - -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":{}} == True - selectList [TestValueJson @>. object ["foo" .= object []]] [] - >>= matchKeys "3" [objDeepK] + it "matches a nested object against an empty object at the same key" $ + -- {c: 24.986, foo: {deep1: true}} @>. {foo: {}} == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. object ["foo" .= object []]] [] + [objDeepK] `matchKeys` vals - -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":"nope"} == False - selectList [TestValueJson @>. object ["foo" .= String "nope"]] [] - >>= matchKeys "4" [] + it "doesn't match a nested object against a string at the same key" $ + -- {c: 24.986, foo: {deep1: true}} @>. {foo: nope} == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. object ["foo" .= String "nope"]] [] + [] `matchKeys` vals - -- {"c":24.986,"foo":{"deep1":true"}} @> {"foo":{"deep1":true}} == True - selectList [TestValueJson @>. (object ["foo" .= object ["deep1" .= True]])] [] - >>= matchKeys "5" [objDeepK] + it "matches a nested object when the query object is identical" $ + -- {c: 24.986, foo: {deep1: true}} @>. {foo: {deep1: true}} == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. (object ["foo" .= object ["deep1" .= True]])] [] + [objDeepK] `matchKeys` vals - -- {"c":24.986,"foo":{"deep1":true"}} @> {"deep1":true} == False - selectList [TestValueJson @>. object ["deep1" .= True]] [] - >>= matchKeys "6" [] + it "doesn't match a nested object when queried with that exact object" $ + -- {c: 24.986, foo: {deep1: true}} @>. {deep1: true} == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. object ["deep1" .= True]] [] + [] `matchKeys` vals - -- An empty Array matches any array - selectList [TestValueJson @>. emptyArr] [] - >>= matchKeys "7" [arrNullK,arrListK,arrList2K,arrFilledK] + describe "@>. array queries" $ do + it "matches an empty Array with any list" $ + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. emptyArr] [] + [arrNullK, arrListK, arrList2K, arrFilledK, arrList3K, arrList4K] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [4] == True - selectList [TestValueJson @>. toJSON [4 :: Int]] [] - >>= matchKeys "8" [arrFilledK] + it "matches list when queried with subset (1 item)" $ + -- [null, 4, 'b', {}, [], {test: [null], test2: 'yes'}] @>. [4] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [4 :: Int]] [] + [arrFilledK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,"b"] == True - selectList [TestValueJson @>. toJSON [Null, String "b"]] [] - >>= matchKeys "9" [arrFilledK] + it "matches list when queried with subset (2 items)" $ + -- [null, 4, 'b', {}, [], {test: [null], test2: 'yes'}] @>. [null,'b'] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [Null, String "b"]] [] + [arrFilledK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,"d"] == False - selectList [TestValueJson @>. toJSON [emptyArr, String "d"]] [] - >>= matchKeys "10" [] + it "doesn't match list when queried with intersecting list (1 match, 1 diff)" $ + -- [null, 4, 'b', {}, [], {test: [null], test2: 'yes'}] @>. [null,'d'] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [emptyArr, String "d"]] [] + [] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [[],"b",{"test":[null],"test2":"yes"},4,null,{}] == True - selectList [TestValueJson @>. toJSON [emptyArr, String "b", object [ "test" .= [Null], "test2" .= String "yes"], Number 4, Null, Object mempty]] [] - >>= matchKeys "11" [arrFilledK] + it "matches list when queried with same list in different order" $ + -- [null, 4, 'b', {}, [], {test: [null], test2: 'yes'}] @>. + -- [[],'b',{test: [null],test2: 'yes'},4,null,{}] == True + \TestKeys {..} -> runConnAssert $ do + let queryList = + toJSON [ emptyArr, String "b" + , object [ "test" .= [Null], "test2" .= String "yes"] + , Number 4, Null, Object mempty ] - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == False - selectList [TestValueJson @>. toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"], Bool False]] [] - >>= matchKeys "12" [] + vals <- selectList [TestValueJson @>. queryList ] [] + [arrFilledK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{}] == True - selectList [TestValueJson @>. toJSON [Object mempty]] [] - >>= matchKeys "13" [arrFilledK] + it "doesn't match list when queried with same list + 1 item" $ + -- [null,4,'b',{},[],{test:[null],test2:'yes'}] @>. + -- [null,4,'b',{},[],{test:[null],test2: 'yes'}, false] == False + \TestKeys {..} -> runConnAssert $ do + let testList = + toJSON [ Null, Number 4, String "b", Object mempty, emptyArr + , object [ "test" .= [Null], "test2" .= String "yes"] + , Bool False ] - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{"test":[]}] == True - selectList [TestValueJson @>. toJSON [object ["test" .= emptyArr]]] [] - >>= matchKeys "14" [arrFilledK] + vals <- selectList [TestValueJson @>. testList] [] + [] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [{"test1":[null]}] == False - selectList [TestValueJson @>. toJSON [object ["test1" .= [Null]]]] [] - >>= matchKeys "15" [] + it "matches list when it shares an empty object with the query list" $ + -- [null,4,'b',{},[],{test: [null],test2: 'yes'}] @>. [{}] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [Object mempty]] [] + [arrFilledK] `matchKeys` vals - -- [[],[],[[],[]]] @> [[]] == True - -- [[],[3,false],[[],[{}]]] @> [[]] == True - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> [[]] == True - selectList [TestValueJson @>. toJSON [emptyArr]] [] - >>= matchKeys "16" [arrListK,arrList2K,arrFilledK] + it "matches list with nested list, when queried with an empty nested list" $ + -- [null,4,'b',{},[],{test:[null],test2:'yes'}] @>. [{test:[]}] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [object ["test" .= emptyArr]]] [] + [arrFilledK] `matchKeys` vals - -- [[],[3,false],[[],[{}]]] @> [[3]] == True - selectList [TestValueJson @>. toJSON [[3 :: Int]]] [] - >>= matchKeys "17" [arrList2K] + it "doesn't match list with nested list, when queried with a diff. nested list" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. + -- [{"test1":[null]}] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [object ["test1" .= [Null]]]] [] + [] `matchKeys` vals - -- [[],[3,false],[[],[{}]]] @> [[true,3]] == False - selectList [TestValueJson @>. toJSON [[Bool True, Number 3]]] [] - >>= matchKeys "18" [] + it "matches many nested lists when queried with empty nested list" $ + -- [[],[],[[],[]]] @>. [[]] == True + -- [[],[3,false],[[],[{}]]] @>. [[]] == True + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. [[]] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [emptyArr]] [] + [arrListK,arrList2K,arrFilledK, arrList3K] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> 4 == True - selectList [TestValueJson @>. Number 4] [] - >>= matchKeys "19" [arrFilledK] + it "matches nested list when queried with a subset of that list" $ + -- [[],[3,false],[[],[{}]]] @>. [[3]] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [[3 :: Int]]] [] + [arrList2K] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> 4 == True - selectList [TestValueJson @>. Number 99] [] - >>= matchKeys "20" [] + it "doesn't match nested list againts a partial intersection of that list" $ + -- [[],[3,false],[[],[{}]]] @>. [[true,3]] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON [[Bool True, Number 3]]] [] + [] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> "b" == True - selectList [TestValueJson @>. String "b"] [] - >>= matchKeys "21" [arrFilledK] + it "matches list when queried with raw number contained in the list" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. 4 == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. Number 4] [] + [arrFilledK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> "{}" == False - selectList [TestValueJson @>. String "{}"] [] - >>= matchKeys "22" [strObjK] + it "doesn't match list when queried with raw value not contained in the list" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. 99 == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. Number 99] [] + [] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @> {"test":[null],"test2":"yes"} == False - selectList [TestValueJson @>. object [ "test" .= [Null], "test2" .= String "yes"]] [] - >>= matchKeys "23" [] + it "matches list when queried with raw string contained in the list" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. "b" == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "b"] [] + [arrFilledK, arrList4K] `matchKeys` vals - -- "testing" @> "testing" == True - selectList [TestValueJson @>. String "testing"] [] - >>= matchKeys "24" [strTestK] + it "doesn't match list with empty object when queried with \"{}\" " $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. "{}" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "{}"] [] + [strObjK] `matchKeys` vals - -- "testing" @> "Testing" == False - selectList [TestValueJson @>. String "Testing"] [] - >>= matchKeys "25" [] + it "doesnt match list with nested object when queried with object (not in list)" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] @>. + -- {"test":[null],"test2":"yes"} == False + \TestKeys {..} -> runConnAssert $ do + let queryObject = object [ "test" .= [Null], "test2" .= String "yes"] + vals <- selectList [TestValueJson @>. queryObject ] [] + [] `matchKeys` vals - -- "testing" @> "test" == False - selectList [TestValueJson @>. String "test"] [] - >>= matchKeys "26" [] + describe "@>. string queries" $ do + it "matches identical strings" $ + -- "testing" @>. "testing" == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "testing"] [] + [strTestK] `matchKeys` vals - -- "testing" @> {"testing":1} == False - selectList [TestValueJson @>. object ["testing" .= Number 1]] [] - >>= matchKeys "27" [] + it "doesnt match case insensitive" $ + -- "testing" @>. "Testing" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "Testing"] [] + [] `matchKeys` vals - -- 1 @> 1 == True - selectList [TestValueJson @>. toJSON (1 :: Int)] [] - >>= matchKeys "28" [num1K] + it "doesn't match substrings" $ + -- "testing" @>. "test" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "test"] [] + [] `matchKeys` vals - -- 0 @> 0.0 == True - -- 0.0 @> 0.0 == True - selectList [TestValueJson @>. toJSON (0.0 :: Double)] [] - >>= matchKeys "29" [num0K,numFloatK] + it "doesn't match strings with object keys" $ + -- "testing" @>. {"testing":1} == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. object ["testing" .= Number 1]] [] + [] `matchKeys` vals - -- 1234567890 @> 123456789 == False - selectList [TestValueJson @>. toJSON (123456789 :: Int)] [] - >>= matchKeys "30" [] + describe "@>. number queries" $ do + it "matches identical numbers" $ + -- 1 @>. 1 == True + -- [1] @>. 1 == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON (1 :: Int)] [] + [num1K, arrList3K] `matchKeys` vals - -- 1234567890 @> 234567890 == False - selectList [TestValueJson @>. toJSON (234567890 :: Int)] [] - >>= matchKeys "31" [] + it "matches numbers when queried with float" $ + -- 0 @>. 0.0 == True + -- 0.0 @>. 0.0 == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON (0.0 :: Double)] [] + [num0K,numFloatK] `matchKeys` vals - -- 1 @> "1" == False - selectList [TestValueJson @>. String "1"] [] - >>= matchKeys "32" [] + it "does not match numbers when queried with a substring of that number" $ + -- 1234567890 @>. 123456789 == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON (123456789 :: Int)] [] + [] `matchKeys` vals - -- 1234567890 @> [1,2,3,4,5,6,7,8,9,0] == False - selectList [TestValueJson @>. toJSON ([1,2,3,4,5,6,7,8,9,0] :: [Int])] [] - >>= matchKeys "33" [] + it "does not match number when queried with different number" $ + -- 1234567890 @>. 234567890 == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON (234567890 :: Int)] [] + [] `matchKeys` vals - -- true @> true == True - -- false @> true == False - selectList [TestValueJson @>. toJSON True] [] - >>= matchKeys "34" [boolTK] + it "does not match number when queried with string of that number" $ + -- 1 @>. "1" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "1"] [] + [] `matchKeys` vals - -- false @> false == True - -- true @> false == False - selectList [TestValueJson @>. Bool False] [] - >>= matchKeys "35" [boolFK] + it "does not match number when queried with list of digits" $ + -- 1234567890 @>. [1,2,3,4,5,6,7,8,9,0] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON ([1,2,3,4,5,6,7,8,9,0] :: [Int])] [] + [] `matchKeys` vals - -- true @> "true" == False - selectList [TestValueJson @>. String "true"] [] - >>= matchKeys "36" [] + describe "@>. boolean queries" $ do + it "matches identical booleans (True)" $ + -- true @>. true == True + -- false @>. true == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON True] [] + [boolTK] `matchKeys` vals - -- null @> null == True - selectList [TestValueJson @>. Null] [] - >>= matchKeys "37" [nullK,arrFilledK] + it "matches identical booleans (False)" $ + -- false @>. false == True + -- true @>. false == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. Bool False] [] + [boolFK] `matchKeys` vals - -- null @> "null" == False - selectList [TestValueJson @>. String "null"] [] - >>= matchKeys "38" [] + it "does not match boolean with string of boolean" $ + -- true @>. "true" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "true"] [] + [] `matchKeys` vals ----------------------------------------------------------------------------------------- + describe "@>. null queries" $ do + it "matches nulls" $ + -- null @>. null == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. Null] [] + [nullK,arrFilledK] `matchKeys` vals - liftIO $ putStrLn "\n- - - - - Starting <@ tests - - - - -\n" + it "does not match null with string of null" $ + -- null @>. "null" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "null"] [] + [] `matchKeys` vals - -- {} <@ {"test":null,"test1":"no","blabla":[]} == True - -- {"test":null,"test1":"no"} <@ {"test":null,"test1":"no","blabla":[]} == True - selectList [TestValueJson <@. object ["test" .= Null, "test1" .= String "no", "blabla" .= emptyArr]] [] - >>= matchKeys "39" [objNullK,objTestK] - -- [] <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True - -- null <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True - -- false <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] <@ [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True - selectList [TestValueJson <@. toJSON [Null, Number 4, String "b", Object mempty, emptyArr, object [ "test" .= [Null], "test2" .= String "yes"], Bool False]] [] - >>= matchKeys "40" [arrNullK,arrFilledK,boolFK,nullK] + describe "<@. queries" $ do + it "matches subobject when queried with superobject" $ + -- {} <@. {"test":null,"test1":"no","blabla":[]} == True + -- {"test":null,"test1":"no"} <@. {"test":null,"test1":"no","blabla":[]} == True + \TestKeys {..} -> runConnAssert $ do + let queryObject = object ["test" .= Null + , "test1" .= String "no" + , "blabla" .= emptyArr + ] + vals <- selectList [TestValueJson <@. queryObject] [] + [objNullK,objTestK] `matchKeys` vals - -- "a" <@ "a" == True - selectList [TestValueJson <@. String "a"] [] - >>= matchKeys "41" [strAK] + it "matches raw values and sublists when queried with superlist" $ + -- [] <@. [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True + -- null <@. [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True + -- false <@. [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] <@. + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"},false] == True + \TestKeys {..} -> runConnAssert $ do + let queryList = + toJSON [ Null, Number 4, String "b", Object mempty, emptyArr + , object [ "test" .= [Null], "test2" .= String "yes"] + , Bool False ] + vals <- selectList [TestValueJson <@. queryList ] [] + [arrNullK,arrFilledK,boolFK,nullK] `matchKeys` vals - -- 9876543210.123457 <@ 9876543210.123457 == False - selectList [TestValueJson <@. Number 9876543210.123457] [] - >>= matchKeys "42" [numBigFloatK] + it "matches identical strings" $ + -- "a" <@. "a" == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson <@. String "a"] [] + [strAK] `matchKeys` vals - -- 9876543210.123457 <@ 9876543210.123456789 == False - selectList [TestValueJson <@. Number 9876543210.123456789] [] - >>= matchKeys "43" [] + it "matches identical big floats" $ + -- 9876543210.123457 <@ 9876543210.123457 == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson <@. Number 9876543210.123457] [] + [numBigFloatK] `matchKeys` vals - -- null <@ null == True - selectList [TestValueJson <@. Null] [] - >>= matchKeys "44" [nullK] + it "doesn't match different big floats" $ + -- 9876543210.123457 <@. 9876543210.123456789 == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson <@. Number 9876543210.123456789] [] + [] `matchKeys` vals ----------------------------------------------------------------------------------------- + it "matches nulls" $ + -- null <@. null == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson <@. Null] [] + [nullK] `matchKeys` vals - liftIO $ putStrLn "\n- - - - - Starting ? tests - - - - -\n" + describe "?. queries" $ do + it "matches top level keys and not the keys of nested objects" $ + -- {"test":null,"test1":"no"} ?. "test" == True + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?. "test" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "test"] [] + [objTestK] `matchKeys` vals - arrList3K <- insert' $ toJSON [toJSON [String "a"], Number 1] - arrList4K <- insert' $ toJSON [String "a", String "b", String "c", String "d"] - objEmptyK <- insert' $ object ["" .= Number 9001] - objFullK <- insert' $ object ["a" .= Number 1, "b" .= Number 2, "c" .= Number 3, "d" .= Number 4] + it "doesn't match nested key" $ + -- {"c":24.986,"foo":{"deep1":true"}} ?. "deep1" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "deep1"] [] + [] `matchKeys` vals - -- {"test":null,"test1":"no"} ? "test" == True - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ? "test" == False - selectList [TestValueJson ?. "test"] [] - >>= matchKeys "45" [objTestK] + it "matches \"{}\" but not empty object when queried with \"{}\"" $ + -- "{}" ?. "{}" == True + -- {} ?. "{}" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "{}"] [] + [strObjK] `matchKeys` vals - -- {"c":24.986,"foo":{"deep1":true"}} ? "deep1" == False - selectList [TestValueJson ?. "deep1"] [] - >>= matchKeys "46" [] + it "matches raw empty str and empty str key when queried with \"\"" $ + ---- {} ?. "" == False + ---- "" ?. "" == True + ---- {"":9001} ?. "" == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. ""] [] + [strNullK,objEmptyK] `matchKeys` vals - -- "{}" ? "{}" == True - -- {} ? "{}" == False - selectList [TestValueJson ?. "{}"] [] - >>= matchKeys "47" [strObjK] + it "matches lists containing string value when queried with raw string value" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?. "b" == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "b"] [] + [arrFilledK,arrList4K,objFullK] `matchKeys` vals - -- {} ? "" == False - -- "" ? "" == True - -- {"":9001} ? "" == True - selectList [TestValueJson ?. ""] [] - >>= matchKeys "48" [strNullK,objEmptyK] + it "matches lists, objects, and raw values correctly when queried with string" $ + -- [["a"]] ?. "a" == False + -- "a" ?. "a" == True + -- ["a","b","c","d"] ?. "a" == True + -- {"a":1,"b":2,"c":3,"d":4} ?. "a" == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "a"] [] + [strAK,arrList4K,objFullK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ? "b" == True - selectList [TestValueJson ?. "b"] [] - >>= matchKeys "49" [arrFilledK,arrList4K,objFullK] + it "matches string list but not real list when queried with \"[]\"" $ + -- "[]" ?. "[]" == True + -- [] ?. "[]" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "[]"] [] + [strArrK] `matchKeys` vals - -- [["a"]] ? "a" == False - -- "a" ? "a" == True - -- ["a","b","c","d"] ? "a" == True - -- {"a":1,"b":2,"c":3,"d":4} ? "a" == True - selectList [TestValueJson ?. "a"] [] - >>= matchKeys "50" [strAK,arrList4K,objFullK] + it "does not match null when queried with string null" $ + -- null ?. "null" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "null"] [] + [] `matchKeys` vals - -- "[]" ? "[]" == True - -- [] ? "[]" == False - selectList [TestValueJson ?. "[]"] [] - >>= matchKeys "51" [strArrK] + it "does not match bool whe nqueried with string bool" $ + -- true ?. "true" == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "true"] [] + [] `matchKeys` vals - -- null ? "null" == False - selectList [TestValueJson ?. "null"] [] - >>= matchKeys "52" [] - -- true ? "true" == False - selectList [TestValueJson ?. "true"] [] - >>= matchKeys "53" [] - ----------------------------------------------------------------------------------------- - - liftIO $ putStrLn "\n- - - - - Starting ?| tests - - - - -\n" - - -- "a" ?| ["a","b","c"] == True - -- [["a"],1] ?| ["a","b","c"] == False - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?| ["a","b","c"] == True - -- ["a","b","c","d"] ?| ["a","b","c"] == True - -- {"a":1,"b":2,"c":3,"d":4} ?| ["a","b","c"] == True - selectList [TestValueJson ?|. ["a","b","c"]] [] - >>= matchKeys "54" [strAK,arrFilledK,objDeepK,arrList4K,objFullK] - - -- "{}" ?| ["{}"] == True - -- {} ?| ["{}"] == False - selectList [TestValueJson ?|. ["{}"]] [] - >>= matchKeys "55" [strObjK] - - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?| ["test"] == False - -- "testing" ?| ["test"] == False - -- {"test":null,"test1":"no"} ?| ["test"] == True - selectList [TestValueJson ?|. ["test"]] [] - >>= matchKeys "56" [objTestK] - - -- {"c":24.986,"foo":{"deep1":true"}} ?| ["deep1"] == False - selectList [TestValueJson ?|. ["deep1"]] [] - >>= matchKeys "57" [] + describe "?|. queries" $ do + it "matches raw vals, lists, objects, and nested objects" $ + -- "a" ?|. ["a","b","c"] == True + -- [["a"],1] ?|. ["a","b","c"] == False + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?|. ["a","b","c"] == True + -- ["a","b","c","d"] ?|. ["a","b","c"] == True + -- {"a":1,"b":2,"c":3,"d":4} ?|. ["a","b","c"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["a","b","c"]] [] + [strAK,arrFilledK,objDeepK,arrList4K,objFullK] `matchKeys` vals - -- ANYTHING ?| [] == False - selectList [TestValueJson ?|. []] [] - >>= matchKeys "58" [] + it "matches str object but not object when queried with \"{}\"" $ + -- "{}" ?|. ["{}"] == True + -- {} ?|. ["{}"] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["{}"]] [] + [strObjK] `matchKeys` vals - -- true ?| ["true","null","1"] == False - -- null ?| ["true","null","1"] == False - -- 1 ?| ["true","null","1"] == False - selectList [TestValueJson ?|. ["true","null","1"]] [] - >>= matchKeys "59" [] + it "doesn't match superstrings when queried with substring" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?|. ["test"] == False + -- "testing" ?|. ["test"] == False + -- {"test":null,"test1":"no"} ?|. ["test"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["test"]] [] + [objTestK] `matchKeys` vals - -- [] ?| ["[]"] == False - -- "[]" ?| ["[]"] == True - selectList [TestValueJson ?|. ["[]"]] [] - >>= matchKeys "60" [strArrK] + it "doesn't match nested keys" $ + -- {"c":24.986,"foo":{"deep1":true"}} ?|. ["deep1"] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["deep1"]] [] + [] `matchKeys` vals ----------------------------------------------------------------------------------------- + it "doesn't match anything when queried with empty list" $ + -- ANYTHING ?|. [] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. []] [] + [] `matchKeys` vals - liftIO $ putStrLn "\n- - - - - Starting ?& tests - - - - -\n" + it "doesn't match raw, non-string, values when queried with strings" $ + -- true ?|. ["true","null","1"] == False + -- null ?|. ["true","null","1"] == False + -- 1 ?|. ["true","null","1"] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["true","null","1"]] [] + [] `matchKeys` vals - -- ANYTHING ?& [] == True - selectList [TestValueJson ?&. []] [] - >>= matchKeys "61" [ nullK - , boolTK, boolFK - , num0K, num1K, numBigK, numFloatK, numSmallK, numFloat2K, numBigFloatK - , strNullK, strObjK, strArrK, strAK, strTestK, str2K, strFloatK - , arrNullK, arrListK, arrList2K, arrFilledK - , objNullK, objTestK, objDeepK + it "matches string array when queried with \"[]\"" $ + -- [] ?|. ["[]"] == False + -- "[]" ?|. ["[]"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["[]"]] [] + [strArrK] `matchKeys` vals - , arrList3K, arrList4K - , objEmptyK, objFullK - ] + describe "?&. queries" $ do + it "matches anything when queried with an empty list" $ + -- ANYTHING ?&. [] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. []] [] + flip matchKeys vals [ nullK + , boolTK, boolFK + , num0K, num1K, numBigK, numFloatK + , numSmallK, numFloat2K, numBigFloatK + , strNullK, strObjK, strArrK, strAK + , strTestK, str2K, strFloatK + , arrNullK, arrListK, arrList2K + , arrFilledK, arrList3K, arrList4K + , objNullK, objTestK, objDeepK + , objEmptyK, objFullK + ] - -- "a" ?& ["a"] == True - -- [["a"],1] ?& ["a"] == False - -- ["a","b","c","d"] ?& ["a"] == True - -- {"a":1,"b":2,"c":3,"d":4} ?& ["a"] == True - selectList [TestValueJson ?&. ["a"]] [] - >>= matchKeys "62" [strAK,arrList4K,objFullK] + it "matches raw values, lists, and objects when queried with string" $ + -- "a" ?&. ["a"] == True + -- [["a"],1] ?&. ["a"] == False + -- ["a","b","c","d"] ?&. ["a"] == True + -- {"a":1,"b":2,"c":3,"d":4} ?&. ["a"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["a"]] [] + [strAK,arrList4K,objFullK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?& ["b","c"] == False - -- {"c":24.986,"foo":{"deep1":true"}} ?& ["b","c"] == False - -- ["a","b","c","d"] ?& ["b","c"] == True - -- {"a":1,"b":2,"c":3,"d":4} ?& ["b","c"] == True - selectList [TestValueJson ?&. ["b","c"]] [] - >>= matchKeys "63" [arrList4K,objFullK] + it "matches raw values, lists, and objects when queried with multiple string" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?&. ["b","c"] == False + -- {"c":24.986,"foo":{"deep1":true"}} ?&. ["b","c"] == False + -- ["a","b","c","d"] ?&. ["b","c"] == True + -- {"a":1,"b":2,"c":3,"d":4} ?&. ["b","c"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["b","c"]] [] + [arrList4K,objFullK] `matchKeys` vals - -- {} ?& ["{}"] == False - -- "{}" ?& ["{}"] == True - selectList [TestValueJson ?&. ["{}"]] [] - >>= matchKeys "64" [strObjK] + it "matches object string when queried with \"{}\"" $ + -- {} ?&. ["{}"] == False + -- "{}" ?&. ["{}"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["{}"]] [] + [strObjK] `matchKeys` vals - -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?& ["test"] == False - -- "testing" ?& ["test"] == False - -- {"test":null,"test1":"no"} ?& ["test"] == True - selectList [TestValueJson ?&. ["test"]] [] - >>= matchKeys "65" [objTestK] + it "doesn't match superstrings when queried with substring" $ + -- [null,4,"b",{},[],{"test":[null],"test2":"yes"}] ?&. ["test"] == False + -- "testing" ?&. ["test"] == False + -- {"test":null,"test1":"no"} ?&. ["test"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["test"]] [] + [objTestK] `matchKeys` vals - -- {"c":24.986,"foo":{"deep1":true"}} ?& ["deep1"] == False - selectList [TestValueJson ?&. ["deep1"]] [] - >>= matchKeys "66" [] + it "doesn't match nested keys" $ + -- {"c":24.986,"foo":{"deep1":true"}} ?&. ["deep1"] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["deep1"]] [] + [] `matchKeys` vals - -- "a" ?& ["a","e"] == False - -- ["a","b","c","d"] ?& ["a","e"] == False - -- {"a":1,"b":2,"c":3,"d":4} ?& ["a","e"] == False - selectList [TestValueJson ?&. ["a","e"]] [] - >>= matchKeys "67" [] + it "doesn't match anything when there is a partial match" $ + -- "a" ?&. ["a","e"] == False + -- ["a","b","c","d"] ?&. ["a","e"] == False + -- {"a":1,"b":2,"c":3,"d":4} ?&. ["a","e"] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["a","e"]] [] + [] `matchKeys` vals - -- [] ?& ["[]"] == False - -- "[]" ?& ["[]"] == True - selectList [TestValueJson ?&. ["[]"]] [] - >>= matchKeys "68" [strArrK] + it "matches string array when queried with \"[]\"" $ + -- [] ?&. ["[]"] == False + -- "[]" ?&. ["[]"] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["[]"]] [] + [strArrK] `matchKeys` vals - -- THIS WILL FAIL IF THE IMPLEMENTATION USES - -- @ '{null}' @ - -- INSTEAD OF - -- @ ARRAY['null'] @ - -- null ?& ["null"] == False - selectList [TestValueJson ?&. ["null"]] [] - >>= matchKeys "69" [] + it "doesn't match null when queried with string null" $ + -- THIS WILL FAIL IF THE IMPLEMENTATION USES + -- @ '{null}' @ + -- INSTEAD OF + -- @ ARRAY['null'] @ + -- null ?&. ["null"] == False + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["null"]] [] + [] `matchKeys` vals - -- [["a"],1] ?& ["1"] == False - -- "1" ?& ["1"] == True - selectList [TestValueJson ?&. ["1"]] [] - >>= matchKeys "70" [] + it "doesn't match number when queried with str of that number" $ + -- [["a"],1] ?&. ["1"] == False + -- "1" ?&. ["1"] == True + \TestKeys {..} -> runConnAssert $ do + str1 <- insert' $ toJSON $ String "1" + vals <- selectList [TestValueJson ?&. ["1"]] [] + [str1] `matchKeys` vals - -- {} ?& [""] == False - -- [] ?& [""] == False - -- "" ?& [""] == True - -- {"":9001} ?& [""] == True - selectList [TestValueJson ?&. [""]] [] - >>= matchKeys "71" [strNullK,objEmptyK] + it "doesn't match empty objs or list when queried with empty string" $ + -- {} ?&. [""] == False + -- [] ?&. [""] == False + -- "" ?&. [""] == True + -- {"":9001} ?&. [""] == True + \TestKeys {..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. [""]] [] + [strNullK,objEmptyK] `matchKeys` vals diff --git a/test/PgInit.hs b/test/PgInit.hs --- a/test/PgInit.hs +++ b/test/PgInit.hs @@ -3,11 +3,13 @@ module PgInit ( runConn + , runConn_ + , runConnAssert + , runConnAssertUseConf , MonadIO , persistSettings , MkPersistSettings (..) - , db , BackendKey(..) , GenerateKey(..) @@ -85,21 +87,52 @@ persistSettings = sqlSettings { mpsGeneric = True } runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () -runConn f = do +runConn f = runConn_ f >>= const (return ()) + +runConn_ :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m t +runConn_ f = runConnInternal RunConnBasic f + +-- | Data type to switch between pool creation functions, to ease testing both. +data RunConnType = + RunConnBasic -- ^ Use 'withPostgresqlPool' + | RunConnConf -- ^ Use 'withPostgresqlPoolWithConf' + deriving (Show, Eq) + +runConnInternal :: MonadUnliftIO m => RunConnType -> SqlPersistT (LoggingT m) t -> m t +runConnInternal connType f = do travis <- liftIO isTravis let debugPrint = not travis && _debugOn - let printDebug = if debugPrint then print . fromLogStr else void . return + printDebug = if debugPrint then print . fromLogStr else void . return + poolSize = 1 + connString <- if travis + then do + pure "host=localhost port=5432 user=perstest password=perstest dbname=persistent" + else do + host <- fromMaybe "localhost" <$> liftIO dockerPg + pure ("host=" <> host <> " port=5432 user=postgres dbname=test") + flip runLoggingT (\_ _ _ s -> printDebug s) $ do - _ <- if travis - then withPostgresqlPool "host=localhost port=5432 user=postgres dbname=persistent" 1 $ runSqlPool f - else do - host <- fromMaybe "localhost" <$> liftIO dockerPg - withPostgresqlPool ("host=" <> host <> " port=5432 user=postgres dbname=test") 1 $ runSqlPool f - return () + logInfoN (if travis then "Running in CI" else "CI not detected") + case connType of + RunConnBasic -> withPostgresqlPool connString poolSize $ runSqlPool f + RunConnConf -> do + let conf = PostgresConf + { pgConnStr = connString + , pgPoolStripes = 1 + , pgPoolIdleTimeout = 60 + , pgPoolSize = poolSize + } + hooks = defaultPostgresConfHooks + withPostgresqlPoolWithConf conf hooks (runSqlPool f) -db :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion -db actions = do +runConnAssert :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion +runConnAssert actions = do runResourceT $ runConn $ actions >> transactionUndo + +-- | Like runConnAssert, but uses the "conf" flavor of functions to test that code path. +runConnAssertUseConf :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion +runConnAssertUseConf actions = do + runResourceT $ runConnInternal RunConnConf (actions >> transactionUndo) instance Arbitrary Value where arbitrary = frequency [ (1, pure Null) diff --git a/test/PgIntervalTest.hs b/test/PgIntervalTest.hs new file mode 100644 --- /dev/null +++ b/test/PgIntervalTest.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs, DataKinds, FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} + +module PgIntervalTest where + +import PgInit +import Data.Time.Clock (NominalDiffTime) +import Database.Persist.Postgresql (PgInterval(..)) +import Test.Hspec.QuickCheck + +share [mkPersist sqlSettings, mkMigrate "pgIntervalMigrate"] [persistLowerCase| +PgIntervalDb + interval_field PgInterval + deriving Eq + deriving Show +|] + +-- Postgres Interval has a 1 microsecond resolution, while NominalDiffTime has +-- picosecond resolution. Round to the nearest microsecond so that we can be +-- fine in the tests. +truncate' :: NominalDiffTime -> NominalDiffTime +truncate' x = (fromIntegral (round (x * 10^6))) / 10^6 + +specs :: Spec +specs = describe "Postgres Interval Property tests" $ + prop "Round trips" $ \time -> runConnAssert $ do + let eg = PgIntervalDb $ PgInterval (truncate' time) + rid <- insert eg + r <- getJust rid + liftIO $ r `shouldBe` eg diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,5 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} @@ -20,9 +20,9 @@ import Data.Time import Test.QuickCheck --- FIXME: should probably be used? --- import qualified ArrayAggTest +import qualified ArrayAggTest import qualified CompositeTest +import qualified ForeignKey import qualified CustomPersistFieldTest import qualified CustomPrimaryKeyReferenceTest import qualified DataTypeTest @@ -35,8 +35,10 @@ import qualified LargeNumberTest import qualified MaxLenTest import qualified MigrationColumnLengthTest +import qualified MigrationTest import qualified MigrationOnlyTest import qualified MpsNoPrefixTest +import qualified MpsCustomPrefixTest import qualified PersistentTest import qualified PersistUniqueTest import qualified PrimaryTest @@ -50,6 +52,9 @@ import qualified UniqueTest import qualified UpsertTest import qualified CustomConstraintTest +import qualified LongIdentifierTest +import qualified PgIntervalTest +import qualified GeneratedColumnTestSQL type Tuple = (,) @@ -102,6 +107,8 @@ mapM_ setup [ PersistentTest.testMigrate , PersistentTest.noPrefixMigrate + , PersistentTest.customPrefixMigrate + , PersistentTest.treeMigrate , EmbedTest.embedMigrate , EmbedOrderTest.embedOrderMigrate , LargeNumberTest.numberMigrate @@ -117,12 +124,17 @@ , CustomPrimaryKeyReferenceTest.migration , MigrationColumnLengthTest.migration , TransactionLevelTest.migration + , LongIdentifierTest.migration + , ForeignKey.compositeMigrate + , MigrationTest.migrationMigrate + , PgIntervalTest.pgIntervalMigrate ] PersistentTest.cleanDB + ForeignKey.cleanDB hspec $ do - RenameTest.specsWith db - DataTypeTest.specsWith db + RenameTest.specsWith runConnAssert + DataTypeTest.specsWith runConnAssert (Just (runMigrationSilent dataTypeMigrate)) [ TestFn "text" dataTypeTableText , TestFn "textMaxLen" dataTypeTableTextMaxLen @@ -141,41 +153,48 @@ [ ("pico", dataTypeTablePico) ] dataTypeTableDouble HtmlTest.specsWith - db + runConnAssert (Just (runMigrationSilent HtmlTest.htmlMigrate)) - EmbedTest.specsWith db - EmbedOrderTest.specsWith db - LargeNumberTest.specsWith db - UniqueTest.specsWith db - MaxLenTest.specsWith db - Recursive.specsWith db - SumTypeTest.specsWith db (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationOnlyTest.specsWith db + + EmbedTest.specsWith runConnAssert + EmbedOrderTest.specsWith runConnAssert + LargeNumberTest.specsWith runConnAssert + ForeignKey.specsWith runConnAssert + UniqueTest.specsWith runConnAssert + MaxLenTest.specsWith runConnAssert + Recursive.specsWith runConnAssert + SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) + MigrationTest.specsWith runConnAssert + MigrationOnlyTest.specsWith runConnAssert + (Just $ runMigrationSilent MigrationOnlyTest.migrateAll1 >> runMigrationSilent MigrationOnlyTest.migrateAll2 ) - PersistentTest.specsWith db - ReadWriteTest.specsWith db - PersistentTest.filterOrSpecs db - RawSqlTest.specsWith db + PersistentTest.specsWith runConnAssert + ReadWriteTest.specsWith runConnAssert + PersistentTest.filterOrSpecs runConnAssert + RawSqlTest.specsWith runConnAssert UpsertTest.specsWith - db + runConnAssert UpsertTest.Don'tUpdateNull UpsertTest.UpsertPreserveOldKey - MpsNoPrefixTest.specsWith db - EmptyEntityTest.specsWith db (Just (runMigrationSilent EmptyEntityTest.migration)) - CompositeTest.specsWith db - TreeTest.specsWith db - PersistUniqueTest.specsWith db - PrimaryTest.specsWith db - CustomPersistFieldTest.specsWith db - CustomPrimaryKeyReferenceTest.specsWith db - MigrationColumnLengthTest.specsWith db + MpsNoPrefixTest.specsWith runConnAssert + MpsCustomPrefixTest.specsWith runConnAssert + EmptyEntityTest.specsWith runConnAssert (Just (runMigrationSilent EmptyEntityTest.migration)) + CompositeTest.specsWith runConnAssert + TreeTest.specsWith runConnAssert + PersistUniqueTest.specsWith runConnAssert + PrimaryTest.specsWith runConnAssert + CustomPersistFieldTest.specsWith runConnAssert + CustomPrimaryKeyReferenceTest.specsWith runConnAssert + MigrationColumnLengthTest.specsWith runConnAssert EquivalentTypeTestPostgres.specs - TransactionLevelTest.specsWith db + TransactionLevelTest.specsWith runConnAssert + LongIdentifierTest.specsWith runConnAssertUseConf -- Have at least one test use the conf variant of connecting to Postgres, to improve test coverage. JSONTest.specs - CustomConstraintTest.specs db - -- FIXME: not used, probably should? - -- ArrayAggTest.specs db + CustomConstraintTest.specs + PgIntervalTest.specs + ArrayAggTest.specs + GeneratedColumnTestSQL.specsWith runConnAssert