diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,35 @@ # Changelog for persistent-postgresql +# 2.14.3.0 + +* [#1616](https://github.com/yesodweb/persistent/pull/1616) + * Allow overriding the default cascade option for foreign keys. + +# 2.14.2.0 + +* [#1614](https://github.com/yesodweb/persistent/pull/1614) + * Generate migrations to create foreign key constraints while adding new foreign key columns (previously you had to generate migrations twice to create foreign key constraints) + +# 2.14.1.0 + +* [#1612](https://github.com/yesodweb/persistent/pull/1612) + * Speed up migrations by avoiding N+1 queries. + You can now migrate a large set of entities much faster, by using the new `migrateEntitiesStructured` function. + +# 2.14.0.1 + +* [#1610](https://github.com/yesodweb/persistent/pull/1610) + * Update suggested migrations to handle `NoAction` as a `CascadeAction` + +## 2.14.0.0 + +* [#1604](https://github.com/yesodweb/persistent/pull/1604) + * Changed the representation of intervals to use the `Interval` type from [the `postgresql-simple-interval` package](https://hackage.haskell.org/package/postgresql-simple-interval). + This changes the behavior of `PgInterval` for very small and very large values. + * Previously `PgInterval 0.000_000_9` would be rounded to `0.000_001` seconds, but now it is truncated to 0 seconds. + * Previously `PgInterval 9_223_372_036_854.775_808` would overflow and throw a SQL error, but now it saturates to `9_223_372_036_854.775_807` seconds. + * The SQL representation of `PgInterval` now always includes the `interval` prefix, like `interval '1 second'`. + ## 2.13.7.0 * [#1600](https://github.com/yesodweb/persistent/pull/1600) diff --git a/Database/Persist/Postgresql.hs b/Database/Persist/Postgresql.hs --- a/Database/Persist/Postgresql.hs +++ b/Database/Persist/Postgresql.hs @@ -506,7 +506,7 @@ , connStmtMap = smap , connInsertSql = insertSql' , connClose = PG.close conn - , connMigrateSql = migrate' + , connMigrateSql = migrate' emptyBackendSpecificOverrides , connBegin = \_ mIsolation -> case mIsolation of Nothing -> PG.begin conn Just iso -> @@ -683,11 +683,14 @@ Ok v -> return v migrate' - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] CautiousMigration) -migrate' allDefs getter entity = fmap (fmap $ map showAlterDb) $ migrateStructured allDefs getter entity +migrate' overrides allDefs getter entity = + fmap (fmap $ map showAlterDb) $ + migrateStructured overrides allDefs getter entity -- | Get the SQL string for the table that a PersistEntity represents. -- Useful for raw SQL queries. @@ -821,15 +824,16 @@ } mockMigrate - :: [EntityDef] + :: BackendSpecificOverrides + -> [EntityDef] -> (Text -> IO Statement) -> EntityDef -> IO (Either [Text] [(Bool, Text)]) -mockMigrate allDefs _ entity = +mockMigrate overrides allDefs _ entity = fmap (fmap $ map showAlterDb) $ return $ Right $ - mockMigrateStructured allDefs entity + mockMigrateStructured overrides allDefs entity -- | Mock a migration even when the database is not present. -- This function performs the same functionality of 'printMigration' @@ -852,7 +856,7 @@ , connInsertSql = undefined , connStmtMap = smap , connClose = undefined - , connMigrateSql = mockMigrate + , connMigrateSql = mockMigrate emptyBackendSpecificOverrides , connBegin = undefined , connCommit = undefined , connRollback = undefined diff --git a/Database/Persist/Postgresql/Internal.hs b/Database/Persist/Postgresql/Internal.hs --- a/Database/Persist/Postgresql/Internal.hs +++ b/Database/Persist/Postgresql/Internal.hs @@ -1,1281 +1,263 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Database.Persist.Postgresql.Internal - ( P (..) - , PgInterval (..) - , getGetter - , AlterDB (..) - , AlterTable (..) - , AlterColumn (..) - , SafeToRemove - , migrateStructured - , mockMigrateStructured - , addTable - , findAlters - , maySerial - , mayDefault - , showSqlType - , showColumn - , showAlter - , showAlterDb - , showAlterTable - , getAddReference - , udToPair - , safeToRemove - , postgresMkColumns - , getAlters - , escapeE - , escapeF - , escape - ) where - -import qualified Database.PostgreSQL.Simple as PG -import qualified Database.PostgreSQL.Simple.FromField as PGFF -import qualified Database.PostgreSQL.Simple.Internal as PG -import qualified Database.PostgreSQL.Simple.ToField as PGTF -import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS -import qualified Database.PostgreSQL.Simple.Types as PG - -import qualified Blaze.ByteString.Builder.Char8 as BBB -import Control.Arrow -import Control.Monad -import Control.Monad.Except -import Control.Monad.IO.Unlift (MonadIO (..)) -import Control.Monad.Trans.Class (lift) -import Data.Acquire (with) -import qualified Data.Attoparsec.ByteString.Char8 as P -import Data.Bits ((.&.)) -import Data.ByteString (ByteString) -import qualified Data.ByteString.Builder as BB -import qualified Data.ByteString.Char8 as B8 -import Data.Char (ord) -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Data (Typeable) -import Data.Either (partitionEithers) -import Data.Fixed (Fixed (..), Pico) -import Data.Function (on) -import Data.Int (Int64) -import qualified Data.IntMap as I -import Data.List as List (find, foldl', groupBy, sort) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map as Map -import Data.Maybe -import Data.String.Conversions.Monomorphic (toStrictByteString) -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import Data.Time (NominalDiffTime, localTimeToUTC, utc) -import Database.Persist.Sql -import qualified Database.Persist.Sql.Util as Util - --- | Newtype used to avoid orphan instances for @postgresql-simple@ classes. --- --- @since 2.13.2.0 -newtype P = P {unP :: PersistValue} - -instance PGTF.ToField P where - toField (P (PersistText t)) = PGTF.toField t - toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) - toField (P (PersistInt64 i)) = PGTF.toField i - toField (P (PersistDouble d)) = PGTF.toField d - toField (P (PersistRational r)) = - PGTF.Plain $ - BBB.fromString $ - show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field - toField (P (PersistBool b)) = PGTF.toField b - toField (P (PersistDay d)) = PGTF.toField d - toField (P (PersistTimeOfDay t)) = PGTF.toField t - toField (P (PersistUTCTime t)) = PGTF.toField t - toField (P PersistNull) = PGTF.toField PG.Null - toField (P (PersistList l)) = PGTF.toField $ listToJSON l - toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m - toField (P (PersistLiteral_ DbSpecific s)) = PGTF.toField (Unknown s) - toField (P (PersistLiteral_ Unescaped l)) = PGTF.toField (UnknownLiteral l) - toField (P (PersistLiteral_ Escaped e)) = PGTF.toField (Unknown e) - toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a - toField (P (PersistObjectId _)) = - error "Refusing to serialize a PersistObjectId to a PostgreSQL value" - -instance PGFF.FromField P where - fromField field mdata = fmap P $ case mdata of - -- If we try to simply decode based on oid, we will hit unexpected null - -- errors. - Nothing -> pure PersistNull - data' -> getGetter (PGFF.typeOid field) field data' - -newtype Unknown = Unknown {unUnknown :: ByteString} - deriving (Eq, Show, Read, Ord) - -instance PGFF.FromField Unknown where - fromField f mdata = - case mdata of - Nothing -> - PGFF.returnError - PGFF.UnexpectedNull - f - "Database.Persist.Postgresql/PGFF.FromField Unknown" - Just dat -> return (Unknown dat) - -instance PGTF.ToField Unknown where - toField (Unknown a) = PGTF.Escape a - -newtype UnknownLiteral = UnknownLiteral {unUnknownLiteral :: ByteString} - deriving (Eq, Show, Read, Ord, Typeable) - -instance PGFF.FromField UnknownLiteral where - fromField f mdata = - case mdata of - Nothing -> - PGFF.returnError - PGFF.UnexpectedNull - f - "Database.Persist.Postgresql/PGFF.FromField UnknownLiteral" - Just dat -> return (UnknownLiteral dat) - -instance PGTF.ToField UnknownLiteral where - toField (UnknownLiteral a) = PGTF.Plain $ BB.byteString a - -type Getter a = PGFF.FieldParser a - -convertPV :: (PGFF.FromField a) => (a -> b) -> Getter b -convertPV f = (fmap f .) . PGFF.fromField - -builtinGetters :: I.IntMap (Getter PersistValue) -builtinGetters = - I.fromList - [ (k PS.bool, convertPV PersistBool) - , (k PS.bytea, convertPV (PersistByteString . unBinary)) - , (k PS.char, convertPV PersistText) - , (k PS.name, convertPV PersistText) - , (k PS.int8, convertPV PersistInt64) - , (k PS.int2, convertPV PersistInt64) - , (k PS.int4, convertPV PersistInt64) - , (k PS.text, convertPV PersistText) - , (k PS.xml, convertPV (PersistByteString . unUnknown)) - , (k PS.float4, convertPV PersistDouble) - , (k PS.float8, convertPV PersistDouble) - , (k PS.money, convertPV PersistRational) - , (k PS.bpchar, convertPV PersistText) - , (k PS.varchar, convertPV PersistText) - , (k PS.date, convertPV PersistDay) - , (k PS.time, convertPV PersistTimeOfDay) - , (k PS.timestamp, convertPV (PersistUTCTime . localTimeToUTC utc)) - , (k PS.timestamptz, convertPV PersistUTCTime) - , (k PS.interval, convertPV (PersistLiteralEscaped . pgIntervalToBs)) - , (k PS.bit, convertPV PersistInt64) - , (k PS.varbit, convertPV PersistInt64) - , (k PS.numeric, convertPV PersistRational) - , (k PS.void, \_ _ -> return PersistNull) - , (k PS.json, convertPV (PersistByteString . unUnknown)) - , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) - , (k PS.unknown, convertPV (PersistByteString . unUnknown)) - , -- Array types: same order as above. - -- The OIDs were taken from pg_type. - (1000, listOf PersistBool) - , (1001, listOf (PersistByteString . unBinary)) - , (1002, listOf PersistText) - , (1003, listOf PersistText) - , (1016, listOf PersistInt64) - , (1005, listOf PersistInt64) - , (1007, listOf PersistInt64) - , (1009, listOf PersistText) - , (143, listOf (PersistByteString . unUnknown)) - , (1021, listOf PersistDouble) - , (1022, listOf PersistDouble) - , (1023, listOf PersistUTCTime) - , (1024, listOf PersistUTCTime) - , (791, listOf PersistRational) - , (1014, listOf PersistText) - , (1015, listOf PersistText) - , (1182, listOf PersistDay) - , (1183, listOf PersistTimeOfDay) - , (1115, listOf PersistUTCTime) - , (1185, listOf PersistUTCTime) - , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs)) - , (1561, listOf PersistInt64) - , (1563, listOf PersistInt64) - , (1231, listOf PersistRational) - , -- no array(void) type - (2951, listOf (PersistLiteralEscaped . unUnknown)) - , (199, listOf (PersistByteString . unUnknown)) - , (3807, listOf (PersistByteString . unUnknown)) - -- no array(unknown) either - ] - where - k (PGFF.typoid -> i) = PG.oid2int i - -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert - -- the values to Haskell-land. The @Maybe@ is important - -- because the usual way of checking NULLs - -- (c.f. withStmt') won't check for NULL inside - -- arrays---or any other compound structure for that matter. - listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) - where - nullable = maybe PersistNull - --- | Get the field parser corresponding to the given 'PG.Oid'. --- --- For example, pass in the 'PG.Oid' of 'PS.bool', and you will get back a --- field parser which parses boolean values in the table into 'PersistBool's. --- --- @since 2.13.2.0 -getGetter :: PG.Oid -> Getter PersistValue -getGetter oid = - fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters - where - defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) - -unBinary :: PG.Binary a -> a -unBinary (PG.Binary x) = x - --- | Represent Postgres interval using NominalDiffTime --- --- @since 2.11.0.0 -newtype PgInterval = PgInterval {getPgInterval :: NominalDiffTime} - deriving (Eq, Show) - -pgIntervalToBs :: PgInterval -> ByteString -pgIntervalToBs = toStrictByteString . show . getPgInterval - -instance PGTF.ToField PgInterval where - toField (PgInterval t) = PGTF.toField t - -instance PGFF.FromField PgInterval where - fromField f mdata = - if PGFF.typeOid f /= PS.typoid PS.interval - then PGFF.returnError PGFF.Incompatible f "" - else case mdata of - Nothing -> PGFF.returnError PGFF.UnexpectedNull f "" - Just dat -> case P.parseOnly (nominalDiffTime <* P.endOfInput) dat of - Left msg -> PGFF.returnError PGFF.ConversionFailed f msg - Right t -> return $ PgInterval t - where - toPico :: Integer -> Pico - toPico = MkFixed - - -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser - twoDigits :: P.Parser Int - twoDigits = do - a <- P.digit - b <- P.digit - let - c2d c = ord c .&. 15 - return $! c2d a * 10 + c2d b - - -- Taken from Database.PostgreSQL.Simple.Time.Internal.Parser - seconds :: P.Parser Pico - seconds = do - real <- twoDigits - mc <- P.peekChar - case mc of - Just '.' -> do - t <- P.anyChar *> P.takeWhile1 P.isDigit - return $! parsePicos (fromIntegral real) t - _ -> return $! fromIntegral real - where - parsePicos :: Int64 -> B8.ByteString -> Pico - parsePicos a0 t = toPico (fromIntegral (t' * 10 ^ n)) - where - n = max 0 (12 - B8.length t) - t' = - B8.foldl' - (\a c -> 10 * a + fromIntegral (ord c .&. 15)) - a0 - (B8.take 12 t) - - parseSign :: P.Parser Bool - parseSign = P.choice [P.char '-' >> return True, return False] - - -- Db stores it in [-]HHH:MM:SS.[SSSS] - -- For example, nominalDay is stored as 24:00:00 - interval :: P.Parser (Bool, Int, Int, Pico) - interval = do - s <- parseSign - h <- P.decimal <* P.char ':' - m <- twoDigits <* P.char ':' - ss <- seconds - if m < 60 && ss <= 60 - then return (s, h, m, ss) - else fail "Invalid interval" - - nominalDiffTime :: P.Parser NominalDiffTime - nominalDiffTime = do - (s, h, m, ss) <- interval - let - pico = ss + 60 * (fromIntegral m) + 60 * 60 * (fromIntegral (abs h)) - return . fromRational . toRational $ if s then (-pico) else pico - -fromPersistValueError - :: Text - -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" - -> Text - -- ^ Database type(s), should appear different from Haskell name, e.g. "integer" or "INT", not "Int". - -> PersistValue - -- ^ Incorrect value - -> Text - -- ^ Error message -fromPersistValueError haskellType databaseType received = - T.concat - [ "Failed to parse Haskell type `" - , haskellType - , "`; expected " - , databaseType - , " from database, but received: " - , T.pack (show received) - , ". Potential solution: Check that your database schema matches your Persistent model definitions." - ] - -instance PersistField PgInterval where - toPersistValue = PersistLiteralEscaped . pgIntervalToBs - fromPersistValue (PersistLiteral_ DbSpecific bs) = - fromPersistValue (PersistLiteralEscaped bs) - fromPersistValue x@(PersistLiteral_ Escaped bs) = - case P.parseOnly (P.signed P.rational <* P.char 's' <* P.endOfInput) bs of - Left _ -> Left $ fromPersistValueError "PgInterval" "Interval" x - Right i -> Right $ PgInterval i - fromPersistValue x = Left $ fromPersistValueError "PgInterval" "Interval" x - -instance PersistFieldSql PgInterval where - sqlType _ = SqlOther "interval" - --- | Indicates whether a Postgres Column is safe to drop. --- --- @since 2.17.1.0 -newtype SafeToRemove = SafeToRemove Bool - deriving (Show, Eq) - --- | Represents a change to a Postgres column in a DB statement. --- --- @since 2.17.1.0 -data AlterColumn - = ChangeType Column SqlType Text - | IsNull Column - | NotNull Column - | AddColumn Column - | Drop Column SafeToRemove - | Default Column Text - | NoDefault Column - | UpdateNullToValue Column Text - | AddReference - EntityNameDB - ConstraintNameDB - (NEL.NonEmpty FieldNameDB) - [Text] - FieldCascade - | DropReference ConstraintNameDB - deriving (Show, Eq) - --- | Represents a change to a Postgres table in a DB statement. --- --- @since 2.17.1.0 -data AlterTable - = AddUniqueConstraint ConstraintNameDB [FieldNameDB] - | DropConstraint ConstraintNameDB - deriving (Show, Eq) - --- | Represents a change to a Postgres DB in a statement. --- --- @since 2.17.1.0 -data AlterDB - = AddTable EntityNameDB EntityIdDef [Column] - | AlterColumn EntityNameDB AlterColumn - | AlterTable EntityNameDB AlterTable - deriving (Show, Eq) - --- | Returns a structured representation of all of the --- DB changes required to migrate the Entity from its --- current state in the database to the state described in --- Haskell. --- --- @since 2.17.1.0 -migrateStructured - :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] [AlterDB]) -migrateStructured allDefs getter entity = do - old <- getColumns getter entity newcols' - case partitionEithers old of - ([], old'') -> do - exists' <- - if null old - then doesTableExist getter name - else return True - return $ Right $ migrationText exists' old'' - (errs, _) -> return $ Left errs - where - name = getEntityDBName entity - (newcols', udefs, fdefs) = postgresMkColumns allDefs entity - migrationText exists' old'' - | not exists' = - createText newcols fdefs udspair - | otherwise = - let - (acs, ats) = - getAlters allDefs entity (newcols, udspair) old' - acs' = map (AlterColumn name) acs - ats' = map (AlterTable name) ats - in - acs' ++ ats' - where - old' = partitionEithers old'' - newcols = filter (not . safeToRemove entity . cName) newcols' - udspair = map udToPair udefs - -- Check for table existence if there are no columns, workaround - -- for https://github.com/yesodweb/persistent/issues/152 - - createText newcols fdefs_ udspair = - (addTable newcols entity) : uniques ++ references ++ foreignsAlt - where - uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] - references = - mapMaybe - ( \Column{cName, cReference} -> - getAddReference allDefs entity cName =<< cReference - ) - newcols - foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs_ - --- | Returns a structured representation of all of the --- DB changes required to migrate the Entity to the state --- described in Haskell, assuming it currently does not --- exist in the database. --- --- @since 2.17.1.0 -mockMigrateStructured - :: [EntityDef] - -> EntityDef - -> [AlterDB] -mockMigrateStructured allDefs entity = migrationText - where - name = getEntityDBName entity - migrationText = createText newcols fdefs udspair - where - (newcols', udefs, fdefs) = postgresMkColumns allDefs entity - newcols = filter (not . safeToRemove entity . cName) newcols' - udspair = map udToPair udefs - -- Check for table existence if there are no columns, workaround - -- for https://github.com/yesodweb/persistent/issues/152 - - createText newcols fdefs udspair = - (addTable newcols entity) : uniques ++ references ++ foreignsAlt - where - uniques = flip concatMap udspair $ \(uname, ucols) -> - [AlterTable name $ AddUniqueConstraint uname ucols] - references = - mapMaybe - ( \Column{cName, cReference} -> - getAddReference allDefs entity cName =<< cReference - ) - newcols - foreignsAlt = mapMaybe (mkForeignAlt entity) fdefs - --- | Returns a structured representation of all of the --- DB changes required to migrate the Entity from its current state --- in the database to the state described in Haskell. --- --- @since 2.17.1.0 -addTable :: [Column] -> EntityDef -> AlterDB -addTable cols entity = - AddTable name entityId nonIdCols - where - nonIdCols = - case entityPrimary entity of - Just _ -> - cols - _ -> - filter keepField cols - where - keepField c = - Just (cName c) /= fmap fieldDB (getEntityIdField entity) - && not (safeToRemove entity (cName c)) - entityId = getEntityId entity - name = getEntityDBName entity - -maySerial :: SqlType -> Maybe Text -> Text -maySerial SqlInt64 Nothing = " SERIAL8 " -maySerial sType _ = " " <> showSqlType sType - -mayDefault :: Maybe Text -> Text -mayDefault def = case def of - Nothing -> "" - Just d -> " DEFAULT " <> d - -getAlters - :: [EntityDef] - -> EntityDef - -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) - -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) - -> ([AlterColumn], [AlterTable]) -getAlters defs def (c1, u1) (c2, u2) = - (getAltersC c1 c2, getAltersU u1 u2) - where - getAltersC [] old = - map (\x -> Drop x $ SafeToRemove $ safeToRemove def $ cName x) old - getAltersC (new : news) old = - let - (alters, old') = findAlters defs def new old - in - alters ++ getAltersC news old' - - getAltersU - :: [(ConstraintNameDB, [FieldNameDB])] - -> [(ConstraintNameDB, [FieldNameDB])] - -> [AlterTable] - getAltersU [] old = - map DropConstraint $ filter (not . isManual) $ map fst old - getAltersU ((name, cols) : news) old = - case lookup name old of - Nothing -> - AddUniqueConstraint name cols : getAltersU news old - Just ocols -> - let - old' = filter (\(x, _) -> x /= name) old - in - if sort cols == sort ocols - then getAltersU news old' - else - DropConstraint name - : AddUniqueConstraint name cols - : getAltersU news old' - - -- Don't drop constraints which were manually added. - isManual (ConstraintNameDB x) = "__manual_" `T.isPrefixOf` x - --- | Postgres' default maximum identifier length in bytes --- (You can re-compile Postgres with a new limit, but I'm assuming that virtually noone does this). --- See https://www.postgresql.org/docs/11/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS -maximumIdentifierLength :: Int -maximumIdentifierLength = 63 - --- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer -sqlTypeEq :: SqlType -> SqlType -> Bool -sqlTypeEq x y = - let - -- Non exhaustive helper to map postgres aliases to the same name. Based on - -- https://www.postgresql.org/docs/9.5/datatype.html. - -- This prevents needless `ALTER TYPE`s when the type is the same. - normalize "int8" = "bigint" - normalize "serial8" = "bigserial" - normalize v = v - in - normalize (T.toCaseFold (showSqlType x)) - == normalize (T.toCaseFold (showSqlType y)) - --- We check if we should alter a foreign key. This is almost an equality check, --- except we consider 'Nothing' and 'Just Restrict' equivalent. -equivalentRef :: Maybe ColumnReference -> Maybe ColumnReference -> Bool -equivalentRef Nothing Nothing = True -equivalentRef (Just cr1) (Just cr2) = - crTableName cr1 == crTableName cr2 - && crConstraintName cr1 == crConstraintName cr2 - && eqCascade (fcOnUpdate $ crFieldCascade cr1) (fcOnUpdate $ crFieldCascade cr2) - && eqCascade (fcOnDelete $ crFieldCascade cr1) (fcOnDelete $ crFieldCascade cr2) - where - eqCascade :: Maybe CascadeAction -> Maybe CascadeAction -> Bool - eqCascade Nothing Nothing = True - eqCascade Nothing (Just Restrict) = True - eqCascade (Just Restrict) Nothing = True - eqCascade (Just cs1) (Just cs2) = cs1 == cs2 - eqCascade _ _ = False -equivalentRef _ _ = False - -refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB -refName (EntityNameDB table) (FieldNameDB column) = - let - overhead = T.length $ T.concat ["_", "_fkey"] - (fromTable, fromColumn) = shortenNames overhead (T.length table, T.length column) - in - ConstraintNameDB $ - T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"] - where - -- Postgres automatically truncates too long foreign keys to a combination of - -- truncatedTableName + "_" + truncatedColumnName + "_fkey" - -- This works fine for normal use cases, but it creates an issue for Persistent - -- Because after running the migrations, Persistent sees the truncated foreign key constraint - -- doesn't have the expected name, and suggests that you migrate again - -- To workaround this, we copy the Postgres truncation approach before sending foreign key constraints to it. - -- - -- I believe this will also be an issue for extremely long table names, - -- but it's just much more likely to exist with foreign key constraints because they're usually tablename * 2 in length - - -- Approximation of the algorithm Postgres uses to truncate identifiers - -- See makeObjectName https://github.com/postgres/postgres/blob/5406513e997f5ee9de79d4076ae91c04af0c52f6/src/backend/commands/indexcmds.c#L2074-L2080 - shortenNames :: Int -> (Int, Int) -> (Int, Int) - shortenNames overhead (x, y) - | x + y + overhead <= maximumIdentifierLength = (x, y) - | x > y = shortenNames overhead (x - 1, y) - | otherwise = shortenNames overhead (x, y - 1) - -postgresMkColumns - :: [EntityDef] -> EntityDef -> ([Column], [UniqueDef], [ForeignDef]) -postgresMkColumns allDefs t = - mkColumns allDefs t $ - setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides - --- | Check if a column name is listed as the "safe to remove" in the entity --- list. -safeToRemove :: EntityDef -> FieldNameDB -> Bool -safeToRemove def (FieldNameDB colName) = - any (elem FieldAttrSafeToRemove . fieldAttrs) $ - filter ((== FieldNameDB colName) . fieldDB) $ - allEntityFields - where - allEntityFields = - getEntityFieldsDatabase def <> case getEntityId def of - EntityIdField fdef -> - [fdef] - _ -> - [] - -udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) -udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud) - --- | Get the references to be added to a table for the given column. -getAddReference - :: [EntityDef] - -> EntityDef - -> FieldNameDB - -> ColumnReference - -> Maybe AlterDB -getAddReference allDefs entity cname cr@ColumnReference{crTableName = s, crConstraintName = constraintName} = do - guard $ Just cname /= fmap fieldDB (getEntityIdField entity) - pure $ - AlterColumn - table - (AddReference s constraintName (cname NEL.:| []) id_ (crFieldCascade cr)) - where - table = getEntityDBName entity - id_ = - fromMaybe - (error $ "Could not find ID of entity " ++ show s) - $ do - entDef <- find ((== s) . getEntityDBName) allDefs - return $ NEL.toList $ Util.dbIdColumnsEsc escapeF entDef - -mkForeignAlt - :: EntityDef - -> ForeignDef - -> Maybe AlterDB -mkForeignAlt entity fdef = case NEL.nonEmpty childfields of - Nothing -> Nothing - Just childfields' -> Just $ AlterColumn tableName_ addReference - where - addReference = - AddReference - (foreignRefTableDBName fdef) - constraintName - childfields' - escapedParentFields - (foreignFieldCascade fdef) - where - tableName_ = getEntityDBName entity - constraintName = - foreignConstraintNameDBName fdef - (childfields, parentfields) = - unzip (map (\((_, b), (_, d)) -> (b, d)) (foreignFields fdef)) - escapedParentFields = - map escapeF parentfields - -escapeC :: ConstraintNameDB -> Text -escapeC = escapeWith escape - -escapeE :: EntityNameDB -> Text -escapeE = escapeWith escape - -escapeF :: FieldNameDB -> Text -escapeF = escapeWith escape - -escape :: Text -> Text -escape s = - T.pack $ '"' : go (T.unpack s) ++ "\"" - where - go "" = "" - go ('"' : xs) = "\"\"" ++ go xs - go (x : xs) = x : go xs - -showAlterDb :: AlterDB -> (Bool, Text) -showAlterDb (AddTable name entityId nonIdCols) = (False, rawText) - where - idtxt = - case entityId of - EntityIdNaturalKey pdef -> - T.concat - [ " PRIMARY KEY (" - , T.intercalate "," $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef - , ")" - ] - EntityIdField field -> - let - defText = defaultAttribute $ fieldAttrs field - sType = fieldSqlType field - in - T.concat - [ escapeF $ fieldDB field - , maySerial sType defText - , " PRIMARY KEY UNIQUE" - , mayDefault defText - ] - rawText = - T.concat - -- Lower case e: see Database.Persist.Sql.Migration - [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! - , escapeE name - , "(" - , idtxt - , if null nonIdCols then "" else "," - , T.intercalate "," $ map showColumn nonIdCols - , ")" - ] -showAlterDb (AlterColumn t ac) = - (isUnsafe ac, showAlter t ac) - where - isUnsafe (Drop _ (SafeToRemove safeRemove)) = not safeRemove - isUnsafe _ = False -showAlterDb (AlterTable t at) = (False, showAlterTable t at) - -showAlterTable :: EntityNameDB -> AlterTable -> Text -showAlterTable table (AddUniqueConstraint cname cols) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ADD CONSTRAINT " - , escapeC cname - , " UNIQUE(" - , T.intercalate "," $ map escapeF cols - , ")" - ] -showAlterTable table (DropConstraint cname) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " DROP CONSTRAINT " - , escapeC cname - ] - -showAlter :: EntityNameDB -> AlterColumn -> Text -showAlter table (ChangeType c t extra) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " TYPE " - , showSqlType t - , extra - ] -showAlter table (IsNull c) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " DROP NOT NULL" - ] -showAlter table (NotNull c) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " SET NOT NULL" - ] -showAlter table (AddColumn col) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ADD COLUMN " - , showColumn col - ] -showAlter table (Drop c _) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " DROP COLUMN " - , escapeF (cName c) - ] -showAlter table (Default c s) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " SET DEFAULT " - , s - ] -showAlter table (NoDefault c) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ALTER COLUMN " - , escapeF (cName c) - , " DROP DEFAULT" - ] -showAlter table (UpdateNullToValue c s) = - T.concat - [ "UPDATE " - , escapeE table - , " SET " - , escapeF (cName c) - , "=" - , s - , " WHERE " - , escapeF (cName c) - , " IS NULL" - ] -showAlter table (AddReference reftable fkeyname t2 id2 cascade) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " ADD CONSTRAINT " - , escapeC fkeyname - , " FOREIGN KEY(" - , T.intercalate "," $ map escapeF $ NEL.toList t2 - , ") REFERENCES " - , escapeE reftable - , "(" - , T.intercalate "," id2 - , ")" - ] - <> renderFieldCascade cascade -showAlter table (DropReference cname) = - T.concat - [ "ALTER TABLE " - , escapeE table - , " DROP CONSTRAINT " - , escapeC cname - ] - -showColumn :: Column -> Text -showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = - T.concat - [ escapeF n - , " " - , showSqlType sqlType' - , " " - , if nu then "NULL" else "NOT NULL" - , case def of - Nothing -> "" - Just s -> " DEFAULT " <> s - , case gen of - Nothing -> "" - Just s -> " GENERATED ALWAYS AS (" <> s <> ") STORED" - ] - -showSqlType :: SqlType -> Text -showSqlType SqlString = "VARCHAR" -showSqlType SqlInt32 = "INT4" -showSqlType SqlInt64 = "INT8" -showSqlType SqlReal = "DOUBLE PRECISION" -showSqlType (SqlNumeric s prec) = T.concat ["NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")"] -showSqlType SqlDay = "DATE" -showSqlType SqlTime = "TIME" -showSqlType SqlDayTime = "TIMESTAMP WITH TIME ZONE" -showSqlType SqlBlob = "BYTEA" -showSqlType SqlBool = "BOOLEAN" --- Added for aliasing issues re: https://github.com/yesodweb/yesod/issues/682 -showSqlType (SqlOther (T.toLower -> "integer")) = "INT4" -showSqlType (SqlOther t) = t - -findAlters - :: [EntityDef] - -- ^ The list of all entity definitions that persistent is aware of. - -> EntityDef - -- ^ The entity definition for the entity that we're working on. - -> Column - -- ^ The column that we're searching for potential alterations for. - -> [Column] - -> ([AlterColumn], [Column]) -findAlters defs edef col@(Column name isNull sqltype def _gen _defConstraintName _maxLen ref) cols = - case List.find (\c -> cName c == name) cols of - Nothing -> - ([AddColumn col], cols) - Just - (Column _oldName isNull' sqltype' def' _gen' _defConstraintName' _maxLen' ref') -> - let - refDrop Nothing = [] - refDrop (Just ColumnReference{crConstraintName = cname}) = - [DropReference cname] - - refAdd Nothing = [] - refAdd (Just colRef) = - case find ((== crTableName colRef) . getEntityDBName) defs of - Just refdef - | Just _oldName /= fmap fieldDB (getEntityIdField edef) -> - [ AddReference - (crTableName colRef) - (crConstraintName colRef) - (name NEL.:| []) - (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef) - (crFieldCascade colRef) - ] - Just _ -> [] - Nothing -> - error $ - "could not find the entityDef for reftable[" - ++ show (crTableName colRef) - ++ "]" - modRef = - if equivalentRef ref ref' - then [] - else refDrop ref' ++ refAdd ref - modNull = case (isNull, isNull') of - (True, False) -> do - guard $ Just name /= fmap fieldDB (getEntityIdField edef) - pure (IsNull col) - (False, True) -> - let - up = case def of - Nothing -> id - Just s -> (:) (UpdateNullToValue col s) - in - up [NotNull col] - _ -> [] - modType - | sqlTypeEq sqltype sqltype' = [] - -- When converting from Persistent pre-2.0 databases, we - -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is - -- treated as UTC. - | sqltype == SqlDayTime && sqltype' == SqlOther "timestamp" = - [ ChangeType col sqltype $ - T.concat - [ " USING " - , escapeF name - , " AT TIME ZONE 'UTC'" - ] - ] - | otherwise = [ChangeType col sqltype ""] - modDef = - if def == def' - || isJust (T.stripPrefix "nextval" =<< def') - then [] - else case def of - Nothing -> [NoDefault col] - Just s -> [Default col s] - dropSafe = - if safeToRemove edef name - then error "wtf" [Drop col (SafeToRemove True)] - else [] - in - ( modRef ++ modDef ++ modNull ++ modType ++ dropSafe - , filter (\c -> cName c /= name) cols - ) - --- | Returns all of the columns in the given table currently in the database. -getColumns - :: (Text -> IO Statement) - -> EntityDef - -> [Column] - -> IO [Either Text (Either Column (ConstraintNameDB, [FieldNameDB]))] -getColumns getter def cols = do - let - sqlv = - T.concat - [ "SELECT " - , "column_name " - , ",is_nullable " - , ",COALESCE(domain_name, udt_name)" -- See DOMAINS below - , ",column_default " - , ",generation_expression " - , ",numeric_precision " - , ",numeric_scale " - , ",character_maximum_length " - , "FROM information_schema.columns " - , "WHERE table_catalog=current_database() " - , "AND table_schema=current_schema() " - , "AND table_name=? " - ] - - -- DOMAINS Postgres supports the concept of domains, which are data types - -- with optional constraints. An app might make an "email" domain over the - -- varchar type, with a CHECK that the emails are valid In this case the - -- generated SQL should use the domain name: ALTER TABLE users ALTER COLUMN - -- foo TYPE email This code exists to use the domain name (email), instead - -- of the underlying type (varchar). This is tested in - -- EquivalentTypeTest.hs - - stmt <- getter sqlv - let - vals = - [ PersistText $ unEntityNameDB $ getEntityDBName def - ] - columns <- - with - (stmtQuery stmt vals) - (\src -> runConduit $ src .| processColumns .| CL.consume) - let - sqlc = - T.concat - [ "SELECT " - , "c.constraint_name, " - , "c.column_name " - , "FROM information_schema.key_column_usage AS c, " - , "information_schema.table_constraints AS k " - , "WHERE c.table_catalog=current_database() " - , "AND c.table_catalog=k.table_catalog " - , "AND c.table_schema=current_schema() " - , "AND c.table_schema=k.table_schema " - , "AND c.table_name=? " - , "AND c.table_name=k.table_name " - , "AND c.constraint_name=k.constraint_name " - , "AND NOT k.constraint_type IN ('PRIMARY KEY', 'FOREIGN KEY') " - , "ORDER BY c.constraint_name, c.column_name" - ] - - stmt' <- getter sqlc - - us <- with (stmtQuery stmt' vals) (\src -> runConduit $ src .| helperU) - return $ columns ++ us - where - refMap = - fmap (\cr -> (crTableName cr, crConstraintName cr)) $ - Map.fromList $ - List.foldl' ref [] cols - where - ref rs c = - maybe rs (\r -> (unFieldNameDB $ cName c, r) : rs) (cReference c) - getAll = - CL.mapM $ \x -> - pure $ case x of - [PersistText con, PersistText col] -> - (con, col) - [PersistByteString con, PersistByteString col] -> - (T.decodeUtf8 con, T.decodeUtf8 col) - o -> - error $ "unexpected datatype returned for postgres o=" ++ show o - helperU = do - rows <- getAll .| CL.consume - return - $ map - (Right . Right . (ConstraintNameDB . fst . head &&& map (FieldNameDB . snd))) - $ groupBy ((==) `on` fst) rows - processColumns = - CL.mapM $ \x'@((PersistText cname) : _) -> do - col <- - liftIO $ getColumn getter (getEntityDBName def) x' (Map.lookup cname refMap) - pure $ case col of - Left e -> Left e - Right c -> Right $ Left c - -getColumn - :: (Text -> IO Statement) - -> EntityNameDB - -> [PersistValue] - -> Maybe (EntityNameDB, ConstraintNameDB) - -> IO (Either Text Column) -getColumn - getter - tableName' - [ PersistText columnName - , PersistText isNullable - , PersistText typeName - , defaultValue - , generationExpression - , numericPrecision - , numericScale - , maxlen - ] - refName_ = runExceptT $ do - defaultValue' <- - case defaultValue of - PersistNull -> - pure Nothing - PersistText t -> - pure $ Just t - _ -> - throwError $ T.pack $ "Invalid default column: " ++ show defaultValue - - generationExpression' <- - case generationExpression of - PersistNull -> - pure Nothing - PersistText t -> - pure $ Just t - _ -> - throwError $ T.pack $ "Invalid generated column: " ++ show generationExpression - - let - typeStr = - case maxlen of - PersistInt64 n -> - T.concat [typeName, "(", T.pack (show n), ")"] - _ -> - typeName - - t <- getType typeStr - - let - cname = FieldNameDB columnName - - ref <- lift $ fmap join $ traverse (getRef cname) refName_ - - return - Column - { cName = cname - , cNull = isNullable == "YES" - , cSqlType = t - , cDefault = fmap stripSuffixes defaultValue' - , cGenerated = fmap stripSuffixes generationExpression' - , cDefaultConstraintName = Nothing - , cMaxLen = Nothing - , cReference = fmap (\(a, b, c, d) -> ColumnReference a b (mkCascade c d)) ref - } - where - mkCascade updText delText = - FieldCascade - { fcOnUpdate = parseCascade updText - , fcOnDelete = parseCascade delText - } - - parseCascade txt = - case txt of - "NO ACTION" -> - Nothing - "CASCADE" -> - Just Cascade - "SET NULL" -> - Just SetNull - "SET DEFAULT" -> - Just SetDefault - "RESTRICT" -> - Just Restrict - _ -> - error $ "Unexpected value in parseCascade: " <> show txt - - stripSuffixes t = - loop' - [ "::character varying" - , "::text" - ] - where - loop' [] = t - loop' (p : ps) = - case T.stripSuffix p t of - Nothing -> loop' ps - Just t' -> t' - - getRef cname (_, refName') = do - let - sql = - T.concat - [ "SELECT DISTINCT " - , "ccu.table_name, " - , "tc.constraint_name, " - , "rc.update_rule, " - , "rc.delete_rule " - , "FROM information_schema.constraint_column_usage ccu " - , "INNER JOIN information_schema.key_column_usage kcu " - , " ON ccu.constraint_name = kcu.constraint_name " - , "INNER JOIN information_schema.table_constraints tc " - , " ON tc.constraint_name = kcu.constraint_name " - , "LEFT JOIN information_schema.referential_constraints AS rc" - , " ON rc.constraint_name = ccu.constraint_name " - , "WHERE tc.constraint_type='FOREIGN KEY' " - , "AND kcu.ordinal_position=1 " - , "AND kcu.table_name=? " - , "AND kcu.column_name=? " - , "AND tc.constraint_name=?" - ] - stmt <- getter sql - cntrs <- - with - ( stmtQuery - stmt - [ PersistText $ unEntityNameDB tableName' - , PersistText $ unFieldNameDB cname - , PersistText $ unConstraintNameDB refName' - ] - ) - (\src -> runConduit $ src .| CL.consume) - case cntrs of - [] -> - return Nothing - [ [ PersistText table - , PersistText constraint - , PersistText updRule - , PersistText delRule - ] - ] -> - return $ - Just (EntityNameDB table, ConstraintNameDB constraint, updRule, delRule) - xs -> - error $ - mconcat - [ "Postgresql.getColumn: error fetching constraints. Expected a single result for foreign key query for table: " - , T.unpack (unEntityNameDB tableName') - , " and column: " - , T.unpack (unFieldNameDB cname) - , " but got: " - , show xs - ] - - getType "int4" = pure SqlInt32 - getType "int8" = pure SqlInt64 - getType "varchar" = pure SqlString - getType "text" = pure SqlString - getType "date" = pure SqlDay - getType "bool" = pure SqlBool - getType "timestamptz" = pure SqlDayTime - getType "float4" = pure SqlReal - getType "float8" = pure SqlReal - getType "bytea" = pure SqlBlob - getType "time" = pure SqlTime - getType "numeric" = getNumeric numericPrecision numericScale - getType a = pure $ SqlOther a - - getNumeric (PersistInt64 a) (PersistInt64 b) = - pure $ SqlNumeric (fromIntegral a) (fromIntegral b) - getNumeric PersistNull PersistNull = - throwError $ - T.concat - [ "No precision and scale were specified for the column: " - , columnName - , " in table: " - , unEntityNameDB tableName' - , ". Postgres defaults to a maximum scale of 147,455 and precision of 16383," - , " which is probably not what you intended." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] - getNumeric a b = - throwError $ - T.concat - [ "Can not get numeric field precision for the column: " - , columnName - , " in table: " - , unEntityNameDB tableName' - , ". Expected an integer for both precision and scale, " - , "got: " - , T.pack $ show a - , " and " - , T.pack $ show b - , ", respectively." - , " Specify the values as numeric(total_digits, digits_after_decimal_place)." - ] -getColumn _ _ columnName _ = - return $ - Left $ - T.pack $ - "Invalid result from information_schema: " ++ show columnName - -doesTableExist - :: (Text -> IO Statement) - -> EntityNameDB - -> IO Bool -doesTableExist getter (EntityNameDB name) = do - stmt <- getter sql - with (stmtQuery stmt vals) (\src -> runConduit $ src .| start) - where - sql = - "SELECT COUNT(*) FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'" - <> " AND schemaname != 'information_schema' AND tablename=?" - vals = [PersistText name] - - start = await >>= maybe (error "No results when checking doesTableExist") start' - start' [PersistInt64 0] = finish False - start' [PersistInt64 1] = finish True - start' res = error $ "doesTableExist returned unexpected result: " ++ show res - finish x = await >>= maybe (return x) (error "Too many rows returned in doesTableExist") +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Database.Persist.Postgresql.Internal + ( P (..) + , PgInterval (..) + , getGetter + , AlterDB (..) + , AlterTable (..) + , AlterColumn (..) + , SafeToRemove + , migrateStructured + , migrateEntitiesStructured + , mockMigrateStructured + , addTable + , findAlters + , maySerial + , mayDefault + , showSqlType + , showColumn + , showAlter + , showAlterDb + , showAlterTable + , getAddReference + , udToPair + , safeToRemove + , postgresMkColumns + , getAlters + , escapeE + , escapeF + , escape + ) where + +import qualified Database.PostgreSQL.Simple as PG +import qualified Database.PostgreSQL.Simple.FromField as PGFF +import qualified Database.PostgreSQL.Simple.Internal as PG +import qualified Database.PostgreSQL.Simple.Interval as Interval +import qualified Database.PostgreSQL.Simple.ToField as PGTF +import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS +import qualified Database.PostgreSQL.Simple.Types as PG + +import qualified Blaze.ByteString.Builder.Char8 as BBB +import Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString.Builder as BB +import Data.Fixed (Pico) +import qualified Data.IntMap as I +import Data.Maybe +import Data.Time + ( NominalDiffTime + , localTimeToUTC + , utc + ) +import Database.Persist.Postgresql.Internal.Migration +import Database.Persist.Sql + +-- | Newtype used to avoid orphan instances for @postgresql-simple@ classes. +-- +-- @since 2.13.2.0 +newtype P = P {unP :: PersistValue} + +instance PGTF.ToField P where + toField (P (PersistText t)) = PGTF.toField t + toField (P (PersistByteString bs)) = PGTF.toField (PG.Binary bs) + toField (P (PersistInt64 i)) = PGTF.toField i + toField (P (PersistDouble d)) = PGTF.toField d + toField (P (PersistRational r)) = + PGTF.Plain $ + BBB.fromString $ + show (fromRational r :: Pico) -- FIXME: Too Ambigous, can not select precision without information about field + toField (P (PersistBool b)) = PGTF.toField b + toField (P (PersistDay d)) = PGTF.toField d + toField (P (PersistTimeOfDay t)) = PGTF.toField t + toField (P (PersistUTCTime t)) = PGTF.toField t + toField (P PersistNull) = PGTF.toField PG.Null + toField (P (PersistList l)) = PGTF.toField $ listToJSON l + toField (P (PersistMap m)) = PGTF.toField $ mapToJSON m + toField (P (PersistLiteral_ DbSpecific s)) = PGTF.toField (Unknown s) + toField (P (PersistLiteral_ Unescaped l)) = PGTF.toField (UnknownLiteral l) + toField (P (PersistLiteral_ Escaped e)) = PGTF.toField (Unknown e) + toField (P (PersistArray a)) = PGTF.toField $ PG.PGArray $ P <$> a + toField (P (PersistObjectId _)) = + error "Refusing to serialize a PersistObjectId to a PostgreSQL value" + +instance PGFF.FromField P where + fromField field mdata = fmap P $ case mdata of + -- If we try to simply decode based on oid, we will hit unexpected null + -- errors. + Nothing -> pure PersistNull + data' -> getGetter (PGFF.typeOid field) field data' + +newtype Unknown = Unknown {unUnknown :: ByteString} + deriving (Eq, Show, Read, Ord) + +instance PGFF.FromField Unknown where + fromField f mdata = + case mdata of + Nothing -> + PGFF.returnError + PGFF.UnexpectedNull + f + "Database.Persist.Postgresql/PGFF.FromField Unknown" + Just dat -> return (Unknown dat) + +instance PGTF.ToField Unknown where + toField (Unknown a) = PGTF.Escape a + +newtype UnknownLiteral = UnknownLiteral {unUnknownLiteral :: ByteString} + deriving (Eq, Show, Read, Ord) + +instance PGFF.FromField UnknownLiteral where + fromField f mdata = + case mdata of + Nothing -> + PGFF.returnError + PGFF.UnexpectedNull + f + "Database.Persist.Postgresql/PGFF.FromField UnknownLiteral" + Just dat -> return (UnknownLiteral dat) + +instance PGTF.ToField UnknownLiteral where + toField (UnknownLiteral a) = PGTF.Plain $ BB.byteString a + +type Getter a = PGFF.FieldParser a + +convertPV :: (PGFF.FromField a) => (a -> b) -> Getter b +convertPV f = (fmap f .) . PGFF.fromField + +builtinGetters :: I.IntMap (Getter PersistValue) +builtinGetters = + I.fromList + [ (k PS.bool, convertPV PersistBool) + , (k PS.bytea, convertPV (PersistByteString . unBinary)) + , (k PS.char, convertPV PersistText) + , (k PS.name, convertPV PersistText) + , (k PS.int8, convertPV PersistInt64) + , (k PS.int2, convertPV PersistInt64) + , (k PS.int4, convertPV PersistInt64) + , (k PS.text, convertPV PersistText) + , (k PS.xml, convertPV (PersistByteString . unUnknown)) + , (k PS.float4, convertPV PersistDouble) + , (k PS.float8, convertPV PersistDouble) + , (k PS.money, convertPV PersistRational) + , (k PS.bpchar, convertPV PersistText) + , (k PS.varchar, convertPV PersistText) + , (k PS.date, convertPV PersistDay) + , (k PS.time, convertPV PersistTimeOfDay) + , (k PS.timestamp, convertPV (PersistUTCTime . localTimeToUTC utc)) + , (k PS.timestamptz, convertPV PersistUTCTime) + , (k PS.interval, convertPV $ toPersistValue @Interval.Interval) + , (k PS.bit, convertPV PersistInt64) + , (k PS.varbit, convertPV PersistInt64) + , (k PS.numeric, convertPV PersistRational) + , (k PS.void, \_ _ -> return PersistNull) + , (k PS.json, convertPV (PersistByteString . unUnknown)) + , (k PS.jsonb, convertPV (PersistByteString . unUnknown)) + , (k PS.unknown, convertPV (PersistByteString . unUnknown)) + , -- Array types: same order as above. + -- The OIDs were taken from pg_type. + (1000, listOf PersistBool) + , (1001, listOf (PersistByteString . unBinary)) + , (1002, listOf PersistText) + , (1003, listOf PersistText) + , (1016, listOf PersistInt64) + , (1005, listOf PersistInt64) + , (1007, listOf PersistInt64) + , (1009, listOf PersistText) + , (143, listOf (PersistByteString . unUnknown)) + , (1021, listOf PersistDouble) + , (1022, listOf PersistDouble) + , (1023, listOf PersistUTCTime) + , (1024, listOf PersistUTCTime) + , (791, listOf PersistRational) + , (1014, listOf PersistText) + , (1015, listOf PersistText) + , (1182, listOf PersistDay) + , (1183, listOf PersistTimeOfDay) + , (1115, listOf PersistUTCTime) + , (1185, listOf PersistUTCTime) + , (1187, listOf $ toPersistValue @Interval.Interval) + , (1561, listOf PersistInt64) + , (1563, listOf PersistInt64) + , (1231, listOf PersistRational) + , -- no array(void) type + (2951, listOf (PersistLiteralEscaped . unUnknown)) + , (199, listOf (PersistByteString . unUnknown)) + , (3807, listOf (PersistByteString . unUnknown)) + -- no array(unknown) either + ] + where + k (PGFF.typoid -> i) = PG.oid2int i + -- A @listOf f@ will use a @PGArray (Maybe T)@ to convert + -- the values to Haskell-land. The @Maybe@ is important + -- because the usual way of checking NULLs + -- (c.f. withStmt') won't check for NULL inside + -- arrays---or any other compound structure for that matter. + listOf f = convertPV (PersistList . map (nullable f) . PG.fromPGArray) + where + nullable = maybe PersistNull + +-- | Get the field parser corresponding to the given 'PG.Oid'. +-- +-- For example, pass in the 'PG.Oid' of 'PS.bool', and you will get back a +-- field parser which parses boolean values in the table into 'PersistBool's. +-- +-- @since 2.13.2.0 +getGetter :: PG.Oid -> Getter PersistValue +getGetter oid = + fromMaybe defaultGetter $ I.lookup (PG.oid2int oid) builtinGetters + where + defaultGetter = convertPV (PersistLiteralEscaped . unUnknown) + +unBinary :: PG.Binary a -> a +unBinary (PG.Binary x) = x + +-- | Represent Postgres interval using NominalDiffTime +-- +-- Note that this type cannot be losslessly round tripped through PostgreSQL. +-- For example the value @'PgInterval' 0.0000009@ will truncate extra +-- precision. And the value @'PgInterval' 9223372036854.775808@ will overflow. +-- Use the 'Interval.Interval' type if that is a problem for you. +-- +-- @since 2.11.0.0 +newtype PgInterval = PgInterval {getPgInterval :: NominalDiffTime} + deriving (Eq, Show) + +instance PGTF.ToField PgInterval where + toField = PGTF.toField . pgIntervalToInterval + +instance PGFF.FromField PgInterval where + fromField f = + maybe (PGFF.returnError PGFF.ConversionFailed f "invalid interval") pure + . intervalToPgInterval + <=< PGFF.fromField f + +instance PersistField PgInterval where + toPersistValue = + toPersistValue + . pgIntervalToInterval + fromPersistValue = + maybe (Left "invalid interval") pure + . intervalToPgInterval + <=< fromPersistValue + +instance PersistFieldSql PgInterval where + sqlType _ = SqlOther "interval" + +pgIntervalToInterval :: PgInterval -> Interval.Interval +pgIntervalToInterval = + Interval.fromTimeSaturating mempty + . getPgInterval + +intervalToPgInterval :: Interval.Interval -> Maybe PgInterval +intervalToPgInterval interval = + let + (calendarDiffDays, nominalDiffTime) = Interval.intoTime interval + in + if calendarDiffDays == mempty + then Just $ PgInterval nominalDiffTime + else Nothing diff --git a/Database/Persist/Postgresql/Internal/Migration.hs b/Database/Persist/Postgresql/Internal/Migration.hs new file mode 100644 --- /dev/null +++ b/Database/Persist/Postgresql/Internal/Migration.hs @@ -0,0 +1,1191 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Generate postgresql migrations for a set of EntityDefs, either from scratch +-- or based on the current state of a database. +module Database.Persist.Postgresql.Internal.Migration where + +import Control.Arrow +import Control.Monad +import Control.Monad.Except +import Control.Monad.IO.Class +import Data.Acquire (with) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Either (partitionEithers) +import Data.FileEmbed (embedFileRelative) +import Data.List as List +import qualified Data.List.NonEmpty as NEL +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Traversable +import Database.Persist.Sql +import qualified Database.Persist.Sql.Util as Util + +-- | Returns a structured representation of all of the +-- DB changes required to migrate the Entity from its +-- current state in the database to the state described in +-- Haskell. +-- +-- @since 2.17.1.0 +migrateStructured + :: BackendSpecificOverrides + -> [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [AlterDB]) +migrateStructured overrides allDefs getter entity = + migrateEntitiesStructured overrides getter allDefs [entity] + +-- | Returns a structured representation of all of the DB changes required to +-- migrate the listed entities from their current state in the database to the +-- state described in Haskell. This function avoids N+1 queries, so if you +-- have a lot of entities to migrate, it's much faster to use this rather than +-- using 'migrateStructured' in a loop. +-- +-- @since 2.14.1.0 +migrateEntitiesStructured + :: BackendSpecificOverrides + -> (Text -> IO Statement) + -> [EntityDef] + -> [EntityDef] + -> IO (Either [Text] [AlterDB]) +migrateEntitiesStructured overrides getStmt allDefs defsToMigrate = do + r <- collectSchemaState getStmt (map getEntityDBName defsToMigrate) + pure $ case r of + Right schemaState -> + migrateEntitiesFromSchemaState overrides schemaState allDefs defsToMigrate + Left err -> + Left [err] + +-- | Returns a structured representation of all of the +-- DB changes required to migrate the Entity to the state +-- described in Haskell, assuming it currently does not +-- exist in the database. +-- +-- @since 2.17.1.0 +mockMigrateStructured + :: BackendSpecificOverrides + -> [EntityDef] + -> EntityDef + -> [AlterDB] +mockMigrateStructured overrides allDefs entity = + migrateEntityFromSchemaState overrides EntityDoesNotExist allDefs entity + +-- | In order to ensure that generating migrations is fast and avoids N+1 +-- queries, we split it into two phases. The first phase involves querying the +-- database to gather all of the information we need about the existing schema. +-- The second phase then generates migrations based on the information from the +-- first phase. This data type represents all of the data that's gathered during +-- the first phase: information about the current state of the entities we're +-- migrating in the database. +newtype SchemaState = SchemaState (Map EntityNameDB EntitySchemaState) + deriving (Eq, Show) + +-- | The state of a particular entity (i.e. table) in the database; we generate +-- migrations based on the diff of this versus an EntityDef. +data EntitySchemaState + = -- | The table does not exist in the database + EntityDoesNotExist + | -- | The table does exist in the database + EntityExists ExistingEntitySchemaState + deriving (Eq, Show) + +-- | Information about an existing table in the database +data ExistingEntitySchemaState = ExistingEntitySchemaState + { essColumns :: Map FieldNameDB (Column, (Set ColumnReference)) + -- ^ The columns in this entity, together with the set of foreign key + -- constraints that they are subject to. Usually the ColumnReference list + -- will contain 0-1 elements, but in the event that there are multiple FK + -- constraints applying to a given column in the database we need to keep + -- track of them all because we don't yet know which one has the right name + -- (based on what is in the corresponding model's EntityDef). + -- + -- Note that cReference will be unset for these columns, for the same reason: + -- there may be multiple FK constraints and we don't yet know which one to + -- use. + , essUniqueConstraints :: Map ConstraintNameDB [FieldNameDB] + -- ^ A map of unique constraint names to the columns that are affected by + -- those constraints. + } + deriving (Eq, Show) + +-- | Query a database in order to assemble a SchemaState containing information +-- about each of the entities in the given list. Every entity name in the input +-- should be present in the returned Map. +collectSchemaState + :: (Text -> IO Statement) -> [EntityNameDB] -> IO (Either Text SchemaState) +collectSchemaState getStmt entityNames = runExceptT $ do + existence <- getTableExistence getStmt entityNames + columns <- getColumnsWithoutReferences getStmt entityNames + constraints <- getConstraints getStmt entityNames + foreignKeyReferences <- getForeignKeyReferences getStmt entityNames + + fmap (SchemaState . Map.fromList) $ + for entityNames $ \entityNameDB -> do + tableExists <- case Map.lookup entityNameDB existence of + Just e -> pure e + Nothing -> + throwError + ("Missing entity name from existence map: " <> unEntityNameDB entityNameDB) + + if tableExists + then do + essColumns <- case Map.lookup entityNameDB columns of + Just cols -> + pure $ Map.fromList $ flip map cols $ \c -> + ( cName c + , + ( c + , fromMaybe Set.empty $ + Map.lookup (cName c) =<< Map.lookup entityNameDB foreignKeyReferences + ) + ) + Nothing -> + throwError + ("Missing entity name from columns map: " <> unEntityNameDB entityNameDB) + + let + essUniqueConstraints = fromMaybe Map.empty (Map.lookup entityNameDB constraints) + pure + ( entityNameDB + , EntityExists $ ExistingEntitySchemaState{essColumns, essUniqueConstraints} + ) + else + pure + ( entityNameDB + , EntityDoesNotExist + ) + +runStmt + :: (Show a) + => (Text -> IO Statement) + -> Text + -> [PersistValue] + -> ([PersistValue] -> a) + -> IO [a] +runStmt getStmt sql values process = do + stmt <- getStmt sql + results <- + with + (stmtQuery stmt values) + (\src -> runConduit $ src .| CL.map process .| CL.consume) + pure results + +-- | Check for the existence of each of the input tables. The keys in the +-- returned Map are exactly the entity names in the argument; True means the +-- table exists. +getTableExistence + :: (Text -> IO Statement) + -> [EntityNameDB] + -> ExceptT Text IO (Map EntityNameDB Bool) +getTableExistence getStmt entityNames = do + results <- + liftIO $ + runStmt + getStmt + getTableExistenceSql + [PersistArray (map (PersistText . unEntityNameDB) entityNames)] + processTable + case partitionEithers results of + ([], xs) -> + let + existing = Set.fromList xs + in + pure $ Map.fromList $ map (\n -> (n, Set.member n existing)) entityNames + (errs, _) -> throwError (T.intercalate "\n" errs) + where + getTableExistenceSql = + "SELECT tablename FROM pg_catalog.pg_tables WHERE schemaname != 'pg_catalog'" + <> " AND schemaname != 'information_schema' AND tablename=ANY (?)" + + processTable :: [PersistValue] -> Either Text EntityNameDB + processTable resultRow = do + fmap EntityNameDB $ + case resultRow of + [PersistText tableName] -> + pure tableName + [PersistByteString tableName] -> + pure (T.decodeUtf8 tableName) + other -> + throwError $ T.pack $ "Invalid result from information_schema: " ++ show other + +-- | Get all columns for the listed tables from the database, ignoring foreign +-- key references (those are filled in later). +getColumnsWithoutReferences + :: (Text -> IO Statement) + -> [EntityNameDB] + -> ExceptT Text IO (Map EntityNameDB [Column]) +getColumnsWithoutReferences getStmt entityNames = do + results <- + liftIO $ + runStmt + getStmt + getColumnsSql + [PersistArray (map (PersistText . unEntityNameDB) entityNames)] + processColumn + case partitionEithers results of + ([], xs) -> pure $ Map.fromListWith (++) $ map (second (: [])) xs + (errs, _) -> throwError (T.intercalate "\n" errs) + where + getColumnsSql = + T.concat + [ "SELECT " + , "table_name " + , ",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=ANY (?) " + ] + + -- 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 + processColumn :: [PersistValue] -> Either Text (EntityNameDB, Column) + processColumn resultRow = do + case resultRow of + [ PersistText tableName + , PersistText columnName + , PersistText isNullable + , PersistText typeName + , defaultValue + , generationExpression + , numericPrecision + , numericScale + , maxlen + ] -> mapLeft (addErrorContext tableName columnName) $ 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 numericPrecision numericScale typeStr + + pure + ( EntityNameDB tableName + , Column + { cName = FieldNameDB columnName + , cNull = isNullable == "YES" + , cSqlType = t + , cDefault = fmap stripSuffixes defaultValue' + , cGenerated = fmap stripSuffixes generationExpression' + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + ) + other -> + Left $ + T.pack $ + "Invalid result from information_schema: " ++ show other + + stripSuffixes t = + loop' + [ "::character varying" + , "::text" + ] + where + loop' [] = t + loop' (p : ps) = + case T.stripSuffix p t of + Nothing -> loop' ps + Just t' -> t' + + 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 precision scale "numeric" = getNumeric precision scale + 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. " + , "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. " + , "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)." + ] + +-- cyclist putting a stick into his own wheel meme +addErrorContext :: Text -> Text -> Text -> Text +addErrorContext tableName columnName originalMsg = + T.concat + [ "Error in column " + , tableName + , "." + , columnName + , ": " + , originalMsg + ] + +-- | Get all constraints for the listed tables from the database, except for foreign +-- keys and primary keys (those go in the Column data type) +getConstraints + :: (Text -> IO Statement) + -> [EntityNameDB] + -> ExceptT Text IO (Map EntityNameDB (Map ConstraintNameDB [FieldNameDB])) +getConstraints getStmt entityNames = do + results <- + liftIO $ + runStmt + getStmt + getConstraintsSql + [PersistArray (map (PersistText . unEntityNameDB) entityNames)] + processConstraint + case partitionEithers results of + ([], xs) -> pure $ Map.unionsWith (Map.unionWith (<>)) xs + (errs, _) -> throwError (T.intercalate "\n" errs) + where + getConstraintsSql = + T.concat + [ "SELECT " + , "c.table_name, " + , "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=ANY (?) " + , "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" + ] + + processConstraint + :: [PersistValue] + -> Either Text (Map EntityNameDB (Map ConstraintNameDB [FieldNameDB])) + processConstraint resultRow = do + (tableName, constraintName, columnName) <- case resultRow of + [PersistText tab, PersistText con, PersistText col] -> + pure (tab, con, col) + [PersistByteString tab, PersistByteString con, PersistByteString col] -> + pure (T.decodeUtf8 tab, T.decodeUtf8 con, T.decodeUtf8 col) + o -> + throwError $ T.pack $ "unexpected datatype returned for postgres o=" ++ show o + + pure $ + Map.singleton + (EntityNameDB tableName) + (Map.singleton (ConstraintNameDB constraintName) [FieldNameDB columnName]) + +-- | Get foreign key constraint information for all columns in the supplied +-- tables from the database. We return a list of references per column because +-- there may be duplicate FK constraints in the database. +-- +-- Note that we only care about FKs where the column in question has ordinal +-- position 1 i.e. is the first column appearing in the FK constraint. +-- Eventually we may want to fill this gap so that multi-column FK constraints +-- can be dealt with by this migrator, but for now that is not something that +-- persistent-postgresql handles. +getForeignKeyReferences + :: (Text -> IO Statement) + -> [EntityNameDB] + -> ExceptT Text IO (Map EntityNameDB (Map FieldNameDB (Set ColumnReference))) +getForeignKeyReferences getStmt entityNames = do + results <- + liftIO $ + runStmt + getStmt + getForeignKeyReferencesSql + [PersistArray (map (PersistText . unEntityNameDB) entityNames)] + processForeignKeyReference + case partitionEithers results of + ([], xs) -> pure $ Map.unionsWith (Map.unionWith Set.union) xs + (errs, _) -> throwError (T.intercalate "\n" errs) + where + getForeignKeyReferencesSql = T.decodeUtf8 $(embedFileRelative "sql/getForeignKeyReferences.sql") + + processForeignKeyReference + :: [PersistValue] + -> Either Text (Map EntityNameDB (Map FieldNameDB (Set ColumnReference))) + processForeignKeyReference resultRow = do + ( sourceTableName + , sourceColumnName + , refTableName + , constraintName + , updRule + , delRule + ) <- + case resultRow of + [ PersistText constrName + , PersistText srcTable + , PersistText refTable + , PersistText srcColumn + , PersistText _refColumn + , PersistText updRule + , PersistText delRule + ] -> + pure + ( EntityNameDB srcTable + , FieldNameDB srcColumn + , EntityNameDB refTable + , ConstraintNameDB constrName + , updRule + , delRule + ) + other -> + throwError $ T.pack $ "unexpected row returned for postgres: " ++ show other + + fcOnUpdate <- parseCascade updRule + fcOnDelete <- parseCascade delRule + + let + columnRef = + ColumnReference + { crTableName = refTableName + , crConstraintName = constraintName + , crFieldCascade = + FieldCascade + { fcOnUpdate = Just fcOnUpdate + , fcOnDelete = Just fcOnDelete + } + } + + pure $ + Map.singleton + sourceTableName + (Map.singleton sourceColumnName (Set.singleton columnRef)) + +-- Parse a cascade action as represented in pg_constraint +parseCascade :: Text -> Either Text CascadeAction +parseCascade txt = + case txt of + "a" -> + Right NoAction + "c" -> + Right Cascade + "n" -> + Right SetNull + "d" -> + Right SetDefault + "r" -> + Right Restrict + _ -> + Left $ "Unexpected value in parseCascade: " <> txt + +mapLeft :: (a1 -> a2) -> Either a1 b -> Either a2 b +mapLeft _ (Right x) = Right x +mapLeft f (Left x) = Left (f x) + +migrateEntitiesFromSchemaState + :: BackendSpecificOverrides + -> SchemaState + -> [EntityDef] + -> [EntityDef] + -> Either [Text] [AlterDB] +migrateEntitiesFromSchemaState overrides (SchemaState schemaStateMap) allDefs defsToMigrate = + let + go :: EntityDef -> Either Text [AlterDB] + go entity = do + let + name = getEntityDBName entity + case Map.lookup name schemaStateMap of + Just entityState -> + Right $ migrateEntityFromSchemaState overrides entityState allDefs entity + Nothing -> + Left $ T.pack $ "No entry for entity in schemaState: " <> show name + in + case partitionEithers (map go defsToMigrate) of + ([], xs) -> Right (concat xs) + (errs, _) -> Left errs + +migrateEntityFromSchemaState + :: BackendSpecificOverrides + -> EntitySchemaState + -> [EntityDef] + -> EntityDef + -> [AlterDB] +migrateEntityFromSchemaState overrides schemaState allDefs entity = + case schemaState of + EntityDoesNotExist -> + (addTable newcols entity) : uniques ++ references ++ foreignsAlt + EntityExists ExistingEntitySchemaState{essColumns, essUniqueConstraints} -> + let + (acs, ats) = + getAlters + allDefs + entity + (newcols, udspair) + ( map pickColumnReference (Map.elems essColumns) + , Map.toList essUniqueConstraints + ) + acs' = map (AlterColumn name) acs + ats' = map (AlterTable name) ats + in + acs' ++ ats' + where + name = getEntityDBName entity + (newcols', udefs, fdefs) = postgresMkColumns overrides allDefs entity + newcols = filter (not . safeToRemove entity . cName) newcols' + udspair = map udToPair udefs + + 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 + + -- HACK! This was added to preserve existing behaviour during a refactor. + -- The migrator currently expects to only see cReference set in the old + -- columns if it is also set in the new ones. It also ignores any existing + -- FK constraints in the database that don't match the expected FK + -- constraint name as defined by the Persistent EntityDef. + -- + -- This means that the migrator sometimes behaves incorrectly for standalone + -- Foreign declarations, like Child in the ForeignKey test in + -- persistent-test, as well as in situations where there are duplicate FK + -- constraints for a given column. + -- + -- See https://github.com/yesodweb/persistent/issues/1611#issuecomment-3613251095 for + -- more info + pickColumnReference (oldCol, oldReferences) = + case List.find (\c -> cName c == cName oldCol) newcols of + Just new -> fromMaybe oldCol $ do + -- Note that if this do block evaluates to Nothing, it means + -- we'll return a Column that has cReference = Nothing - + -- effectively, we are telling the migrator that this particular + -- column has no FK constraints in the DB. + + -- If the persistent models don't define a FK constraint, ignore + -- any FK constraints that might exist in the DB (this is + -- arguably a bug, but it's a pre-existing one) + newRef <- cReference new + + -- If the persistent models _do_ define an FK constraint but + -- there's no matching FK constraint in the DB, we don't have + -- to do anything else here: `getAlters` should handle adding + -- the FK constraint for us + oldRef <- + List.find + (\oldRef -> crConstraintName oldRef == crConstraintName newRef) + oldReferences + + -- Finally, if the persistent models define an FK constraint and + -- an FK constraint of that name exists in the DB, return it, so + -- that `getAlters` can check that the constraint is set up + -- correctly + pure $ oldCol{cReference = Just oldRef} + Nothing -> + -- We have a column that exists in the DB but not in the + -- EntityDef. We can no-op here, since `getAlters` will handle + -- dropping this for us. + oldCol + +-- | Indicates whether a Postgres Column is safe to drop. +-- +-- @since 2.17.1.0 +newtype SafeToRemove = SafeToRemove Bool + deriving (Show, Eq) + +-- | Represents a change to a Postgres column in a DB statement. +-- +-- @since 2.17.1.0 +data AlterColumn + = ChangeType Column SqlType Text + | IsNull Column + | NotNull Column + | AddColumn Column + | Drop Column SafeToRemove + | Default Column Text + | NoDefault Column + | UpdateNullToValue Column Text + | AddReference + EntityNameDB + ConstraintNameDB + (NEL.NonEmpty FieldNameDB) + [Text] + FieldCascade + | DropReference ConstraintNameDB + deriving (Show, Eq) + +-- | Represents a change to a Postgres table in a DB statement. +-- +-- @since 2.17.1.0 +data AlterTable + = AddUniqueConstraint ConstraintNameDB [FieldNameDB] + | DropConstraint ConstraintNameDB + deriving (Show, Eq) + +-- | Represents a change to a Postgres DB in a statement. +-- +-- @since 2.17.1.0 +data AlterDB + = AddTable EntityNameDB EntityIdDef [Column] + | AlterColumn EntityNameDB AlterColumn + | AlterTable EntityNameDB AlterTable + deriving (Show, Eq) + +-- | Create a table if it doesn't exist. +-- +-- @since 2.17.1.0 +addTable :: [Column] -> EntityDef -> AlterDB +addTable cols entity = + AddTable name entityId nonIdCols + where + nonIdCols = + case entityPrimary entity of + Just _ -> + cols + _ -> + filter keepField cols + where + keepField c = + Just (cName c) /= fmap fieldDB (getEntityIdField entity) + && not (safeToRemove entity (cName c)) + entityId = getEntityId entity + name = getEntityDBName entity + +maySerial :: SqlType -> Maybe Text -> Text +maySerial SqlInt64 Nothing = " SERIAL8 " +maySerial sType _ = " " <> showSqlType sType + +mayDefault :: Maybe Text -> Text +mayDefault def = case def of + Nothing -> "" + Just d -> " DEFAULT " <> d + +getAlters + :: [EntityDef] + -> EntityDef + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([Column], [(ConstraintNameDB, [FieldNameDB])]) + -> ([AlterColumn], [AlterTable]) +getAlters defs def (c1, u1) (c2, u2) = + (getAltersC c1 c2, getAltersU u1 u2) + where + getAltersC [] old = + map (\x -> Drop x $ SafeToRemove $ safeToRemove def $ cName x) old + getAltersC (new : news) old = + let + (alters, old') = findAlters defs def new old + in + alters ++ getAltersC news old' + + getAltersU + :: [(ConstraintNameDB, [FieldNameDB])] + -> [(ConstraintNameDB, [FieldNameDB])] + -> [AlterTable] + getAltersU [] old = + map DropConstraint $ filter (not . isManual) $ map fst old + getAltersU ((name, cols) : news) old = + case lookup name old of + Nothing -> + AddUniqueConstraint name cols : getAltersU news old + Just ocols -> + let + old' = filter (\(x, _) -> x /= name) old + in + if sort cols == sort ocols + then getAltersU news old' + else + DropConstraint name + : AddUniqueConstraint name cols + : getAltersU news old' + + -- Don't drop constraints which were manually added. + isManual (ConstraintNameDB x) = "__manual_" `T.isPrefixOf` x + +-- | Postgres' default maximum identifier length in bytes +-- (You can re-compile Postgres with a new limit, but I'm assuming that virtually noone does this). +-- See https://www.postgresql.org/docs/11/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS +maximumIdentifierLength :: Int +maximumIdentifierLength = 63 + +-- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer +sqlTypeEq :: SqlType -> SqlType -> Bool +sqlTypeEq x y = + let + -- Non exhaustive helper to map postgres aliases to the same name. Based on + -- https://www.postgresql.org/docs/9.5/datatype.html. + -- This prevents needless `ALTER TYPE`s when the type is the same. + normalize "int8" = "bigint" + normalize "serial8" = "bigserial" + normalize v = v + in + normalize (T.toCaseFold (showSqlType x)) + == normalize (T.toCaseFold (showSqlType y)) + +-- We check if we should alter a foreign key. This is almost an equality check, +-- except we consider 'Nothing' and 'Just Restrict' equivalent. +equivalentRef :: Maybe ColumnReference -> Maybe ColumnReference -> Bool +equivalentRef Nothing Nothing = True +equivalentRef (Just cr1) (Just cr2) = + crTableName cr1 == crTableName cr2 + && crConstraintName cr1 == crConstraintName cr2 + && eqCascade (fcOnUpdate $ crFieldCascade cr1) (fcOnUpdate $ crFieldCascade cr2) + && eqCascade (fcOnDelete $ crFieldCascade cr1) (fcOnDelete $ crFieldCascade cr2) + where + eqCascade :: Maybe CascadeAction -> Maybe CascadeAction -> Bool + eqCascade Nothing Nothing = True + eqCascade Nothing (Just Restrict) = True + eqCascade (Just Restrict) Nothing = True + eqCascade (Just cs1) (Just cs2) = cs1 == cs2 + eqCascade _ _ = False +equivalentRef _ _ = False + +-- | Generate the default foreign key constraint name for a given source table and +-- source column name. Note that this function should generally not be used +-- except as an argument to postgresMkColumns, because if you use it in other contexts, +-- you're likely to miss nonstandard constraint names declared in the persistent +-- models files via `constraint=` +refName :: EntityNameDB -> FieldNameDB -> ConstraintNameDB +refName (EntityNameDB table) (FieldNameDB column) = + let + overhead = T.length $ T.concat ["_", "_fkey"] + (fromTable, fromColumn) = shortenNames overhead (T.length table, T.length column) + in + ConstraintNameDB $ + T.concat [T.take fromTable table, "_", T.take fromColumn column, "_fkey"] + where + -- Postgres automatically truncates too long foreign keys to a combination of + -- truncatedTableName + "_" + truncatedColumnName + "_fkey" + -- This works fine for normal use cases, but it creates an issue for Persistent + -- Because after running the migrations, Persistent sees the truncated foreign key constraint + -- doesn't have the expected name, and suggests that you migrate again + -- To workaround this, we copy the Postgres truncation approach before sending foreign key constraints to it. + -- + -- I believe this will also be an issue for extremely long table names, + -- but it's just much more likely to exist with foreign key constraints because they're usually tablename * 2 in length + + -- Approximation of the algorithm Postgres uses to truncate identifiers + -- See makeObjectName https://github.com/postgres/postgres/blob/5406513e997f5ee9de79d4076ae91c04af0c52f6/src/backend/commands/indexcmds.c#L2074-L2080 + shortenNames :: Int -> (Int, Int) -> (Int, Int) + shortenNames overhead (x, y) + | x + y + overhead <= maximumIdentifierLength = (x, y) + | x > y = shortenNames overhead (x - 1, y) + | otherwise = shortenNames overhead (x, y - 1) + +postgresMkColumns + :: BackendSpecificOverrides + -> [EntityDef] + -> EntityDef + -> ([Column], [UniqueDef], [ForeignDef]) +postgresMkColumns overrides allDefs t = + mkColumns allDefs t $ + setBackendSpecificForeignKeyName refName overrides + +-- | Check if a column name is listed as the "safe to remove" in the entity +-- list. +safeToRemove :: EntityDef -> FieldNameDB -> Bool +safeToRemove def (FieldNameDB colName) = + any (elem FieldAttrSafeToRemove . fieldAttrs) $ + filter ((== FieldNameDB colName) . fieldDB) $ + allEntityFields + where + allEntityFields = + getEntityFieldsDatabase def <> case getEntityId def of + EntityIdField fdef -> + [fdef] + _ -> + [] + +udToPair :: UniqueDef -> (ConstraintNameDB, [FieldNameDB]) +udToPair ud = (uniqueDBName ud, map snd $ NEL.toList $ uniqueFields ud) + +-- | Get the references to be added to a table for the given column. +getAddReference + :: [EntityDef] + -> EntityDef + -> FieldNameDB + -> ColumnReference + -> Maybe AlterDB +getAddReference allDefs entity cname cr@ColumnReference{crTableName = s, crConstraintName = constraintName} = do + guard $ Just cname /= fmap fieldDB (getEntityIdField entity) + pure $ + AlterColumn + table + (AddReference s constraintName (cname NEL.:| []) id_ (crFieldCascade cr)) + where + table = getEntityDBName entity + id_ = + fromMaybe + (error $ "Could not find ID of entity " ++ show s) + $ do + entDef <- find ((== s) . getEntityDBName) allDefs + return $ NEL.toList $ Util.dbIdColumnsEsc escapeF entDef + +mkForeignAlt + :: EntityDef + -> ForeignDef + -> Maybe AlterDB +mkForeignAlt entity fdef = case NEL.nonEmpty childfields of + Nothing -> Nothing + Just childfields' -> Just $ AlterColumn tableName_ addReference + where + addReference = + AddReference + (foreignRefTableDBName fdef) + constraintName + childfields' + escapedParentFields + (foreignFieldCascade fdef) + where + tableName_ = getEntityDBName entity + constraintName = + foreignConstraintNameDBName fdef + (childfields, parentfields) = + unzip (map (\((_, b), (_, d)) -> (b, d)) (foreignFields fdef)) + escapedParentFields = + map escapeF parentfields + +escapeC :: ConstraintNameDB -> Text +escapeC = escapeWith escape + +escapeE :: EntityNameDB -> Text +escapeE = escapeWith escape + +escapeF :: FieldNameDB -> Text +escapeF = escapeWith escape + +escape :: Text -> Text +escape s = + T.pack $ '"' : go (T.unpack s) ++ "\"" + where + go "" = "" + go ('"' : xs) = "\"\"" ++ go xs + go (x : xs) = x : go xs + +showAlterDb :: AlterDB -> (Bool, Text) +showAlterDb (AddTable name entityId nonIdCols) = (False, rawText) + where + idtxt = + case entityId of + EntityIdNaturalKey pdef -> + T.concat + [ " PRIMARY KEY (" + , T.intercalate "," $ map (escapeF . fieldDB) $ NEL.toList $ compositeFields pdef + , ")" + ] + EntityIdField field -> + let + defText = defaultAttribute $ fieldAttrs field + sType = fieldSqlType field + in + T.concat + [ escapeF $ fieldDB field + , maySerial sType defText + , " PRIMARY KEY UNIQUE" + , mayDefault defText + ] + rawText = + T.concat + -- Lower case e: see Database.Persist.Sql.Migration + [ "CREATe TABLE " -- DO NOT FIX THE CAPITALIZATION! + , escapeE name + , "(" + , idtxt + , if null nonIdCols then "" else "," + , T.intercalate "," $ map showColumn nonIdCols + , ")" + ] +showAlterDb (AlterColumn t ac) = + (isUnsafe ac, showAlter t ac) + where + isUnsafe (Drop _ (SafeToRemove safeRemove)) = not safeRemove + isUnsafe _ = False +showAlterDb (AlterTable t at) = (False, showAlterTable t at) + +showAlterTable :: EntityNameDB -> AlterTable -> Text +showAlterTable table (AddUniqueConstraint cname cols) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ADD CONSTRAINT " + , escapeC cname + , " UNIQUE(" + , T.intercalate "," $ map escapeF cols + , ")" + ] +showAlterTable table (DropConstraint cname) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " DROP CONSTRAINT " + , escapeC cname + ] + +showAlter :: EntityNameDB -> AlterColumn -> Text +showAlter table (ChangeType c t extra) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " TYPE " + , showSqlType t + , extra + ] +showAlter table (IsNull c) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " DROP NOT NULL" + ] +showAlter table (NotNull c) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " SET NOT NULL" + ] +showAlter table (AddColumn col) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ADD COLUMN " + , showColumn col + ] +showAlter table (Drop c _) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " DROP COLUMN " + , escapeF (cName c) + ] +showAlter table (Default c s) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " SET DEFAULT " + , s + ] +showAlter table (NoDefault c) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ALTER COLUMN " + , escapeF (cName c) + , " DROP DEFAULT" + ] +showAlter table (UpdateNullToValue c s) = + T.concat + [ "UPDATE " + , escapeE table + , " SET " + , escapeF (cName c) + , "=" + , s + , " WHERE " + , escapeF (cName c) + , " IS NULL" + ] +showAlter table (AddReference reftable fkeyname t2 id2 cascade) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " ADD CONSTRAINT " + , escapeC fkeyname + , " FOREIGN KEY(" + , T.intercalate "," $ map escapeF $ NEL.toList t2 + , ") REFERENCES " + , escapeE reftable + , "(" + , T.intercalate "," id2 + , ")" + ] + <> renderFieldCascade cascade +showAlter table (DropReference cname) = + T.concat + [ "ALTER TABLE " + , escapeE table + , " DROP CONSTRAINT " + , escapeC cname + ] + +showColumn :: Column -> Text +showColumn (Column n nu sqlType' def gen _defConstraintName _maxLen _ref) = + T.concat + [ escapeF n + , " " + , showSqlType sqlType' + , " " + , if nu then "NULL" else "NOT NULL" + , case def of + Nothing -> "" + Just s -> " DEFAULT " <> s + , case gen of + Nothing -> "" + Just s -> " GENERATED ALWAYS AS (" <> s <> ") STORED" + ] + +showSqlType :: SqlType -> Text +showSqlType SqlString = "VARCHAR" +showSqlType SqlInt32 = "INT4" +showSqlType SqlInt64 = "INT8" +showSqlType SqlReal = "DOUBLE PRECISION" +showSqlType (SqlNumeric s prec) = T.concat ["NUMERIC(", T.pack (show s), ",", T.pack (show prec), ")"] +showSqlType SqlDay = "DATE" +showSqlType SqlTime = "TIME" +showSqlType SqlDayTime = "TIMESTAMP WITH TIME ZONE" +showSqlType SqlBlob = "BYTEA" +showSqlType SqlBool = "BOOLEAN" +-- Added for aliasing issues re: https://github.com/yesodweb/yesod/issues/682 +showSqlType (SqlOther (T.toLower -> "integer")) = "INT4" +showSqlType (SqlOther t) = t + +findAlters + :: [EntityDef] + -- ^ The list of all entity definitions that persistent is aware of. + -> EntityDef + -- ^ The entity definition for the entity that we're working on. + -> Column + -- ^ The column that we're searching for potential alterations for, derived + -- from the Persistent EntityDef. That is: this is how we _want_ the column + -- to look, and not necessarily how it actually looks in the database right + -- now. + -> [Column] + -- ^ The columns for this table, as they currently exist in the database. + -> ([AlterColumn], [Column]) +findAlters defs edef newCol oldCols = + case List.find (\c -> cName c == cName newCol) oldCols of + Nothing -> + ([AddColumn newCol] ++ refAdd (cReference newCol), oldCols) + Just + oldCol -> + let + refDrop Nothing = [] + refDrop (Just ColumnReference{crConstraintName = cname}) = + [DropReference cname] + + modRef = + if equivalentRef (cReference oldCol) (cReference newCol) + then [] + else refDrop (cReference oldCol) ++ refAdd (cReference newCol) + modNull = case (cNull newCol, cNull oldCol) of + (True, False) -> do + guard $ Just (cName newCol) /= fmap fieldDB (getEntityIdField edef) + pure (IsNull newCol) + (False, True) -> + let + up = case cDefault newCol of + Nothing -> id + Just s -> (:) (UpdateNullToValue newCol s) + in + up [NotNull newCol] + _ -> [] + modType + | sqlTypeEq (cSqlType newCol) (cSqlType oldCol) = [] + -- When converting from Persistent pre-2.0 databases, we + -- need to make sure that TIMESTAMP WITHOUT TIME ZONE is + -- treated as UTC. + | cSqlType newCol == SqlDayTime && cSqlType oldCol == SqlOther "timestamp" = + [ ChangeType newCol (cSqlType newCol) $ + T.concat + [ " USING " + , escapeF (cName newCol) + , " AT TIME ZONE 'UTC'" + ] + ] + | otherwise = [ChangeType newCol (cSqlType newCol) ""] + modDef = + if cDefault newCol == cDefault oldCol + || isJust (T.stripPrefix "nextval" =<< cDefault oldCol) + then [] + else case cDefault newCol of + Nothing -> [NoDefault newCol] + Just s -> [Default newCol s] + dropSafe = + if safeToRemove edef (cName newCol) + then error "wtf" [Drop newCol (SafeToRemove True)] + else [] + in + ( modRef ++ modDef ++ modNull ++ modType ++ dropSafe + , filter (\c -> cName c /= cName newCol) oldCols + ) + where + refAdd Nothing = [] + -- This check works around a bug where persistent will sometimes + -- generate an erroneous ForeignRef for ID fields. + -- See: https://github.com/yesodweb/persistent/issues/1615 + refAdd _ | fmap fieldDB (getEntityIdField edef) == Just (cName newCol) = [] + refAdd (Just colRef) = + case find ((== crTableName colRef) . getEntityDBName) defs of + Just refdef -> + [ AddReference + (crTableName colRef) + (crConstraintName colRef) + (cName newCol NEL.:| []) + (NEL.toList $ Util.dbIdColumnsEsc escapeF refdef) + (crFieldCascade colRef) + ] + Nothing -> + error $ + "could not find the entityDef for reftable[" + ++ show (crTableName colRef) + ++ "]" diff --git a/Database/Persist/Postgresql/JSON.hs b/Database/Persist/Postgresql/JSON.hs --- a/Database/Persist/Postgresql/JSON.hs +++ b/Database/Persist/Postgresql/JSON.hs @@ -3,25 +3,30 @@ -- | Filter operators for JSON values added to PostgreSQL 9.4 module Database.Persist.Postgresql.JSON - ( (@>.) - , (<@.) - , (?.) - , (?|.) - , (?&.) - , Value() - ) where + ( (@>.) + , (<@.) + , (?.) + , (?|.) + , (?&.) + , Value () + ) where -import Data.Aeson (FromJSON, ToJSON, Value, encode, eitherDecodeStrict) +import Data.Aeson (FromJSON, ToJSON, Value, eitherDecodeStrict, encode) import qualified Data.ByteString.Lazy as BSL import Data.Proxy (Proxy) import Data.Text (Text) import qualified Data.Text as T import Data.Text.Encoding as TE (encodeUtf8) -import Database.Persist (EntityField, Filter(..), PersistValue(..), PersistField(..), PersistFilter(..)) -import Database.Persist.Sql (PersistFieldSql(..), SqlType(..)) -import Database.Persist.Types (FilterValue(..)) - +import Database.Persist + ( EntityField + , Filter (..) + , PersistField (..) + , PersistFilter (..) + , PersistValue (..) + ) +import Database.Persist.Sql (PersistFieldSql (..), SqlType (..)) +import Database.Persist.Types (FilterValue (..)) infix 4 @>., <@., ?., ?|., ?&. @@ -314,36 +319,36 @@ (?&.) :: EntityField record Value -> [Text] -> Filter record (?&.) field = jsonFilter " ??& " field . PostgresArray -jsonFilter :: PersistField a => Text -> EntityField record Value -> a -> Filter record +jsonFilter + :: (PersistField a) => Text -> EntityField record Value -> a -> Filter record jsonFilter op field a = Filter field (UnsafeValue a) $ BackendSpecificFilter op - ----------------- -- AESON VALUE -- ----------------- instance PersistField Value where - toPersistValue = toPersistValueJsonB - fromPersistValue = fromPersistValueJsonB + toPersistValue = toPersistValueJsonB + fromPersistValue = fromPersistValueJsonB instance PersistFieldSql Value where - sqlType = sqlTypeJsonB + sqlType = sqlTypeJsonB -- FIXME: PersistText might be a bit more efficient, -- 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 :: (ToJSON a) => a -> PersistValue toPersistValueJsonB = PersistLiteralEscaped . BSL.toStrict . encode -fromPersistValueJsonB :: FromJSON a => PersistValue -> Either Text a +fromPersistValueJsonB :: (FromJSON a) => PersistValue -> Either Text a fromPersistValueJsonB (PersistText t) = case eitherDecodeStrict $ TE.encodeUtf8 t of - Left str -> Left $ fromPersistValueParseError "FromJSON" t $ T.pack str - Right v -> Right v + Left str -> Left $ fromPersistValueParseError "FromJSON" t $ T.pack str + Right v -> Right v fromPersistValueJsonB (PersistByteString bs) = case eitherDecodeStrict bs of - Left str -> Left $ fromPersistValueParseError "FromJSON" bs $ T.pack str - Right v -> Right v + Left str -> Left $ fromPersistValueParseError "FromJSON" bs $ T.pack str + Right v -> Right v fromPersistValueJsonB x = Left $ fromPersistValueError "FromJSON" "string or bytea" x -- Constraints on the type might not be necessary, @@ -351,38 +356,49 @@ sqlTypeJsonB :: (ToJSON a, FromJSON a) => Proxy a -> SqlType sqlTypeJsonB _ = SqlOther "JSONB" - -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." - ] +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." + ] -fromPersistValueParseError :: (Show a) - => Text -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" - -> a -- ^ Received value - -> Text -- ^ Additional error - -> Text -- ^ Error message -fromPersistValueParseError haskellType received err = T.concat - [ "Failed to parse Haskell type `" - , haskellType - , "`, but received " - , T.pack (show received) - , " | with error: " - , err - ] +fromPersistValueParseError + :: (Show a) + => Text + -- ^ Haskell type, should match Haskell name exactly, e.g. "Int64" + -> a + -- ^ Received value + -> Text + -- ^ Additional error + -> Text + -- ^ Error message +fromPersistValueParseError haskellType received err = + T.concat + [ "Failed to parse Haskell type `" + , haskellType + , "`, but received " + , T.pack (show received) + , " | with error: " + , err + ] newtype PostgresArray a = PostgresArray [a] -instance PersistField a => PersistField (PostgresArray a) where - toPersistValue (PostgresArray ts) = PersistArray $ toPersistValue <$> ts - fromPersistValue (PersistArray as) = PostgresArray <$> traverse fromPersistValue as - fromPersistValue wat = Left $ fromPersistValueError "PostgresArray" "array" wat +instance (PersistField a) => PersistField (PostgresArray a) where + toPersistValue (PostgresArray ts) = PersistArray $ toPersistValue <$> ts + fromPersistValue (PersistArray as) = PostgresArray <$> traverse fromPersistValue as + fromPersistValue wat = Left $ fromPersistValueError "PostgresArray" "array" wat diff --git a/conn-killed/Main.hs b/conn-killed/Main.hs --- a/conn-killed/Main.hs +++ b/conn-killed/Main.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE ScopedTypeVariables, StandaloneDeriving, GeneralizedNewtypeDeriving, DerivingStrategies #-} -{-# LANGUAGE OverloadedStrings, QuantifiedConstraints #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} -{-# language OverloadedStrings #-} -- | This executable is a test of the issue raised in #1199. module Main where @@ -9,90 +12,104 @@ import Prelude hiding (show) import qualified Prelude -import qualified Data.Text as Text -import Control.Monad.IO.Class -import qualified Control.Monad as Monad -import qualified UnliftIO.Concurrent as Concurrent -import qualified UnliftIO.Exception as Exception -import qualified Database.Persist as Persist -import qualified Database.Persist.Sql as Persist -import qualified Database.Persist.Postgresql as Persist -import qualified Control.Monad.Logger as Logger +import qualified Control.Monad as Monad +import Control.Monad.IO.Class import Control.Monad.Logger +import qualified Control.Monad.Logger as Logger +import Control.Monad.Trans +import Control.Monad.Trans.Reader import qualified Data.ByteString as BS +import Data.Coerce import qualified Data.Pool as Pool +import qualified Data.Text as Text import Data.Time +import qualified Database.Persist as Persist +import qualified Database.Persist.Postgresql as Persist +import qualified Database.Persist.Sql as Persist import UnliftIO -import Data.Coerce -import Control.Monad.Trans.Reader -import Control.Monad.Trans +import qualified UnliftIO.Concurrent as Concurrent +import qualified UnliftIO.Exception as Exception -newtype LogPrefixT m a = LogPrefixT { runLogPrefixT :: ReaderT LogStr m a } +newtype LogPrefixT m a = LogPrefixT {runLogPrefixT :: ReaderT LogStr m a} deriving newtype (Functor, Applicative, Monad, MonadIO, MonadTrans) -instance MonadLogger m => MonadLogger (LogPrefixT m) where +instance (MonadLogger m) => MonadLogger (LogPrefixT m) where monadLoggerLog loc src lvl msg = LogPrefixT $ ReaderT $ \prefix -> monadLoggerLog loc src lvl (toLogStr prefix <> toLogStr msg) -deriving newtype instance (forall a b. Coercible a b => Coercible (m a) (m b), MonadUnliftIO m) => MonadUnliftIO (LogPrefixT m) +deriving newtype instance + (forall a b. (Coercible a b) => Coercible (m a) (m b), MonadUnliftIO m) + => MonadUnliftIO (LogPrefixT m) prefixLogs :: Text.Text -> LogPrefixT m a -> m a prefixLogs prefix = flip runReaderT (toLogStr $! mconcat ["[", prefix, "] "]) . runLogPrefixT infixr 5 `prefixLogs` -show :: Show a => a -> Text.Text +show :: (Show a) => a -> Text.Text show = Text.pack . Prelude.show main :: IO () -main = runStdoutLoggingT $ Concurrent.myThreadId >>= \tid -> prefixLogs (show tid) $ do - - -- I started a postgres server with: - -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres - pool <- Logger.runNoLoggingT $ Persist.createPostgresqlPool "postgresql://postgres:secret@localhost:5433/postgres" 1 +main = + runStdoutLoggingT $ + Concurrent.myThreadId >>= \tid -> prefixLogs (show tid) $ do + -- I started a postgres server with: + -- docker run --rm --name some-postgres -p 5432:5432 -e POSTGRES_PASSWORD=secret postgres + pool <- + Logger.runNoLoggingT $ + Persist.createPostgresqlPool + "postgresql://postgres:secret@localhost:5433/postgres" + 1 - logInfoN "creating table..." - Monad.void $ liftIO $ createTableFoo pool + logInfoN "creating table..." + Monad.void $ liftIO $ createTableFoo pool - liftIO getCurrentTime >>= \now -> - simulateFailedLongRunningPostgresCall pool + liftIO getCurrentTime >>= \now -> + simulateFailedLongRunningPostgresCall pool - -- logInfoN "destroying resources" - -- liftIO $ Pool.destroyAllResources pool + -- logInfoN "destroying resources" + -- liftIO $ Pool.destroyAllResources pool - logInfoN "pg_sleep" - result :: Either Exception.SomeException [Persist.Single (Maybe String)] <- - Exception.try . (liftIO . (flip Persist.runSqlPersistMPool) pool) $ do - Persist.rawSql @(Persist.Single (Maybe String)) "select pg_sleep(2)" [] + logInfoN "pg_sleep" + result :: Either Exception.SomeException [Persist.Single (Maybe String)] <- + Exception.try . (liftIO . (flip Persist.runSqlPersistMPool) pool) $ do + Persist.rawSql @(Persist.Single (Maybe String)) "select pg_sleep(2)" [] - -- when we try the above we get back: - -- 'result: Left libpq: failed (another command is already in progress' - -- this is because the connection went back into the pool before it was ready - -- or perhaps it should have been destroyed and a new connection created and put into the pool? - logInfoN $ "result: " <> show result + -- when we try the above we get back: + -- 'result: Left libpq: failed (another command is already in progress' + -- this is because the connection went back into the pool before it was ready + -- or perhaps it should have been destroyed and a new connection created and put into the pool? + logInfoN $ "result: " <> show result createTableFoo :: Pool.Pool Persist.SqlBackend -> IO () createTableFoo pool = (flip Persist.runSqlPersistMPool) pool $ do - Persist.rawExecute "CREATE table if not exists foo(id int);" [] + Persist.rawExecute "CREATE table if not exists foo(id int);" [] simulateFailedLongRunningPostgresCall - :: (MonadLogger m, MonadUnliftIO m, forall a b. Coercible a b => Coercible (m a) (m b)) => Pool.Pool Persist.SqlBackend -> m () + :: ( MonadLogger m + , MonadUnliftIO m + , forall a b. (Coercible a b) => Coercible (m a) (m b) + ) + => Pool.Pool Persist.SqlBackend -> m () simulateFailedLongRunningPostgresCall pool = do - threadId <- Concurrent.forkIO - $ (do - me <- Concurrent.myThreadId - prefixLogs (show me) $ do - let numThings :: Int = 100000000 - logInfoN $ "start inserting " <> show numThings <> " things" + threadId <- + Concurrent.forkIO $ + ( do + me <- Concurrent.myThreadId + prefixLogs (show me) $ do + let + numThings :: Int = 100000000 + logInfoN $ "start inserting " <> show numThings <> " things" - (`Persist.runSqlPool` pool) $ do - logInfoN "inside of thing" - Monad.forM_ [1 .. numThings] $ \i -> do - Monad.when (i `mod` 1000 == 0) $ - logInfoN $ "Thing #: " <> show i - Persist.rawExecute "insert into foo values(1);" [] - ) - Concurrent.threadDelay 1000000 - Monad.void $ Concurrent.killThread threadId - logInfoN "killed thread" + (`Persist.runSqlPool` pool) $ do + logInfoN "inside of thing" + Monad.forM_ [1 .. numThings] $ \i -> do + Monad.when (i `mod` 1000 == 0) $ + logInfoN $ + "Thing #: " <> show i + Persist.rawExecute "insert into foo values(1);" [] + ) + Concurrent.threadDelay 1000000 + Monad.void $ Concurrent.killThread threadId + logInfoN "killed thread" diff --git a/persistent-postgresql.cabal b/persistent-postgresql.cabal --- a/persistent-postgresql.cabal +++ b/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.13.7.0 +version: 2.14.3.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman @@ -12,34 +12,39 @@ build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues -extra-source-files: ChangeLog.md +extra-source-files: + ChangeLog.md + sql/*.sql library build-depends: - aeson >=1.0 + aeson >=1.0 , attoparsec - , base >=4.9 && <5 + , base >=4.9 && <5 , blaze-builder - , bytestring >=0.10 - , conduit >=1.2.12 - , containers >=0.5 - , monad-logger >=0.3.25 + , bytestring >=0.10 + , conduit >=1.2.12 + , containers >=0.5 + , file-embed >=0.0.16 + , monad-logger >=0.3.25 , mtl - , persistent >=2.13.3 && <3 - , postgresql-libpq >=0.9.4.2 && <0.12 - , postgresql-simple >=0.6.1 && <0.8 + , persistent >=2.18.1 && <3 + , postgresql-libpq >=0.9.4.2 && <0.12 + , postgresql-simple >=0.6.1 && <0.8 + , postgresql-simple-interval >=1 && <1.1 , resource-pool - , resourcet >=1.1.9 + , resourcet >=1.1.9 , string-conversions - , text >=1.2 - , time >=1.6 - , transformers >=0.5 + , text >=1.2 + , time >=1.6 + , transformers >=0.5 , unliftio-core , vault exposed-modules: Database.Persist.Postgresql Database.Persist.Postgresql.Internal + Database.Persist.Postgresql.Internal.Migration Database.Persist.Postgresql.JSON ghc-options: -Wall @@ -60,6 +65,7 @@ ImplicitUuidSpec JSONTest MigrationReferenceSpec + MigrationSpec PgInit PgIntervalTest UpsertWhere @@ -67,11 +73,11 @@ ghc-options: -Wall build-depends: aeson - , base >=4.9 && <5 + , base >=4.9 && <5 , bytestring , containers , fast-logger - , hspec >=2.4 + , hspec >=2.4 , hspec-expectations , hspec-expectations-lifted , http-api-data @@ -82,6 +88,7 @@ , persistent-postgresql , persistent-qq , persistent-test + , postgresql-simple-interval , QuickCheck , quickcheck-instances , resourcet diff --git a/sql/getForeignKeyReferences.sql b/sql/getForeignKeyReferences.sql new file mode 100644 --- /dev/null +++ b/sql/getForeignKeyReferences.sql @@ -0,0 +1,84 @@ +-- Get all foreign key references among the given set of table names in the +-- current namespace/schema. This query is used by the migrator to check whether +-- foreign key definitions are up to date. +-- +-- This query takes one parameter: an array of table names. +with + foreign_constraints as ( + select + c.* + from + pg_constraint AS c + inner join pg_class src_table + on src_table.oid = c.conrelid + inner join pg_namespace ns + on ns.oid = c.connamespace + where + -- f = foreign key constraint + c.contype = 'f' + and src_table.relname = ANY (?) + and ns.nspname = current_schema() + ), + foreign_constraint_with_source_columns as ( + select + c.oid, + array_agg( + a.attname::text + ORDER BY + k.n ASC + ) as column_names + from + foreign_constraints AS c + -- conkey is a list of the column indices on the source + -- table + CROSS JOIN LATERAL unnest(c.conkey) WITH ORDINALITY AS k (attnum, n) + INNER JOIN pg_attribute AS a + -- conrelid is the id of the source table + ON k.attnum = a.attnum AND c.conrelid = a.attrelid + group by + c.oid + ), + foreign_constraint_with_foreign_columns as ( + select + c.oid, + array_agg( + a.attname::text + ORDER BY + k.n ASC + ) as foreign_column_names + from + foreign_constraints AS c + -- confkey is a list of the column indices on the foreign + -- table + CROSS JOIN LATERAL unnest(c.confkey) WITH ORDINALITY AS k (attnum, n) + JOIN pg_attribute AS a + -- confrelid is the id of the foreign table + ON k.attnum = a.attnum AND c.confrelid = a.attrelid + group by + c.oid + ) +SELECT + fkey_constraint.conname::text as fkey_name, + src_table.relname::text AS source_table, + foreign_table.relname::text AS referenced_table, + -- NB: postgres arrays are one-indexed! + src_columns.column_names[1], + foreign_columns.foreign_column_names[1], + fkey_constraint.confupdtype, + fkey_constraint.confdeltype +from + foreign_constraints AS fkey_constraint + inner join foreign_constraint_with_source_columns src_columns + on src_columns.oid = fkey_constraint.oid + inner join foreign_constraint_with_foreign_columns foreign_columns + on foreign_columns.oid = fkey_constraint.oid + inner join pg_class src_table + on src_table.oid = fkey_constraint.conrelid + inner join pg_class foreign_table + on foreign_table.oid = fkey_constraint.confrelid + +-- In the future, we may want to look at multi-column FK constraints too. but +-- for now we only care about single-column constraints. +where + array_length(src_columns.column_names, 1) = 1 + and array_length(foreign_columns.foreign_column_names, 1) = 1; diff --git a/test/ArrayAggTest.hs b/test/ArrayAggTest.hs --- a/test/ArrayAggTest.hs +++ b/test/ArrayAggTest.hs @@ -1,16 +1,18 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DataKinds, FlexibleContexts #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -- FIXME -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- FIXME +{-# LANGUAGE UndecidableInstances #-} module ArrayAggTest where @@ -23,12 +25,16 @@ import PersistentTestModels import PgInit -share [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] [persistLowerCase| +share + [mkPersist persistSettings, mkMigrate "jsonTestMigrate"] + [persistLowerCase| TestValue json Value |] -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 @@ -36,22 +42,31 @@ specs :: Spec specs = do - describe "rawSql/array_agg" $ do - let runArrayAggTest :: (PersistField [a], Ord a, Show a) => Text -> [a] -> Assertion - runArrayAggTest dbField expected = runConnAssert $ do - void $ insertMany - [ UserPT "a" $ Just "b" - , UserPT "c" $ Just "d" - , UserPT "e" Nothing - , UserPT "g" $ Just "h" ] - escape <- getEscapeRawNameFunction - let query = T.concat [ "SELECT array_agg(", escape dbField, ") " - , "FROM ", escape "UserPT" - ] - [Single xs] <- rawSql query [] - liftIO $ sort xs @?= expected + describe "rawSql/array_agg" $ do + let + runArrayAggTest :: (PersistField [a], Ord a, Show a) => Text -> [a] -> Assertion + runArrayAggTest dbField expected = runConnAssert $ do + void $ + insertMany + [ UserPT "a" $ Just "b" + , UserPT "c" $ Just "d" + , UserPT "e" Nothing + , UserPT "g" $ Just "h" + ] + escape <- getEscapeRawNameFunction + let + query = + T.concat + [ "SELECT array_agg(" + , escape dbField + , ") " + , "FROM " + , escape "UserPT" + ] + [Single xs] <- rawSql query [] + liftIO $ sort xs @?= expected - it "works for [Text]" $ do - runArrayAggTest "ident" ["a", "c", "e", "g" :: Text] - it "works for [Maybe Text]" $ do - runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text] + it "works for [Text]" $ do + runArrayAggTest "ident" ["a", "c", "e", "g" :: Text] + it "works for [Maybe Text]" $ do + runArrayAggTest "password" [Nothing, Just "b", Just "d", Just "h" :: Maybe Text] diff --git a/test/CustomConstraintTest.hs b/test/CustomConstraintTest.hs --- a/test/CustomConstraintTest.hs +++ b/test/CustomConstraintTest.hs @@ -1,21 +1,26 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs, DataKinds, FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + module CustomConstraintTest where -import PgInit import qualified Data.Text as T +import PgInit -share [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "customConstraintMigrate"] + [persistLowerCase| CustomConstraint1 some_field Text deriving Show @@ -33,34 +38,44 @@ specs :: Spec specs = do - describe "custom constraint used in migration" $ do - 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, " - ,"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 ccu.table_name=? " - ,"AND ccu.column_name=? " - ,"AND kcu.table_name=? " - ,"AND kcu.column_name=? " - ,"AND tc.constraint_name=?"] - [Single exists_] <- rawSql query [PersistText "custom_constraint1" - ,PersistText "id" - ,PersistText "custom_constraint2" - ,PersistText "cc_id" - ,PersistText "custom_constraint"] - liftIO $ 1 @?= (exists_ :: Int) + describe "custom constraint used in migration" $ do + 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, " + , "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 ccu.table_name=? " + , "AND ccu.column_name=? " + , "AND kcu.table_name=? " + , "AND kcu.column_name=? " + , "AND tc.constraint_name=?" + ] + [Single exists_] <- + rawSql + query + [ PersistText "custom_constraint1" + , PersistText "id" + , PersistText "custom_constraint2" + , PersistText "cc_id" + , PersistText "custom_constraint" + ] + liftIO $ 1 @?= (exists_ :: Int) - 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` - void $ getMigration customConstraintMigrate - pure () + 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` + void $ getMigration customConstraintMigrate + pure () diff --git a/test/EquivalentTypeTestPostgres.hs b/test/EquivalentTypeTestPostgres.hs --- a/test/EquivalentTypeTestPostgres.hs +++ b/test/EquivalentTypeTestPostgres.hs @@ -1,15 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE DataKinds, FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module EquivalentTypeTestPostgres (specs) where @@ -20,7 +21,9 @@ import Database.Persist.TH import PgInit -share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrateAll1"] + [persistLowerCase| EquivalentType sql=equivalent_types field1 Int sqltype=bigint field2 T.Text sqltype=text @@ -28,7 +31,9 @@ deriving Eq Show |] -share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "migrateAll2"] + [persistLowerCase| EquivalentType2 sql=equivalent_types field1 Int sqltype=int8 field2 T.Text @@ -39,9 +44,9 @@ specs :: Spec specs = describe "doesn't migrate equivalent types" $ do it "works" $ asIO $ runResourceT $ runConn $ do - _ <- rawExecute "DROP DOMAIN IF EXISTS us_postal_code CASCADE" [] - _ <- rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" [] + _ <- + rawExecute "CREATE DOMAIN us_postal_code AS TEXT CHECK(VALUE ~ '^\\d{5}$')" [] _ <- runMigrationSilent migrateAll1 xs <- getMigration migrateAll2 diff --git a/test/ImplicitUuidSpec.hs b/test/ImplicitUuidSpec.hs --- a/test/ImplicitUuidSpec.hs +++ b/test/ImplicitUuidSpec.hs @@ -46,7 +46,8 @@ rawExecute "DROP TABLE with_def_uuid;" [] runMigration implicitUuidMigrate -itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb + :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) itDb msg action = it msg $ runConnAssert $ void action pass :: IO () @@ -56,10 +57,12 @@ spec = describe "ImplicitUuidSpec" $ before_ wipe $ do describe "WithDefUuidKey" $ do it "works on UUIDs" $ do - let withDefUuidKey = WithDefUuidKey (UUID "Hello") + let + withDefUuidKey = WithDefUuidKey (UUID "Hello") pass describe "getEntityId" $ do - let Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) + let + Just idField = getEntityIdField (entityDef (Proxy @WithDefUuid)) it "has a UUID SqlType" $ asIO $ do fieldSqlType idField `shouldBe` SqlOther "UUID" it "is an implicit ID column" $ asIO $ do @@ -67,10 +70,12 @@ describe "insert" $ do itDb "successfully has a default" $ do - let matt = WithDefUuid - { withDefUuidName = - "Matt" - } + let + matt = + WithDefUuid + { withDefUuidName = + "Matt" + } k <- insert matt mrec <- get k mrec `shouldBe` Just matt diff --git a/test/JSONTest.hs b/test/JSONTest.hs --- a/test/JSONTest.hs +++ b/test/JSONTest.hs @@ -1,680 +1,760 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# language DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -module JSONTest where - -import Control.Monad.IO.Class (MonadIO) -import Data.Aeson hiding (Key) -import qualified Data.Vector as V (fromList) -import Test.HUnit (assertBool) -import Test.Hspec.Expectations () - -import Database.Persist -import Database.Persist.Postgresql.JSON - -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 = deleteWhere ([] :: [Filter TestValue]) - -emptyArr :: Value -emptyArr = toJSON ([] :: [Value]) - -insert' :: (MonadIO m, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend) - => Value -> ReaderT backend m (Key TestValue) -insert' = insert . TestValue - - -matchKeys :: (Show record, Show (Key record), MonadIO m, Eq (Key record)) - => [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 - ] - -setup :: IO TestKeys -setup = asIO $ runConn_ $ do - void $ runMigrationSilent jsonTestMigrate - testKeys - -teardown :: IO () -teardown = asIO $ runConn_ $ do - cleanDB - -shouldBeIO :: (Show a, Eq a, MonadIO m) => a -> a -> m () -shouldBeIO x y = liftIO $ shouldBe x y - -assertBoolIO :: MonadIO m => String -> Bool -> m () -assertBoolIO s b = liftIO $ assertBool s b - -testKeys :: (Monad m, MonadIO m) => ReaderT SqlBackend m TestKeys -testKeys = do - nullK <- insert' Null - - boolTK <- insert' $ Bool True - boolFK <- insert' $ toJSON False - - 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) - - 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" - - 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{..} - -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) - -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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 ] - - vals <- selectList [TestValueJson @>. queryList ] [] - [arrFilledK] `matchKeys` vals - - 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 ] - - vals <- selectList [TestValueJson @>. testList] [] - [] `matchKeys` vals - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - 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 - - describe "@>. string queries" $ do - it "matches identical strings" $ - -- "testing" @>. "testing" == True - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. String "testing"] [] - [strTestK] `matchKeys` vals - - it "doesnt match case insensitive" $ - -- "testing" @>. "Testing" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. String "Testing"] [] - [] `matchKeys` vals - - it "doesn't match substrings" $ - -- "testing" @>. "test" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. String "test"] [] - [] `matchKeys` vals - - it "doesn't match strings with object keys" $ - -- "testing" @>. {"testing":1} == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. object ["testing" .= Number 1]] [] - [] `matchKeys` vals - - 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 - - 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 - - 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 - - it "does not match number when queried with different number" $ - -- 1234567890 @>. 234567890 == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. toJSON (234567890 :: Int)] [] - [] `matchKeys` vals - - 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 - - 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 - - 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 - - it "matches identical booleans (False)" $ - -- false @>. false == True - -- true @>. false == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. Bool False] [] - [boolFK] `matchKeys` vals - - 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 - - it "does not match null with string of null" $ - -- null @>. "null" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson @>. String "null"] [] - [] `matchKeys` vals - - - 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 - - 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 - - it "matches identical strings" $ - -- "a" <@. "a" == True - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson <@. String "a"] [] - [strAK] `matchKeys` vals - - it "matches identical big floats" $ - -- 9876543210.123457 <@ 9876543210.123457 == True - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson <@. Number 9876543210.123457] [] - [numBigFloatK] `matchKeys` vals - - 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 - - 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 - - it "doesn't match nested key" $ - -- {"c":24.986,"foo":{"deep1":true"}} ?. "deep1" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?. "deep1"] [] - [] `matchKeys` vals - - it "matches \"{}\" but not empty object when queried with \"{}\"" $ - -- "{}" ?. "{}" == True - -- {} ?. "{}" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?. "{}"] [] - [strObjK] `matchKeys` vals - - 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 - - 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 - - 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 - - it "matches string list but not real list when queried with \"[]\"" $ - -- "[]" ?. "[]" == True - -- [] ?. "[]" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?. "[]"] [] - [strArrK] `matchKeys` vals - - it "does not match null when queried with string null" $ - -- null ?. "null" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?. "null"] [] - [] `matchKeys` vals - - it "does not match bool whe nqueried with string bool" $ - -- true ?. "true" == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?. "true"] [] - [] `matchKeys` vals - - - 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 - - it "matches str object but not object when queried with \"{}\"" $ - -- "{}" ?|. ["{}"] == True - -- {} ?|. ["{}"] == False - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?|. ["{}"]] [] - [strObjK] `matchKeys` vals - - 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 - - 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 - - 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 - - it "matches string array when queried with \"[]\"" $ - -- [] ?|. ["[]"] == False - -- "[]" ?|. ["[]"] == True - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?|. ["[]"]] [] - [strArrK] `matchKeys` vals - - 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 - ] - - 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 - - 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 - - it "matches object string when queried with \"{}\"" $ - -- {} ?&. ["{}"] == False - -- "{}" ?&. ["{}"] == True - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?&. ["{}"]] [] - [strObjK] `matchKeys` vals - - 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 - - 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 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 - - it "matches string array when queried with \"[]\"" $ - -- [] ?&. ["[]"] == False - -- "[]" ?&. ["[]"] == True - \TestKeys {..} -> runConnAssert $ do - vals <- selectList [TestValueJson ?&. ["[]"]] [] - [strArrK] `matchKeys` vals - - 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 - - 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 - - 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 +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module JSONTest where + +import Control.Monad.IO.Class (MonadIO) +import Data.Aeson hiding (Key) +import qualified Data.Vector as V (fromList) +import Test.HUnit (assertBool) +import Test.Hspec.Expectations () + +import Database.Persist +import Database.Persist.Postgresql.JSON + +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 = deleteWhere ([] :: [Filter TestValue]) + +emptyArr :: Value +emptyArr = toJSON ([] :: [Value]) + +insert' + :: (MonadIO m, PersistStoreWrite backend, BaseBackend backend ~ SqlBackend) + => Value -> ReaderT backend m (Key TestValue) +insert' = insert . TestValue + +matchKeys + :: (Show record, Show (Key record), MonadIO m, Eq (Key record)) + => [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 + ] + +setup :: IO TestKeys +setup = asIO $ runConn_ $ do + void $ runMigrationSilent jsonTestMigrate + testKeys + +teardown :: IO () +teardown = asIO $ runConn_ $ do + cleanDB + +shouldBeIO :: (Show a, Eq a, MonadIO m) => a -> a -> m () +shouldBeIO x y = liftIO $ shouldBe x y + +assertBoolIO :: (MonadIO m) => String -> Bool -> m () +assertBoolIO s b = liftIO $ assertBool s b + +testKeys :: (Monad m, MonadIO m) => ReaderT SqlBackend m TestKeys +testKeys = do + nullK <- insert' Null + + boolTK <- insert' $ Bool True + boolFK <- insert' $ toJSON False + + 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) + + 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" + + 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{..} + +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) + +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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + ] + + vals <- selectList [TestValueJson @>. queryList] [] + [arrFilledK] `matchKeys` vals + + 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 + ] + + vals <- selectList [TestValueJson @>. testList] [] + [] `matchKeys` vals + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + 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 + + describe "@>. string queries" $ do + it "matches identical strings" $ + -- "testing" @>. "testing" == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "testing"] [] + [strTestK] `matchKeys` vals + + it "doesnt match case insensitive" $ + -- "testing" @>. "Testing" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "Testing"] [] + [] `matchKeys` vals + + it "doesn't match substrings" $ + -- "testing" @>. "test" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "test"] [] + [] `matchKeys` vals + + it "doesn't match strings with object keys" $ + -- "testing" @>. {"testing":1} == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. object ["testing" .= Number 1]] [] + [] `matchKeys` vals + + 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 + + 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 + + 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 + + it "does not match number when queried with different number" $ + -- 1234567890 @>. 234567890 == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. toJSON (234567890 :: Int)] [] + [] `matchKeys` vals + + 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 + + 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 + + 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 + + it "matches identical booleans (False)" $ + -- false @>. false == True + -- true @>. false == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. Bool False] [] + [boolFK] `matchKeys` vals + + 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 + + it "does not match null with string of null" $ + -- null @>. "null" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson @>. String "null"] [] + [] `matchKeys` vals + + 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 + + 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 + + it "matches identical strings" $ + -- "a" <@. "a" == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson <@. String "a"] [] + [strAK] `matchKeys` vals + + it "matches identical big floats" $ + -- 9876543210.123457 <@ 9876543210.123457 == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson <@. Number 9876543210.123457] [] + [numBigFloatK] `matchKeys` vals + + 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 + + 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 + + it "doesn't match nested key" $ + -- {"c":24.986,"foo":{"deep1":true"}} ?. "deep1" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "deep1"] [] + [] `matchKeys` vals + + it "matches \"{}\" but not empty object when queried with \"{}\"" $ + -- "{}" ?. "{}" == True + -- {} ?. "{}" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "{}"] [] + [strObjK] `matchKeys` vals + + 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 + + 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 + + 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 + + it "matches string list but not real list when queried with \"[]\"" $ + -- "[]" ?. "[]" == True + -- [] ?. "[]" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "[]"] [] + [strArrK] `matchKeys` vals + + it "does not match null when queried with string null" $ + -- null ?. "null" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "null"] [] + [] `matchKeys` vals + + it "does not match bool whe nqueried with string bool" $ + -- true ?. "true" == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?. "true"] [] + [] `matchKeys` vals + + 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 + + it "matches str object but not object when queried with \"{}\"" $ + -- "{}" ?|. ["{}"] == True + -- {} ?|. ["{}"] == False + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["{}"]] [] + [strObjK] `matchKeys` vals + + 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 + + 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 + + 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 + + it "matches string array when queried with \"[]\"" $ + -- [] ?|. ["[]"] == False + -- "[]" ?|. ["[]"] == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?|. ["[]"]] [] + [strArrK] `matchKeys` vals + + 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 + ] + + 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 + + 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 + + it "matches object string when queried with \"{}\"" $ + -- {} ?&. ["{}"] == False + -- "{}" ?&. ["{}"] == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["{}"]] [] + [strObjK] `matchKeys` vals + + 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 + + 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 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 + + it "matches string array when queried with \"[]\"" $ + -- [] ?&. ["[]"] == False + -- "[]" ?&. ["[]"] == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. ["[]"]] [] + [strArrK] `matchKeys` vals + + 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 + + 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 + + it "doesn't match empty objs or list when queried with empty string" $ + -- {} ?&. [""] == False + -- [] ?&. [""] == False + -- "" ?&. [""] == True + -- {"":9001} ?&. [""] == True + \TestKeys{..} -> runConnAssert $ do + vals <- selectList [TestValueJson ?&. [""]] [] + [strNullK, objEmptyK] `matchKeys` vals diff --git a/test/MigrationReferenceSpec.hs b/test/MigrationReferenceSpec.hs --- a/test/MigrationReferenceSpec.hs +++ b/test/MigrationReferenceSpec.hs @@ -1,13 +1,15 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE OverloadedStrings, DataKinds, FlexibleInstances #-} -{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} module MigrationReferenceSpec where @@ -17,7 +19,9 @@ import Control.Monad.Trans.Writer (censor, mapWriterT) import Data.Text (Text, isInfixOf) -share [mkPersist sqlSettings, mkMigrate "referenceMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "referenceMigrate"] + [persistLowerCase| LocationCapabilities Id Text @@ -47,10 +51,10 @@ isReference :: Text -> Bool isReference migration = "REFERENCES" `isInfixOf` migration - runMigration - $ mapWriterT (censor noForeignKeys) - $ referenceMigrate + runMigration $ + mapWriterT (censor noForeignKeys) $ + referenceMigrate - runMigration - $ mapWriterT (censor onlyForeignKeys) - $ referenceMigrate + runMigration $ + mapWriterT (censor onlyForeignKeys) $ + referenceMigrate diff --git a/test/MigrationSpec.hs b/test/MigrationSpec.hs new file mode 100644 --- /dev/null +++ b/test/MigrationSpec.hs @@ -0,0 +1,687 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module MigrationSpec where + +import PgInit + +import Data.Foldable (traverse_) +import qualified Data.Map as Map +import Data.Proxy +import qualified Data.Set as Set +import qualified Data.Text as T +import Database.Persist.Postgresql.Internal.Migration + +getStmtGetter + :: (Monad m) => SqlPersistT m (Text -> IO Statement) +getStmtGetter = do + backend <- ask + pure (getStmtConn backend) + +-- NB: we do not perform these migrations in main.hs +share + [mkPersist persistSettings{mpsGeneric = False}] + [persistLowerCase| +User sql=users + name Text + title Text Maybe + deriving Show Eq + +UserFriendship sql=user_friendships + user1Id UserId Maybe + user2Id UserId Maybe + deriving Show Eq + +Password sql=passwords + passwordHash Text + userId UserId Maybe + UniqueUserId userId !force + +Password2 sql=passwords_2 + passwordHash Text + userId UserId Maybe OnDeleteCascade OnUpdateSetNull + UniqueUserId2 userId !force + +AdminUser sql=admin_users + userId UserId + Primary userId + + promotedByUserId UserId + UniquePromotedByUserId promotedByUserId + +FKParent sql=migration_fk_parent + +FKChildV1 sql=migration_fk_child + +-- Simulate creating a new FK field on an existing table +FKChildV2 sql=migration_fk_child + parentId FKParentId + +ExplicitPrimaryKey sql=explicit_primary_key + Id Text +|] + +userEntityDef :: EntityDef +userEntityDef = entityDef (Proxy :: Proxy User) + +userFriendshipEntityDef :: EntityDef +userFriendshipEntityDef = entityDef (Proxy :: Proxy UserFriendship) + +passwordEntityDef :: EntityDef +passwordEntityDef = entityDef (Proxy :: Proxy Password) + +password2EntityDef :: EntityDef +password2EntityDef = entityDef (Proxy :: Proxy Password2) + +adminUserEntityDef :: EntityDef +adminUserEntityDef = entityDef (Proxy :: Proxy AdminUser) + +fkParentEntityDef :: EntityDef +fkParentEntityDef = entityDef (Proxy :: Proxy FKParent) + +fkChildV1EntityDef :: EntityDef +fkChildV1EntityDef = entityDef (Proxy :: Proxy FKChildV1) + +fkChildV2EntityDef :: EntityDef +fkChildV2EntityDef = entityDef (Proxy :: Proxy FKChildV2) + +explicitPrimaryKeyEntityDef :: EntityDef +explicitPrimaryKeyEntityDef = entityDef (Proxy :: Proxy ExplicitPrimaryKey) + +-- Note that FKChild is deliberately omitted here because we have two +-- versions of it +allEntityDefs :: [EntityDef] +allEntityDefs = + [ userEntityDef + , userFriendshipEntityDef + , passwordEntityDef + , password2EntityDef + , adminUserEntityDef + , fkParentEntityDef + , explicitPrimaryKeyEntityDef + ] + +-- Note that this function migrates to the schema expected by FKChildV1 +migrateManually :: (HasCallStack, MonadIO m) => SqlPersistT m () +migrateManually = do + cleanDB + let + rawEx sql = rawExecute sql [] + rawEx + "CREATE TABLE users(id int8 primary key, name text not null, title text);" + rawEx $ + T.concat + [ "CREATE TABLE user_friendships(" + , " id int8 primary key," + , " user1_id int8 references users(id) on delete restrict on update restrict," + , " user2_id int8 references users(id) on delete restrict on update restrict" + , ");" + ] + rawEx $ + T.concat + [ "CREATE TABLE passwords(" + , " id int8 primary key," + , " password_hash text not null," + , " user_id int8 references users(id) on delete restrict on update restrict" + , ");" + ] + rawEx $ + T.concat + [ "ALTER TABLE passwords" + , " ADD CONSTRAINT unique_user_id" + , " UNIQUE(user_id);" + ] + rawEx $ + T.concat + [ "CREATE TABLE passwords_2(" + , " id int8 primary key," + , " password_hash text not null," + , " user_id int8 references users(id) on delete cascade on update set null" + , ");" + ] + rawEx $ + T.concat + [ "ALTER TABLE passwords_2" + , " ADD CONSTRAINT unique_user_id2" + , " UNIQUE(user_id);" + ] + -- Add an extra redundant FK constraint on passwords_2.user_id, so that we + -- can test that the migrator ignores it + rawEx $ + T.concat + [ "ALTER TABLE passwords_2" + , " ADD CONSTRAINT duplicate_passwords_2_user_id_fkey" + , " FOREIGN KEY (user_id) REFERENCES users(id);" + ] + rawEx $ + T.concat + [ "CREATE TABLE admin_users(" + , " user_id int8 not null references users(id) on delete restrict on update restrict primary key," + , " promoted_by_user_id int8 not null references users(id) on delete restrict on update restrict" + , ");" + ] + rawEx $ + T.concat + [ "ALTER TABLE admin_users" + , " ADD CONSTRAINT unique_promoted_by_user_id" + , " UNIQUE(promoted_by_user_id);" + ] + rawEx "CREATE TABLE migration_fk_parent(id int8 primary key);" + rawEx "CREATE TABLE migration_fk_child(id int8 primary key);" + rawEx "CREATE TABLE explicit_primary_key(id text primary key);" + rawEx "CREATE TABLE ignored(id int8 primary key);" + +cleanDB :: (HasCallStack, MonadIO m) => SqlPersistT m () +cleanDB = do + let + rawEx sql = rawExecute sql [] + rawEx "DROP TABLE IF EXISTS user_friendships;" + rawEx "DROP TABLE IF EXISTS passwords;" + rawEx "DROP TABLE IF EXISTS passwords_2;" + rawEx "DROP TABLE IF EXISTS ignored;" + rawEx "DROP TABLE IF EXISTS admin_users;" + rawEx "DROP TABLE IF EXISTS users;" + rawEx "DROP TABLE IF EXISTS migration_fk_child;" + rawEx "DROP TABLE IF EXISTS migration_fk_parent;" + rawEx "DROP TABLE IF EXISTS explicit_primary_key;" + +spec :: Spec +spec = describe "MigrationSpec" $ do + it "gathers schema state" $ runConnAssert $ do + migrateManually + + getter <- getStmtGetter + actual <- + liftIO $ + collectSchemaState getter $ + map + EntityNameDB + [ "users" + , "admin_users" + , "user_friendships" + , "passwords" + , "passwords_2" + , "nonexistent" + ] + + cleanDB + + let + expected = + SchemaState + ( Map.fromList + [ + ( EntityNameDB{unEntityNameDB = "admin_users"} + , EntityExists + ( ExistingEntitySchemaState + { essColumns = + Map.fromList + [ + ( FieldNameDB{unFieldNameDB = "promoted_by_user_id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "promoted_by_user_id"} + , cNull = False + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList + [ ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "admin_users_promoted_by_user_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just Restrict, fcOnDelete = Just Restrict} + } + ] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "user_id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "user_id"} + , cNull = False + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList + [ ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "admin_users_user_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just Restrict, fcOnDelete = Just Restrict} + } + ] + ) + ) + ] + , essUniqueConstraints = + Map.fromList + [ + ( ConstraintNameDB{unConstraintNameDB = "unique_promoted_by_user_id"} + , [FieldNameDB{unFieldNameDB = "promoted_by_user_id"}] + ) + ] + } + ) + ) + , (EntityNameDB{unEntityNameDB = "nonexistent"}, EntityDoesNotExist) + , + ( EntityNameDB{unEntityNameDB = "passwords"} + , EntityExists + ( ExistingEntitySchemaState + { essColumns = + Map.fromList + [ + ( FieldNameDB{unFieldNameDB = "id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "id"} + , cNull = False + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "password_hash"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "password_hash"} + , cNull = False + , cSqlType = SqlString + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "user_id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "user_id"} + , cNull = True + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList + [ ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "passwords_user_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just Restrict, fcOnDelete = Just Restrict} + } + ] + ) + ) + ] + , essUniqueConstraints = + Map.fromList + [ + ( ConstraintNameDB{unConstraintNameDB = "unique_user_id"} + , [FieldNameDB{unFieldNameDB = "user_id"}] + ) + ] + } + ) + ) + , + ( EntityNameDB{unEntityNameDB = "passwords_2"} + , EntityExists + ( ExistingEntitySchemaState + { essColumns = + Map.fromList + [ + ( FieldNameDB{unFieldNameDB = "id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "id"} + , cNull = False + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "password_hash"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "password_hash"} + , cNull = False + , cSqlType = SqlString + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "user_id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "user_id"} + , cNull = True + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList + [ ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "duplicate_passwords_2_user_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just NoAction, fcOnDelete = Just NoAction} + } + , ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "passwords_2_user_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just SetNull, fcOnDelete = Just Cascade} + } + ] + ) + ) + ] + , essUniqueConstraints = + Map.fromList + [ + ( ConstraintNameDB{unConstraintNameDB = "unique_user_id2"} + , [FieldNameDB{unFieldNameDB = "user_id"}] + ) + ] + } + ) + ) + , + ( EntityNameDB{unEntityNameDB = "user_friendships"} + , EntityExists + ( ExistingEntitySchemaState + { essColumns = + Map.fromList + [ + ( FieldNameDB{unFieldNameDB = "id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "id"} + , cNull = False + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "user1_id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "user1_id"} + , cNull = True + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList + [ ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "user_friendships_user1_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just Restrict, fcOnDelete = Just Restrict} + } + ] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "user2_id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "user2_id"} + , cNull = True + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList + [ ColumnReference + { crTableName = EntityNameDB{unEntityNameDB = "users"} + , crConstraintName = + ConstraintNameDB{unConstraintNameDB = "user_friendships_user2_id_fkey"} + , crFieldCascade = + FieldCascade{fcOnUpdate = Just Restrict, fcOnDelete = Just Restrict} + } + ] + ) + ) + ] + , essUniqueConstraints = Map.fromList [] + } + ) + ) + , + ( EntityNameDB{unEntityNameDB = "users"} + , EntityExists + ( ExistingEntitySchemaState + { essColumns = + Map.fromList + [ + ( FieldNameDB{unFieldNameDB = "id"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "id"} + , cNull = False + , cSqlType = SqlInt64 + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "name"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "name"} + , cNull = False + , cSqlType = SqlString + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + , + ( FieldNameDB{unFieldNameDB = "title"} + , + ( Column + { cName = FieldNameDB{unFieldNameDB = "title"} + , cNull = True + , cSqlType = SqlString + , cDefault = Nothing + , cGenerated = Nothing + , cDefaultConstraintName = Nothing + , cMaxLen = Nothing + , cReference = Nothing + } + , Set.fromList [] + ) + ) + ] + , essUniqueConstraints = Map.fromList [] + } + ) + ) + ] + ) + + actual `shouldBe` Right expected + + it "no-ops on a migrated DB" $ runConnAssert $ do + migrateManually + + getter <- getStmtGetter + result <- + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs + + cleanDB + + case result of + Right [] -> + pure () + Left err -> + expectationFailure $ show err + Right alters -> + map (snd . showAlterDb) alters `shouldBe` [] + + it "migrates a clean DB" $ runConnAssert $ do + cleanDB + + getter <- getStmtGetter + result <- + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs + + cleanDB + + case result of + Right [] -> + pure () + Left err -> + expectationFailure $ show err + Right alters -> do + traverse_ (flip rawExecute [] . snd . showAlterDb) alters + result2 <- + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + allEntityDefs + allEntityDefs + result2 `shouldBe` Right [] + + it "suggests FK constraints for new fields first time" $ runConnAssert $ do + migrateManually + + getter <- getStmtGetter + result <- + liftIO $ + migrateEntitiesStructured + emptyBackendSpecificOverrides + getter + (fkChildV2EntityDef : allEntityDefs) + [fkChildV2EntityDef] + + cleanDB + + case result of + Right [] -> + pure () + Left err -> + expectationFailure $ show err + Right alters -> + map (snd . showAlterDb) alters + `shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL" + , "ALTER TABLE \"migration_fk_child\" ADD CONSTRAINT \"migration_fk_child_parent_id_fkey\" FOREIGN KEY(\"parent_id\") REFERENCES \"migration_fk_parent\"(\"id\") ON DELETE RESTRICT ON UPDATE RESTRICT" + ] + + it "Uses overrides for empty cascade action" $ runConnAssert $ do + migrateManually + + getter <- getStmtGetter + + let + overrideWithDefault = + setBackendSpecificForeignKeyCascadeDefault Cascade emptyBackendSpecificOverrides + result <- + liftIO $ + migrateEntitiesStructured + overrideWithDefault + getter + (fkChildV2EntityDef : allEntityDefs) + [fkChildV2EntityDef] + + cleanDB + + case result of + Right [] -> + pure () + Left err -> + expectationFailure $ show err + Right alters -> + map (snd . showAlterDb) alters + `shouldBe` [ "ALTER TABLE \"migration_fk_child\" ADD COLUMN \"parent_id\" INT8 NOT NULL" + , "ALTER TABLE \"migration_fk_child\" ADD CONSTRAINT \"migration_fk_child_parent_id_fkey\" FOREIGN KEY(\"parent_id\") REFERENCES \"migration_fk_parent\"(\"id\") ON DELETE CASCADE ON UPDATE CASCADE" + ] diff --git a/test/PgInit.hs b/test/PgInit.hs --- a/test/PgInit.hs +++ b/test/PgInit.hs @@ -9,14 +9,12 @@ , runConn_ , runConnAssert , runConnAssertUseConf - , MonadIO , persistSettings , MkPersistSettings (..) - , BackendKey(..) - , GenerateKey(..) - - -- re-exports + , BackendKey (..) + , GenerateKey (..) + -- re-exports , module Control.Monad.Trans.Reader , module Control.Monad , module Database.Persist.Sql @@ -29,77 +27,84 @@ , module Test.HUnit , AValue (..) , BS.ByteString - , Int32, Int64 + , Int32 + , Int64 , liftIO - , mkPersist, migrateModels, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase + , mkPersist + , migrateModels + , mkMigrate + , share + , sqlSettings + , persistLowerCase + , persistUpperCase , mkEntityDefList , setImplicitIdDef , SomeException , Text - , TestFn(..) + , TestFn (..) , LoggingT , ResourceT - , UUID(..) + , UUID (..) , sqlSettingsUuid ) where import Init - ( GenerateKey(..) - , MonadFail - , RunDb - , TestFn(..) - , UUID(..) - , arbText - , asIO - , assertEmpty - , assertNotEmpty - , assertNotEqual - , isTravis - , liftA2 - , sqlSettingsUuid - , truncateTimeOfDay - , truncateToMicro - , truncateUTCTime - , (==@) - , (@/=) - , (@==) - ) + ( GenerateKey (..) + , MonadFail + , RunDb + , TestFn (..) + , UUID (..) + , arbText + , asIO + , assertEmpty + , assertNotEmpty + , assertNotEqual + , isTravis + , liftA2 + , sqlSettingsUuid + , truncateTimeOfDay + , truncateToMicro + , truncateUTCTime + , (==@) + , (@/=) + , (@==) + ) -- re-exports import Control.Exception (SomeException) import Control.Monad (forM_, liftM, replicateM, void, when) import Control.Monad.Trans.Reader -import Data.Aeson (FromJSON, ToJSON, Value(..), object) +import Data.Aeson (FromJSON, ToJSON, Value (..), object) import qualified Data.Text.Encoding as TE import Database.Persist.Postgresql.JSON () import Database.Persist.Sql.Raw.QQ import Database.Persist.SqlBackend import Database.Persist.TH - ( MkPersistSettings(..) - , migrateModels - , mkEntityDefList - , mkMigrate - , mkPersist - , persistLowerCase - , persistUpperCase - , setImplicitIdDef - , share - , sqlSettings - ) + ( MkPersistSettings (..) + , migrateModels + , mkEntityDefList + , mkMigrate + , mkPersist + , persistLowerCase + , persistUpperCase + , setImplicitIdDef + , share + , sqlSettings + ) import Test.Hspec - ( Arg - , Spec - , SpecWith - , afterAll_ - , before - , beforeAll - , before_ - , describe - , fdescribe - , fit - , hspec - , it - ) + ( Arg + , Spec + , SpecWith + , afterAll_ + , before + , beforeAll + , before_ + , describe + , fdescribe + , fit + , hspec + , it + ) import Test.Hspec.Expectations.Lifted import Test.QuickCheck.Instances () import UnliftIO @@ -132,98 +137,111 @@ dockerPg :: IO (Maybe BS.ByteString) dockerPg = do - env <- liftIO getEnvironment - return $ case lookup "POSTGRES_NAME" env of - Just _name -> Just "postgres" -- /persistent/postgres - _ -> Nothing + env <- liftIO getEnvironment + return $ case lookup "POSTGRES_NAME" env of + Just _name -> Just "postgres" -- /persistent/postgres + _ -> Nothing persistSettings :: MkPersistSettings -persistSettings = sqlSettings { mpsGeneric = True } +persistSettings = sqlSettings{mpsGeneric = True} -runConn :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m () +runConn :: (MonadUnliftIO m) => SqlPersistT (LoggingT m) t -> m () runConn f = runConn_ f >>= const (return ()) -runConn_ :: MonadUnliftIO m => SqlPersistT (LoggingT m) t -> m t +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) +data RunConnType + = -- | Use 'withPostgresqlPool' + RunConnBasic + | -- | Use 'withPostgresqlPoolWithConf' + RunConnConf + deriving (Show, Eq) -runConnInternal :: MonadUnliftIO m => RunConnType -> SqlPersistT (LoggingT m) t -> m t +runConnInternal + :: (MonadUnliftIO m) => RunConnType -> SqlPersistT (LoggingT m) t -> m t runConnInternal connType f = do - travis <- liftIO isTravis - let debugPrint = not travis && _debugOn - 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") + travis <- liftIO isTravis + let + debugPrint = not travis && _debugOn + 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 - logInfoN (if travis then "Running in CI" else "CI not detected") - let go = - case connType of - RunConnBasic -> - withPostgresqlPool connString poolSize $ runSqlPool f - RunConnConf -> do - let conf = PostgresConf - { pgConnStr = connString - , pgPoolStripes = 1 - , pgPoolIdleTimeout = 60 - , pgPoolSize = poolSize - } - hooks = defaultPostgresConfHooks - withPostgresqlPoolWithConf conf hooks (runSqlPool f) - -- horrifying hack :( postgresql is having weird connection failures in - -- CI, for no reason that i can determine. see this PR for notes: - -- https://github.com/yesodweb/persistent/pull/1197 - eres <- try go - case eres of - Left (err :: SomeException) -> do - eres' <- try go - case eres' of - Left (err' :: SomeException) -> - if show err == show err' - then throwIO err - else throwIO err' - Right a -> - pure a - Right a -> - pure a + flip runLoggingT (\_ _ _ s -> printDebug s) $ do + logInfoN (if travis then "Running in CI" else "CI not detected") + let + go = + case connType of + RunConnBasic -> + withPostgresqlPool connString poolSize $ runSqlPool f + RunConnConf -> do + let + conf = + PostgresConf + { pgConnStr = connString + , pgPoolStripes = 1 + , pgPoolIdleTimeout = 60 + , pgPoolSize = poolSize + } + hooks = defaultPostgresConfHooks + withPostgresqlPoolWithConf conf hooks (runSqlPool f) + -- horrifying hack :( postgresql is having weird connection failures in + -- CI, for no reason that i can determine. see this PR for notes: + -- https://github.com/yesodweb/persistent/pull/1197 + eres <- try go + case eres of + Left (err :: SomeException) -> do + eres' <- try go + case eres' of + Left (err' :: SomeException) -> + if show err == show err' + then throwIO err + else throwIO err' + Right a -> + pure a + Right a -> + pure a runConnAssert :: SqlPersistT (LoggingT (ResourceT IO)) () -> Assertion runConnAssert actions = do - runResourceT $ runConn $ actions >> transactionUndo + 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) + runResourceT $ runConnInternal RunConnConf (actions >> transactionUndo) -newtype AValue = AValue { getValue :: Value } +newtype AValue = AValue {getValue :: Value} -- Need a specialized Arbitrary instance instance Arbitrary AValue where - arbitrary = AValue <$> - frequency [ (1, pure Null) - , (1, Bool <$> arbitrary) - , (2, Number <$> arbitrary) - , (2, String <$> arbText) - , (3, Array <$> limitIt 4 (fmap (fmap getValue) arbitrary)) - , (3, object <$> arbObject) - ] - where - limitIt :: Int -> Gen a -> Gen a - limitIt i x = sized $ \n -> do - let m = if n > i then i else n - resize m x - arbObject = limitIt 4 -- Recursion can make execution divergent + arbitrary = + AValue + <$> frequency + [ (1, pure Null) + , (1, Bool <$> arbitrary) + , (2, Number <$> arbitrary) + , (2, String <$> arbText) + , (3, Array <$> limitIt 4 (fmap (fmap getValue) arbitrary)) + , (3, object <$> arbObject) + ] + where + limitIt :: Int -> Gen a -> Gen a + limitIt i x = sized $ \n -> do + let + m = if n > i then i else n + resize m x + arbObject = + limitIt 4 -- Recursion can make execution divergent $ listOf -- [(,)] -> (,) - . liftA2 (,) arbText -- (,) -> Text and Value + . liftA2 (,) arbText -- (,) -> Text and Value $ limitIt 4 (fmap getValue arbitrary) -- Again, precaution against divergent recursion. diff --git a/test/PgIntervalTest.hs b/test/PgIntervalTest.hs --- a/test/PgIntervalTest.hs +++ b/test/PgIntervalTest.hs @@ -1,43 +1,74 @@ -{-# LANGUAGE EmptyDataDecls #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs, DataKinds, FlexibleInstances #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} module PgIntervalTest where +import Data.Fixed (Fixed (MkFixed), Micro, Pico) +import Data.Time.Clock (secondsToNominalDiffTime) +import Database.Persist.Postgresql (PgInterval (..)) +import qualified Database.PostgreSQL.Simple.Interval as Interval import PgInit -import Data.Time.Clock (NominalDiffTime) -import Database.Persist.Postgresql (PgInterval(..)) import Test.Hspec.QuickCheck -share [mkPersist sqlSettings, mkMigrate "pgIntervalMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "pgIntervalMigrate"] + [persistLowerCase| PgIntervalDb interval_field PgInterval deriving Eq deriving Show + +IntervalDb + interval_field Interval.Interval + deriving Eq 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 +clamp :: (Ord a) => a -> a -> a -> a +clamp lo hi = max lo . min hi +-- Before version 15, PostgreSQL can't parse all possible intervals. +-- Each component is limited to the range of Int32. +-- So anything beyond 2,147,483,647 hours will fail to parse. + +microsecondLimit :: Int64 +microsecondLimit = 2147483647 * 60 * 60 * 1000000 + specs :: Spec specs = do describe "Postgres Interval Property tests" $ do - prop "Round trips" $ \time -> runConnAssert $ do - let eg = PgIntervalDb $ PgInterval (truncate' time) + prop "Round trips" $ \int64 -> runConnAssert $ do + let + eg = + PgIntervalDb + . PgInterval + . secondsToNominalDiffTime + . (realToFrac :: Micro -> Pico) + . MkFixed + . toInteger + $ clamp (-microsecondLimit) microsecondLimit int64 rid <- insert eg r <- getJust rid liftIO $ r `shouldBe` eg + + prop "interval round trips" $ \(m, d, u) -> runConnAssert $ do + let + expected = + IntervalDb . Interval.MkInterval m d $ + clamp (-microsecondLimit) microsecondLimit u + key <- insert expected + actual <- getJust key + liftIO $ actual `shouldBe` expected diff --git a/test/UpsertWhere.hs b/test/UpsertWhere.hs --- a/test/UpsertWhere.hs +++ b/test/UpsertWhere.hs @@ -20,7 +20,9 @@ import Data.Time import Database.Persist.Postgresql -share [mkPersist sqlSettings, mkMigrate "upsertWhereMigrate"] [persistLowerCase| +share + [mkPersist sqlSettings, mkMigrate "upsertWhereMigrate"] + [persistLowerCase| Item name Text sqltype=varchar(80) @@ -47,12 +49,14 @@ deleteWhere ([] :: [Filter Item]) deleteWhere ([] :: [Filter ItemMigOnly]) -itDb :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) +itDb + :: String -> SqlPersistT (LoggingT (ResourceT IO)) a -> SpecWith (Arg (IO ())) itDb msg action = it msg $ runConnAssert $ void action specs :: Spec specs = describe "UpsertWhere" $ do - let item1 = Item "item1" "" (Just 3) Nothing + let + item1 = Item "item1" "" (Just 3) Nothing item2 = Item "item2" "hello world" Nothing (Just 2) items = [item1, item2] @@ -62,14 +66,15 @@ Just item <- fmap entityVal <$> getBy (UniqueName "item1") item `shouldBe` item1 itDb "performs only updates given if record already exists" $ do - let newDescription = "I am a new description" + let + newDescription = "I am a new description" insert_ item1 upsertWhere (Item "item1" "i am an inserted description" (Just 1) (Just 2)) [ItemDescription =. newDescription] [] Just item <- fmap entityVal <$> getBy (UniqueName "item1") - item `shouldBe` item1 { itemDescription = newDescription } + item `shouldBe` item1{itemDescription = newDescription} itDb "inserts with MigrationOnly fields (#1330)" $ do upsertWhere @@ -80,7 +85,8 @@ describe "upsertManyWhere" $ do itDb "inserts fresh records" $ do insertMany_ items - let newItem = Item "item3" "fresh" Nothing Nothing + let + newItem = Item "item3" "fresh" Nothing Nothing upsertManyWhere (newItem : items) [copyField ItemDescription] @@ -91,7 +97,7 @@ itDb "updates existing records" $ do let postUpdate = - map (\i -> i { itemQuantity = fmap (+1) (itemQuantity i) }) items + map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items insertMany_ items upsertManyWhere items @@ -102,8 +108,12 @@ dbItems `shouldMatchList` postUpdate itDb "only copies passing values" $ do insertMany_ items - let newItems = map (\i -> i { itemQuantity = Just 0, itemPrice = fmap (*2) (itemPrice i) }) items - postUpdate = map (\i -> i { itemPrice = fmap (*2) (itemPrice i) }) items + let + newItems = + map + (\i -> i{itemQuantity = Just 0, itemPrice = fmap (* 2) (itemPrice i)}) + items + postUpdate = map (\i -> i{itemPrice = fmap (* 2) (itemPrice i)}) items upsertManyWhere newItems [ copyUnlessEq ItemQuantity (Just 0) @@ -114,7 +124,8 @@ dbItems <- fmap entityVal <$> selectList [] [] dbItems `shouldMatchList` postUpdate itDb "inserts without modifying existing records if no updates specified" $ do - let newItem = Item "item3" "hi friends!" Nothing Nothing + let + newItem = Item "item3" "hi friends!" Nothing Nothing insertMany_ items upsertManyWhere (newItem : items) @@ -123,74 +134,85 @@ [] dbItems <- fmap entityVal <$> selectList [] [] dbItems `shouldMatchList` (newItem : items) - itDb "inserts without modifying existing records if no updates specified and there's a filter with True condition" $ - do - let newItem = Item "item3" "hi friends!" Nothing Nothing - insertMany_ items - upsertManyWhere - (newItem : items) - [] - [] - [ItemDescription ==. "hi friends!"] - dbItems <- fmap entityVal <$> selectList [] [] - dbItems `shouldMatchList` (newItem : items) - itDb "inserts without updating existing records if there are updates specified but there's a filter with a False condition" $ - do - let newItem = Item "item3" "hi friends!" Nothing Nothing - insertMany_ items - upsertManyWhere - (newItem : items) - [] - [ItemQuantity +=. Just 1] - [ItemDescription ==. "hi friends!"] - dbItems <- fmap entityVal <$> selectList [] [] - dbItems `shouldMatchList` (newItem : items) - itDb "inserts new records but does not update existing records if there are updates specified but the modification condition is False" $ - do - let newItem = Item "item3" "hi friends!" Nothing Nothing - insertMany_ items - upsertManyWhere - (newItem : items) - [] - [ItemQuantity +=. Just 1] - [excludeNotEqualToOriginal ItemDescription] - dbItems <- fmap entityVal <$> selectList [] [] - dbItems `shouldMatchList` (newItem : items) - itDb "inserts new records and updates existing records if there are updates specified and the modification condition is True (because it's empty)" $ - do - let newItem = Item "item3" "hello world" Nothing Nothing - postUpdate = map (\i -> i {itemQuantity = fmap (+ 1) (itemQuantity i)}) items - insertMany_ items - upsertManyWhere - (newItem : items) - [] - [ItemQuantity +=. Just 1] - [] - dbItems <- fmap entityVal <$> selectList [] [] - dbItems `shouldMatchList` (newItem : postUpdate) - itDb "inserts new records and updates existing records if there are updates specified and the modification filter condition is triggered" $ - do - let newItem = Item "item3" "hi friends!" Nothing Nothing - postUpdate = map (\i -> i {itemQuantity = fmap (+1) (itemQuantity i)}) items - insertMany_ items - upsertManyWhere - (newItem : items) - [ - copyUnlessEq ItemDescription "hi friends!" - , copyField ItemPrice - ] - [ItemQuantity +=. Just 1] - [ItemDescription !=. "bye friends!"] - dbItems <- fmap entityVal <$> selectList [] [] - dbItems `shouldMatchList` (newItem : postUpdate) - itDb "inserts an item and doesn't apply the update if the filter condition is triggered" $ - do - let newItem = Item "item3" "hello world" Nothing Nothing - insertMany_ items - upsertManyWhere - (newItem : items) - [] - [ItemQuantity +=. Just 1] - [excludeNotEqualToOriginal ItemDescription] - dbItems <- fmap entityVal <$> selectList [] [] - dbItems `shouldMatchList` (newItem : items) + itDb + "inserts without modifying existing records if no updates specified and there's a filter with True condition" + $ do + let + newItem = Item "item3" "hi friends!" Nothing Nothing + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [] + [ItemDescription ==. "hi friends!"] + dbItems <- fmap entityVal <$> selectList [] [] + dbItems `shouldMatchList` (newItem : items) + itDb + "inserts without updating existing records if there are updates specified but there's a filter with a False condition" + $ do + let + newItem = Item "item3" "hi friends!" Nothing Nothing + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [ItemDescription ==. "hi friends!"] + dbItems <- fmap entityVal <$> selectList [] [] + dbItems `shouldMatchList` (newItem : items) + itDb + "inserts new records but does not update existing records if there are updates specified but the modification condition is False" + $ do + let + newItem = Item "item3" "hi friends!" Nothing Nothing + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [excludeNotEqualToOriginal ItemDescription] + dbItems <- fmap entityVal <$> selectList [] [] + dbItems `shouldMatchList` (newItem : items) + itDb + "inserts new records and updates existing records if there are updates specified and the modification condition is True (because it's empty)" + $ do + let + newItem = Item "item3" "hello world" Nothing Nothing + postUpdate = map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [] + dbItems <- fmap entityVal <$> selectList [] [] + dbItems `shouldMatchList` (newItem : postUpdate) + itDb + "inserts new records and updates existing records if there are updates specified and the modification filter condition is triggered" + $ do + let + newItem = Item "item3" "hi friends!" Nothing Nothing + postUpdate = map (\i -> i{itemQuantity = fmap (+ 1) (itemQuantity i)}) items + insertMany_ items + upsertManyWhere + (newItem : items) + [ copyUnlessEq ItemDescription "hi friends!" + , copyField ItemPrice + ] + [ItemQuantity +=. Just 1] + [ItemDescription !=. "bye friends!"] + dbItems <- fmap entityVal <$> selectList [] [] + dbItems `shouldMatchList` (newItem : postUpdate) + itDb + "inserts an item and doesn't apply the update if the filter condition is triggered" + $ do + let + newItem = Item "item3" "hello world" Nothing Nothing + insertMany_ items + upsertManyWhere + (newItem : items) + [] + [ItemQuantity +=. Just 1] + [excludeNotEqualToOriginal ItemDescription] + dbItems <- fmap entityVal <$> selectList [] [] + dbItems `shouldMatchList` (newItem : items) diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -45,6 +45,7 @@ import qualified MigrationColumnLengthTest import qualified MigrationOnlyTest import qualified MigrationReferenceSpec +import qualified MigrationSpec import qualified MigrationTest import qualified MpsCustomPrefixTest import qualified MpsNoPrefixTest @@ -67,7 +68,9 @@ type Tuple = (,) -- Test lower case names -share [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] [persistLowerCase| +share + [mkPersist persistSettings, mkMigrate "dataTypeMigrate"] + [persistLowerCase| DataTypeTable no-json text Text textMaxLen Text maxlen=100 @@ -87,131 +90,139 @@ |] instance Arbitrary DataTypeTable where - arbitrary = DataTypeTable - <$> arbText -- text - <*> (T.take 100 <$> arbText) -- textManLen - <*> arbitrary -- bytes - <*> liftA2 (,) arbitrary arbText -- bytesTextTuple - <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen - <*> arbitrary -- int - <*> arbitrary -- intList - <*> arbitrary -- intMap - <*> arbitrary -- double - <*> arbitrary -- bool - <*> arbitrary -- day - <*> arbitrary -- pico - <*> (arbitrary) -- utc - <*> (truncateUTCTime =<< arbitrary) -- utc - <*> fmap getValue arbitrary -- value + arbitrary = + DataTypeTable + <$> arbText -- text + <*> (T.take 100 <$> arbText) -- textManLen + <*> arbitrary -- bytes + <*> liftA2 (,) arbitrary arbText -- bytesTextTuple + <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen + <*> arbitrary -- int + <*> arbitrary -- intList + <*> arbitrary -- intMap + <*> arbitrary -- double + <*> arbitrary -- bool + <*> arbitrary -- day + <*> arbitrary -- pico + <*> (arbitrary) -- utc + <*> (truncateUTCTime =<< arbitrary) -- utc + <*> fmap getValue arbitrary -- value -setup :: MonadIO m => Migration -> ReaderT SqlBackend m () +setup :: (MonadIO m) => Migration -> ReaderT SqlBackend m () setup migration = do - printMigration migration - runMigrationUnsafe migration + printMigration migration + runMigrationUnsafe migration main :: IO () main = do - runConn $ do - mapM_ setup - [ PersistentTest.testMigrate - , PersistentTest.noPrefixMigrate - , PersistentTest.customPrefixMigrate - , PersistentTest.treeMigrate - , EmbedTest.embedMigrate - , EmbedOrderTest.embedOrderMigrate - , LargeNumberTest.numberMigrate - , UniqueTest.uniqueMigrate - , MaxLenTest.maxlenMigrate - , MaybeFieldDefsTest.maybeFieldDefMigrate - , TypeLitFieldDefsTest.typeLitFieldDefsMigrate - , Recursive.recursiveMigrate - , CompositeTest.compositeMigrate - , TreeTest.treeMigrate - , PersistUniqueTest.migration - , RenameTest.migration - , CustomPersistFieldTest.customFieldMigrate - , PrimaryTest.migration - , CustomPrimaryKeyReferenceTest.migration - , MigrationColumnLengthTest.migration - , TransactionLevelTest.migration - , LongIdentifierTest.migration - , ForeignKey.compositeMigrate - , MigrationTest.migrationMigrate - , PgIntervalTest.pgIntervalMigrate - , UpsertWhere.upsertWhereMigrate - , ImplicitUuidSpec.implicitUuidMigrate - ] - PersistentTest.cleanDB - ForeignKey.cleanDB - - hspec $ do - ImplicitUuidSpec.spec - MigrationReferenceSpec.spec - RenameTest.specsWith runConnAssert - DataTypeTest.specsWith runConnAssert - (Just (runMigrationSilent dataTypeMigrate)) - [ TestFn "text" dataTypeTableText - , TestFn "textMaxLen" dataTypeTableTextMaxLen - , TestFn "bytes" dataTypeTableBytes - , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple - , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen - , TestFn "int" dataTypeTableInt - , TestFn "intList" dataTypeTableIntList - , TestFn "intMap" dataTypeTableIntMap - , TestFn "bool" dataTypeTableBool - , TestFn "day" dataTypeTableDay - , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) - , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) - , TestFn "jsonb" dataTypeTableJsonb - ] - [ ("pico", dataTypeTablePico) ] - dataTypeTableDouble - HtmlTest.specsWith - runConnAssert - (Just (runMigrationSilent HtmlTest.htmlMigrate)) + runConn $ do + mapM_ + setup + [ PersistentTest.testMigrate + , PersistentTest.noPrefixMigrate + , PersistentTest.customPrefixMigrate + , PersistentTest.treeMigrate + , EmbedTest.embedMigrate + , EmbedOrderTest.embedOrderMigrate + , LargeNumberTest.numberMigrate + , UniqueTest.uniqueMigrate + , MaxLenTest.maxlenMigrate + , MaybeFieldDefsTest.maybeFieldDefMigrate + , TypeLitFieldDefsTest.typeLitFieldDefsMigrate + , Recursive.recursiveMigrate + , CompositeTest.compositeMigrate + , TreeTest.treeMigrate + , PersistUniqueTest.migration + , RenameTest.migration + , CustomPersistFieldTest.customFieldMigrate + , PrimaryTest.migration + , CustomPrimaryKeyReferenceTest.migration + , MigrationColumnLengthTest.migration + , TransactionLevelTest.migration + , LongIdentifierTest.migration + , ForeignKey.compositeMigrate + , MigrationTest.migrationMigrate + , PgIntervalTest.pgIntervalMigrate + , UpsertWhere.upsertWhereMigrate + , ImplicitUuidSpec.implicitUuidMigrate + ] + PersistentTest.cleanDB + ForeignKey.cleanDB - EmbedTest.specsWith runConnAssert - EmbedOrderTest.specsWith runConnAssert - LargeNumberTest.specsWith runConnAssert - ForeignKey.specsWith runConnAssert - UniqueTest.specsWith runConnAssert - MaxLenTest.specsWith runConnAssert - MaybeFieldDefsTest.specsWith runConnAssert - TypeLitFieldDefsTest.specsWith runConnAssert - Recursive.specsWith runConnAssert - SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) - MigrationTest.specsWith runConnAssert - MigrationOnlyTest.specsWith runConnAssert + hspec $ do + ImplicitUuidSpec.spec + MigrationReferenceSpec.spec + MigrationSpec.spec + RenameTest.specsWith runConnAssert + DataTypeTest.specsWith + runConnAssert + (Just (runMigrationSilent dataTypeMigrate)) + [ TestFn "text" dataTypeTableText + , TestFn "textMaxLen" dataTypeTableTextMaxLen + , TestFn "bytes" dataTypeTableBytes + , TestFn "bytesTextTuple" dataTypeTableBytesTextTuple + , TestFn "bytesMaxLen" dataTypeTableBytesMaxLen + , TestFn "int" dataTypeTableInt + , TestFn "intList" dataTypeTableIntList + , TestFn "intMap" dataTypeTableIntMap + , TestFn "bool" dataTypeTableBool + , TestFn "day" dataTypeTableDay + , TestFn "time" (DataTypeTest.roundTime . dataTypeTableTime) + , TestFn "utc" (DataTypeTest.roundUTCTime . dataTypeTableUtc) + , TestFn "jsonb" dataTypeTableJsonb + ] + [("pico", dataTypeTablePico)] + dataTypeTableDouble + HtmlTest.specsWith + runConnAssert + (Just (runMigrationSilent HtmlTest.htmlMigrate)) - (Just - $ runMigrationSilent MigrationOnlyTest.migrateAll1 - >> runMigrationSilent MigrationOnlyTest.migrateAll2 - ) - PersistentTest.specsWith runConnAssert - ReadWriteTest.specsWith runConnAssert - PersistentTest.filterOrSpecs runConnAssert - RawSqlTest.specsWith runConnAssert - UpsertTest.specsWith - runConnAssert - UpsertTest.Don'tUpdateNull - UpsertTest.UpsertPreserveOldKey + EmbedTest.specsWith runConnAssert + EmbedOrderTest.specsWith runConnAssert + LargeNumberTest.specsWith runConnAssert + ForeignKey.specsWith runConnAssert + UniqueTest.specsWith runConnAssert + MaxLenTest.specsWith runConnAssert + MaybeFieldDefsTest.specsWith runConnAssert + TypeLitFieldDefsTest.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 runConnAssert + ReadWriteTest.specsWith runConnAssert + PersistentTest.filterOrSpecs runConnAssert + RawSqlTest.specsWith runConnAssert + UpsertTest.specsWith + runConnAssert + UpsertTest.Don'tUpdateNull + UpsertTest.UpsertPreserveOldKey - 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 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 - UpsertWhere.specs - PgIntervalTest.specs - ArrayAggTest.specs - GeneratedColumnTestSQL.specsWith runConnAssert + 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 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 + UpsertWhere.specs + PgIntervalTest.specs + ArrayAggTest.specs + GeneratedColumnTestSQL.specsWith runConnAssert