persistent-postgresql 2.10.1.2 → 2.11.0.0
raw patch · 11 files changed
+2483/−1691 lines, 11 filesdep +attoparsecdep +mtldep +string-conversionsdep ~persistent
Dependencies added: attoparsec, mtl, string-conversions
Dependency ranges changed: persistent
Files
- ChangeLog.md +21/−0
- Database/Persist/Postgresql.hs +1752/−1289
- Database/Persist/Postgresql/JSON.hs +1/−1
- persistent-postgresql.cabal +6/−2
- test/ArrayAggTest.hs +4/−4
- test/CustomConstraintTest.hs +11/−11
- test/EquivalentTypeTestPostgres.hs +1/−0
- test/JSONTest.hs +551/−341
- test/PgInit.hs +44/−11
- test/PgIntervalTest.hs +41/−0
- test/main.hs +51/−32
ChangeLog.md view
@@ -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)
Database/Persist/Postgresql.hs view
@@ -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--- <https://www.postgresql.org/docs/current/static/libpq-connect.html>--- 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:------ <https://groups.google.com/d/msg/yesodweb/qUXrEN_swEo/O0pFwqwQIdcJ>------ @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+-- <https://www.postgresql.org/docs/current/static/libpq-connect.html>+-- 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:+--+-- <https://groups.google.com/d/msg/yesodweb/qUXrEN_swEo/O0pFwqwQIdcJ>+--+-- @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+ }+ )
Database/Persist/Postgresql/JSON.hs view
@@ -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) =
persistent-postgresql.cabal view
@@ -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 <michael@snoyman.com>@@ -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
test/ArrayAggTest.hs view
@@ -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"
test/CustomConstraintTest.hs view
@@ -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 ()
test/EquivalentTypeTestPostgres.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DataKinds, FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}
test/JSONTest.hs view
@@ -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
test/PgInit.hs view
@@ -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)
+ test/PgIntervalTest.hs view
@@ -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
test/main.hs view
@@ -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