persistent-postgresql 2.13.7.0 → 2.14.0.0

raw patch · 15 files changed

+1529/−1342 lines, 15 filesdep +postgresql-simple-interval

Dependencies added: postgresql-simple-interval

Files

• ChangeLog.md +9/−0
• Database/Persist/Postgresql/Internal.hs +44/−105
• Database/Persist/Postgresql/JSON.hs +70/−54
• conn-killed/Main.hs +74/−57
• persistent-postgresql.cabal +3/−1
• test/ArrayAggTest.hs +40/−25
• test/CustomConstraintTest.hs +58/−43
• test/EquivalentTypeTestPostgres.hs +13/−8
• test/ImplicitUuidSpec.hs +12/−7
• test/JSONTest.hs +760/−680
• test/MigrationReferenceSpec.hs +16/−12
• test/PgInit.hs +143/−125
• test/PgIntervalTest.hs +54/−23
• test/UpsertWhere.hs +103/−81
• test/main.hs +130/−121

@@ -1,5 +1,14 @@ # Changelog for persistent-postgresql +## 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)

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-}  module Database.Persist.Postgresql.Internal@@ -35,6 +36,7 @@ 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@@ -46,29 +48,30 @@ 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.Bits (toIntegralSized) 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.Fixed (Fixed (..), Micro, 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 Data.Time+    ( NominalDiffTime+    , localTimeToUTC+    , nominalDiffTimeToSeconds+    , secondsToNominalDiffTime+    , utc+    ) import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util @@ -165,7 +168,7 @@         , (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.interval, convertPV $ toPersistValue @Interval.Interval)         , (k PS.bit, convertPV PersistInt64)         , (k PS.varbit, convertPV PersistInt64)         , (k PS.numeric, convertPV PersistRational)@@ -195,7 +198,7 @@         , (1183, listOf PersistTimeOfDay)         , (1115, listOf PersistUTCTime)         , (1185, listOf PersistUTCTime)-        , (1187, listOf (PersistLiteralEscaped . pgIntervalToBs))+        , (1187, listOf $ toPersistValue @Interval.Interval)         , (1561, listOf PersistInt64)         , (1563, listOf PersistInt64)         , (1231, listOf PersistRational)@@ -233,113 +236,49 @@  -- | 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) -pgIntervalToBs :: PgInterval -> ByteString-pgIntervalToBs = toStrictByteString . show . getPgInterval- instance PGTF.ToField PgInterval where-    toField (PgInterval t) = PGTF.toField t+    toField = PGTF.toField . pgIntervalToInterval  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."-        ]+    fromField f =+        maybe (PGFF.returnError PGFF.ConversionFailed f "invalid interval") pure+            . intervalToPgInterval+            <=< PGFF.fromField f  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+    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  -- | Indicates whether a Postgres Column is safe to drop. --

@@ -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

@@ -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"

@@ -1,5 +1,5 @@ name:               persistent-postgresql-version:            2.13.7.0+version:            2.14.0.0 license:            MIT license-file:       LICENSE author:             Felipe Lessa, Michael Snoyman <michael@snoyman.com>@@ -28,6 +28,7 @@     , persistent          >=2.13.3  && <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     , string-conversions@@ -82,6 +83,7 @@     , persistent-postgresql     , persistent-qq     , persistent-test+    , postgresql-simple-interval     , QuickCheck     , quickcheck-instances     , resourcet

@@ -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]

@@ -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 ()

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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.

@@ -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

@@ -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)

@@ -67,7 +67,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 +89,138 @@ |]  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+        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