packages feed

persistent-postgresql 2.13.7.0 → 2.14.3.0

raw patch · 19 files changed

Files

ChangeLog.md view
@@ -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)
Database/Persist/Postgresql.hs view
@@ -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
Database/Persist/Postgresql/Internal.hs view
@@ -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
+ Database/Persist/Postgresql/Internal/Migration.hs view
@@ -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)+                        ++ "]"
Database/Persist/Postgresql/JSON.hs view
@@ -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
conn-killed/Main.hs view
@@ -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"
persistent-postgresql.cabal view
@@ -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 <michael@snoyman.com>@@ -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
+ sql/getForeignKeyReferences.sql view
@@ -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;
test/ArrayAggTest.hs view
@@ -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]
test/CustomConstraintTest.hs view
@@ -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 ()
test/EquivalentTypeTestPostgres.hs view
@@ -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
test/ImplicitUuidSpec.hs view
@@ -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
test/JSONTest.hs view
@@ -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
test/MigrationReferenceSpec.hs view
@@ -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
+ test/MigrationSpec.hs view
@@ -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"+                               ]
test/PgInit.hs view
@@ -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.
test/PgIntervalTest.hs view
@@ -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
test/UpsertWhere.hs view
@@ -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)
test/main.hs view
@@ -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