From 96331257e4b457fe246e1b1e9bbc184420a3b23d Mon Sep 17 00:00:00 2001 From: Matt Parsons Date: Mon, 29 Mar 2021 14:47:20 -0600 Subject: [PATCH] get persistent 2.12 going (#243) * run mysql tests * uhhh why are you like this * stuff * tests pass locally * make the example work * minor bump * fix gha * k * no persistent-template dependency please * it passed? * ci nonsense * uh * i think that should do it * ok no really * i miss file-watch * sigh * come on pls * stylish haskell * i hate this --- README.md | 1 + cabal.project | 24 + changelog.md | 6 + esqueleto.cabal | 7 +- examples/Blog.hs | 3 +- examples/Main.hs | 3 +- src/Database/Esqueleto/Experimental.hs | 3 +- src/Database/Esqueleto/Internal/ExprParser.hs | 2 +- src/Database/Esqueleto/Internal/Internal.hs | 27 +- .../Esqueleto/Internal/PersistentImport.hs | 3 - src/Database/Esqueleto/PostgreSQL.hs | 5 +- .../Esqueleto/PostgreSQL/JSON/Instances.hs | 2 +- stack-8.8.yaml | 13 +- test/Common/Test.hs | 3 +- test/MySQL/Test.hs | 70 +- test/PostgreSQL/MigrateJSON.hs | 1 + test/PostgreSQL/Test.hs | 617 ++++++++++-------- 17 files changed, 457 insertions(+), 333 deletions(-) diff --git a/README.md b/README.md index 9906a99..e3cfaf1 100644 --- a/README.md +++ b/README.md @@ -487,5 +487,6 @@ user which can access it: ``` mysql> CREATE DATABASE esqutest; mysql> CREATE USER 'travis'@'localhost'; +mysql> ALTER USER 'travis'@'localhost' IDENTIFIED BY 'esqutest'; mysql> GRANT ALL ON esqutest.* TO 'travis'; ``` diff --git a/cabal.project b/cabal.project index e6fdbad..5132074 100644 --- a/cabal.project +++ b/cabal.project @@ -1 +1,25 @@ packages: . + +source-repository-package + type: git + location: https://github.com/yesodweb/persistent + tag: 03e794f618b9b8daa5ae9c3a4edfe792642df55c + subdir: persistent + +source-repository-package + type: git + location: https://github.com/yesodweb/persistent + tag: 03e794f618b9b8daa5ae9c3a4edfe792642df55c + subdir: persistent-postgresql + +source-repository-package + type: git + location: https://github.com/yesodweb/persistent + tag: 03e794f618b9b8daa5ae9c3a4edfe792642df55c + subdir: persistent-mysql + +source-repository-package + type: git + location: https://github.com/yesodweb/persistent + tag: 03e794f618b9b8daa5ae9c3a4edfe792642df55c + subdir: persistent-sqlite diff --git a/changelog.md b/changelog.md index 739a488..03a58ed 100644 --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,9 @@ +3.4.2.0 +======= +- @parsonsmatt + - [#243](https://github.com/bitemyapp/esqueleto/pull/243) + - Support `persistent-2.12` + 3.4.1.1 ======= - @MaxGabriel diff --git a/esqueleto.cabal b/esqueleto.cabal index faa7d85..feb65c9 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -1,7 +1,7 @@ cabal-version: 1.12 name: esqueleto -version: 3.4.1.1 +version: 3.4.2.0 synopsis: Type-safe EDSL for SQL queries on persistent backends. description: @esqueleto@ is a bare bones, type-safe EDSL for SQL queries that works with unmodified @persistent@ SQL backends. Its language closely resembles SQL, so you don't have to learn new concepts, just new syntax, and it's fairly easy to predict the generated SQL and optimize it for your backend. Most kinds of errors committed when writing SQL are caught as compile-time errors---although it is possible to write type-checked @esqueleto@ queries that fail at runtime. . @@ -53,7 +53,7 @@ library , conduit >=1.3 , containers , monad-logger - , persistent >=2.10.0 && <2.12 + , persistent >=2.12 && <2.13 , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 @@ -100,7 +100,6 @@ test-suite mysql , mysql-simple , persistent , persistent-mysql - , persistent-template , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 @@ -135,7 +134,6 @@ test-suite postgresql , mtl , persistent , persistent-postgresql - , persistent-template , postgresql-libpq , postgresql-simple , resourcet >=1.2 @@ -171,7 +169,6 @@ test-suite sqlite , mtl , persistent , persistent-sqlite - , persistent-template , resourcet >=1.2 , tagged >=0.2 , text >=0.11 && <1.3 diff --git a/examples/Blog.hs b/examples/Blog.hs index c593c6d..83bb054 100644 --- a/examples/Blog.hs +++ b/examples/Blog.hs @@ -11,7 +11,7 @@ module Blog import Control.Monad.Base (MonadBase (..)) import Control.Monad.IO.Unlift (MonadUnliftIO(..), wrappedWithRunInIO) -import Control.Monad.Logger (MonadLogger, NoLoggingT (..)) +import Control.Monad.Logger (MonadLoggerIO, MonadLogger, NoLoggingT (..)) import Control.Monad.Reader import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl (..), MonadTransControl (..), @@ -26,6 +26,7 @@ newtype BlogT m a = BlogT { unBlogT :: NoLoggingT (ReaderT ConnectionString m) a , MonadLogger , MonadReader ConnectionString , MonadIO + , MonadLoggerIO ) instance MonadUnliftIO m => MonadUnliftIO (BlogT m) where diff --git a/examples/Main.hs b/examples/Main.hs index 451044b..4bbf1b0 100644 --- a/examples/Main.hs +++ b/examples/Main.hs @@ -23,7 +23,7 @@ import Control.Monad (void) import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO) -import Control.Monad.Logger (MonadLogger) +import Control.Monad.Logger (MonadLogger, MonadLoggerIO) import Control.Monad.Reader (MonadReader(..), runReaderT) import Control.Monad.Trans.Control (MonadBaseControl) import Data.Monoid ((<>)) @@ -165,6 +165,7 @@ runDB :: (MonadReader ConnectionString m, MonadIO m, MonadBaseControl IO m, MonadUnliftIO m, + MonadLoggerIO m, MonadLogger m) => SqlPersistT m a -> m a runDB query = do diff --git a/src/Database/Esqueleto/Experimental.hs b/src/Database/Esqueleto/Experimental.hs index cb9c4af..7f8fbdd 100644 --- a/src/Database/Esqueleto/Experimental.hs +++ b/src/Database/Esqueleto/Experimental.hs @@ -227,6 +227,7 @@ import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Internal.Internal hiding (From, from, on) import Database.Esqueleto.Internal.PersistentImport import GHC.TypeLits +import Database.Persist (EntityNameDB(..)) -- $setup -- @@ -1040,7 +1041,7 @@ from parts = do runFrom :: From a -> SqlQuery (a, FromClause) runFrom e@Table = do let ed = entityDef $ getVal e - ident <- newIdentFor (entityDB ed) + ident <- newIdentFor . DBName . unEntityNameDB $ entityDB ed let entity = EEntity ident pure $ (entity, FromStart ident ed) where diff --git a/src/Database/Esqueleto/Internal/ExprParser.hs b/src/Database/Esqueleto/Internal/ExprParser.hs index f6c39ca..25efb9c 100644 --- a/src/Database/Esqueleto/Internal/ExprParser.hs +++ b/src/Database/Esqueleto/Internal/ExprParser.hs @@ -43,7 +43,7 @@ parseOnExpr sqlBackend text = do -- with postgresql, mysql, and sqlite backends. mkEscapeChar :: SqlBackend -> Either String Char mkEscapeChar sqlBackend = - case Text.uncons (connEscapeName sqlBackend (DBName "")) of + case Text.uncons (connEscapeRawName sqlBackend "") of Nothing -> Left "Failed to get an escape character from the SQL backend." Just (c, _) -> diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 37fa5b8..ddfe8aa 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -56,6 +56,7 @@ import Data.Typeable (Typeable) import Database.Esqueleto.Internal.ExprParser (TableAccess(..), parseOnExpr) import Database.Esqueleto.Internal.PersistentImport import qualified Database.Persist +import Database.Persist (FieldNameDB(..), EntityNameDB(..)) import Database.Persist.Sql.Util ( entityColumnCount , entityColumnNames @@ -64,6 +65,7 @@ import Database.Persist.Sql.Util , parseEntityValues ) import Text.Blaze.Html (Html) +import Data.Coerce (coerce) -- | (Internal) Start a 'from' query with an entity. 'from' -- does two kinds of magic using 'fromStart', 'fromJoin' and @@ -86,11 +88,14 @@ fromStart => SqlQuery (SqlExpr (PreprocessedFrom (SqlExpr (Entity a)))) fromStart = do let ed = entityDef (Proxy :: Proxy a) - ident <- newIdentFor (entityDB ed) + ident <- newIdentFor (coerce $ entityDB ed) let ret = EEntity ident f' = FromStart ident ed return (EPreprocessedFrom ret f') +-- | Copied from @persistent@ +newtype DBName = DBName { unDBName :: T.Text } + -- | (Internal) Same as 'fromStart', but entity may be missing. fromStartMaybe :: ( PersistEntity a @@ -568,7 +573,7 @@ e ^. field ] fieldIdent = case e of - EEntity _ -> fromDBName info (fieldDB fieldDef) + EEntity _ -> fromDBName info (coerce $ fieldDB fieldDef) EAliasedEntity baseI _ -> useIdent info $ aliasedEntityColumnIdent baseI fieldDef EAliasedEntityReference a b -> error $ unwords @@ -1805,7 +1810,7 @@ instance Show FromClause where where dummy = SqlBackend - { connEscapeName = \(DBName x) -> x + { connEscapeRawName = id } render' = T.unpack . renderExpr dummy @@ -2124,7 +2129,7 @@ instance ToSomeValues (SqlExpr (Value a)) where fieldName :: (PersistEntity val, PersistField typ) => IdentInfo -> EntityField val typ -> TLB.Builder -fieldName info = fromDBName info . fieldDB . persistFieldDef +fieldName info = fromDBName info . coerce . fieldDB . persistFieldDef -- FIXME: Composite/non-id pKS not supported on set setAux @@ -2140,7 +2145,7 @@ sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value sub mode query = ERaw Parens $ \info -> toRawSql mode info query fromDBName :: IdentInfo -> DBName -> TLB.Builder -fromDBName (conn, _) = TLB.fromText . connEscapeName conn +fromDBName (conn, _) = TLB.fromText . connEscapeRawName conn . unDBName existsHelper :: SqlQuery () -> SqlExpr (Value Bool) existsHelper = sub SELECT . (>> return true) @@ -2900,7 +2905,7 @@ makeFrom info mode fs = ret (useIdent info ident, mempty) base ident@(I identText) def = - let db@(DBName dbText) = entityDB def + let db@(DBName dbText) = coerce $ entityDB def in ( fromDBName info db <> if dbText == identText then mempty @@ -3030,7 +3035,7 @@ valueReferenceToRawSql sourceIdent columnIdentF info = aliasedEntityColumnIdent :: Ident -> FieldDef -> Ident aliasedEntityColumnIdent (I baseIdent) field = - I (baseIdent <> "_" <> (unDBName $ fieldDB field)) + I (baseIdent <> "_" <> (unDBName $ coerce $ fieldDB field)) aliasedColumnName :: Ident -> IdentInfo -> T.Text -> TLB.Builder aliasedColumnName (I baseIdent) info columnName = @@ -3064,11 +3069,11 @@ instance SqlSelect (SqlExpr InsertFinal) InsertFinal where sqlInsertInto info (EInsertFinal (EInsert p _)) = let fields = uncommas $ - map (fromDBName info . fieldDB) $ + map (fromDBName info . coerce . fieldDB) $ entityFields $ entityDef p table = - fromDBName info . entityDB . entityDef $ p + fromDBName info . DBName . coerce . entityDB . entityDef $ p in ("INSERT INTO " <> table <> parens fields <> "\n", []) sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info @@ -3084,8 +3089,8 @@ instance SqlSelect () () where unescapedColumnNames :: EntityDef -> [DBName] unescapedColumnNames ent = - (if hasCompositeKey ent then id else ( fieldDB (entityId ent) :)) - $ map fieldDB (entityFields ent) + (if hasCompositeKey ent then id else ( coerce (fieldDB (entityId ent)) :)) + $ map (coerce . fieldDB) (entityFields ent) -- | You may return an 'Entity' from a 'select' query. instance PersistEntity a => SqlSelect (SqlExpr (Entity a)) (Entity a) where diff --git a/src/Database/Esqueleto/Internal/PersistentImport.hs b/src/Database/Esqueleto/Internal/PersistentImport.hs index 84e8582..5a90c4f 100644 --- a/src/Database/Esqueleto/Internal/PersistentImport.hs +++ b/src/Database/Esqueleto/Internal/PersistentImport.hs @@ -53,7 +53,6 @@ module Database.Esqueleto.Internal.PersistentImport rawQuery, rawQueryRes, rawSql, - askLogFunc, close', createSqlPool, liftSqlPersistMPool, @@ -118,7 +117,6 @@ module Database.Esqueleto.Internal.PersistentImport Attr, Checkmark(..), CompositeDef(..), - DBName(..), EmbedEntityDef(..), EmbedFieldDef(..), EntityDef(..), @@ -127,7 +125,6 @@ module Database.Esqueleto.Internal.PersistentImport FieldType(..), ForeignDef(..), ForeignFieldDef, - HaskellName(..), IsNullable(..), OnlyUniqueException(..), PersistException(..), diff --git a/src/Database/Esqueleto/PostgreSQL.hs b/src/Database/Esqueleto/PostgreSQL.hs index 8a898b9..bd8685c 100644 --- a/src/Database/Esqueleto/PostgreSQL.hs +++ b/src/Database/Esqueleto/PostgreSQL.hs @@ -47,6 +47,7 @@ import Data.Time.Clock (UTCTime) import Database.Esqueleto.Internal.Internal hiding (random_) import Database.Esqueleto.Internal.PersistentImport hiding (upsert, upsertBy) import Database.Persist.Class (OnlyOneUniqueKey) +import Database.Persist (ConstraintNameDB(..), EntityNameDB(..)) -- | (@random()@) Split out into database specific modules -- because MySQL uses `rand()`. @@ -306,10 +307,10 @@ insertSelectWithConflictCount unique query conflictQuery = do updates = conflictQuery entCurrent entExcluded combine (tlb1,vals1) (tlb2,vals2) = (builderToText (tlb1 `mappend` tlb2), vals1 ++ vals2) entExcluded = EEntity $ I "excluded" - tableName = unDBName . entityDB . entityDef + tableName = unEntityNameDB . entityDB . entityDef entCurrent = EEntity $ I (tableName proxy) uniqueDef = toUniqueDef unique - constraint = TLB.fromText . unDBName . uniqueDBName $ uniqueDef + constraint = TLB.fromText . unConstraintNameDB . uniqueDBName $ uniqueDef renderedUpdates :: (BackendCompatible SqlBackend backend) => backend -> (TLB.Builder, [PersistValue]) renderedUpdates conn = renderUpdates conn updates conflict conn = (mconcat ([ diff --git a/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs b/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs index 0f85170..73d9585 100644 --- a/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs +++ b/src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs @@ -87,7 +87,7 @@ instance IsString JSONAccessor where -- | @since 3.1.0 instance (FromJSON a, ToJSON a) => PersistField (JSONB a) where - toPersistValue = PersistDbSpecific . BSL.toStrict . encode . unJSONB + toPersistValue = PersistLiteralEscaped . BSL.toStrict . encode . unJSONB fromPersistValue pVal = fmap JSONB $ case pVal of PersistByteString bs -> first (badParse $ TE.decodeUtf8 bs) $ eitherDecodeStrict bs PersistText t -> first (badParse t) $ eitherDecodeStrict (TE.encodeUtf8 t) diff --git a/stack-8.8.yaml b/stack-8.8.yaml index 3ef0be4..f1757f4 100644 --- a/stack-8.8.yaml +++ b/stack-8.8.yaml @@ -5,8 +5,11 @@ packages: - 'examples' extra-deps: -- persistent-2.11.0.0 -- persistent-template-2.9.1.0 -- persistent-mysql-2.10.3 -- persistent-postgresql-2.11.0.0 -- persistent-sqlite-2.11.0.0 +- git: https://www.github.com/yesodweb/persistent + commit: 03e794f618b9b8daa5ae9c3a4edfe792642df55c + subdirs: + - persistent + - persistent-template + - persistent-mysql + - persistent-postgresql + - persistent-sqlite diff --git a/test/Common/Test.hs b/test/Common/Test.hs index 414908e..74469f7 100644 --- a/test/Common/Test.hs +++ b/test/Common/Test.hs @@ -71,7 +71,7 @@ import Data.Time import Control.Monad.Fail (MonadFail) #endif import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (MonadLogger(..), NoLoggingT, runNoLoggingT) +import Control.Monad.Logger (MonadLoggerIO(..), MonadLogger(..), NoLoggingT, runNoLoggingT) import Control.Monad.Trans.Reader (ReaderT) import qualified Data.Attoparsec.Text as AP import Data.Char (toLower, toUpper) @@ -2507,6 +2507,7 @@ insert' v = flip Entity v <$> insert v type RunDbMonad m = ( MonadUnliftIO m , MonadIO m + , MonadLoggerIO m , MonadLogger m , MonadCatch m ) diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index fb073af..61bc7a0 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -1,27 +1,30 @@ -{-# LANGUAGE ScopedTypeVariables - , FlexibleContexts - , RankNTypes - , TypeFamilies - , TypeApplications -#-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where +import Control.Applicative import Control.Monad (void) import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) +import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) import Control.Monad.Trans.Reader (ReaderT) -import Database.Persist.MySQL ( withMySQLConn - , connectHost - , connectDatabase - , connectUser - , connectPassword - , connectPort - , defaultConnectInfo) +import qualified Control.Monad.Trans.Resource as R import Database.Esqueleto import Database.Esqueleto.Experimental hiding (from, on) import qualified Database.Esqueleto.Experimental as Experimental -import qualified Control.Monad.Trans.Resource as R +import Database.Persist.MySQL + ( connectDatabase + , connectHost + , connectPassword + , connectPort + , connectUser + , defaultConnectInfo + , withMySQLConn + ) +import System.Environment import Test.Hspec import Common.Test @@ -237,12 +240,31 @@ migrateIt = do withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a -withConn = - R.runResourceT . - withMySQLConn defaultConnectInfo - { connectHost = "127.0.0.1" - , connectUser = "travis" - , connectPassword = "esqutest" - , connectDatabase = "esqutest" - , connectPort = 33306 - } +withConn f = do + ci <- liftIO isCI + let connInfo + | ci = + defaultConnectInfo + { connectHost = "127.0.0.1" + , connectUser = "travis" + , connectPassword = "esqutest" + , connectDatabase = "esqutest" + , connectPort = 33306 + } + | otherwise = + defaultConnectInfo + { connectHost = "localhost" + , connectUser = "travis" + , connectPassword = "esqutest" + , connectDatabase = "esqutest" + , connectPort = 3306 + } + R.runResourceT $ withMySQLConn connInfo f + +isCI :: IO Bool +isCI = do + env <- getEnvironment + return $ case lookup "TRAVIS" env <|> lookup "CI" env of + Just "true" -> True + _ -> False + diff --git a/test/PostgreSQL/MigrateJSON.hs b/test/PostgreSQL/MigrateJSON.hs index 2899c85..b450524 100644 --- a/test/PostgreSQL/MigrateJSON.hs +++ b/test/PostgreSQL/MigrateJSON.hs @@ -30,6 +30,7 @@ import Common.Test (RunDbMonad) share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase| Json value (JSONB Value) + deriving Show |] cleanJSON diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index b1b3a10..d36ebf8 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1,47 +1,47 @@ {-# OPTIONS_GHC -fno-warn-unused-binds #-} -{-# LANGUAGE FlexibleContexts - , LambdaCase - , NamedFieldPuns - , OverloadedStrings - , RankNTypes - , ScopedTypeVariables - , TypeApplications - , TypeFamilies - , PartialTypeSignatures - #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} module Main (main) where -import Data.Coerce -import Data.Foldable -import qualified Data.Map.Strict as Map -import Data.Map (Map) -import Data.Time import Control.Arrow ((&&&)) import Control.Monad (void, when) -import Control.Monad.Catch (MonadCatch, catch) +import Control.Monad.Catch import Control.Monad.IO.Class (MonadIO(liftIO)) -import Control.Monad.Logger (runStderrLoggingT, runNoLoggingT) +import Control.Monad.Logger (runNoLoggingT, runStderrLoggingT) import Control.Monad.Trans.Reader (ReaderT, ask) import qualified Control.Monad.Trans.Resource as R import Data.Aeson hiding (Value) import qualified Data.Aeson as A (Value) import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as BSL import qualified Data.Char as Char +import Data.Coerce +import Data.Foldable import qualified Data.List as L +import Data.Map (Map) +import qualified Data.Map.Strict as Map import Data.Ord (comparing) import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Data.Time.Clock (getCurrentTime, diffUTCTime, UTCTime) +import Data.Time +import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) import Database.Esqueleto hiding (random_) -import Database.Esqueleto.Experimental hiding (random_, from, on) +import Database.Esqueleto.Experimental hiding (from, on, random_) import qualified Database.Esqueleto.Experimental as Experimental import qualified Database.Esqueleto.Internal.Sql as ES import Database.Esqueleto.PostgreSQL (random_) import qualified Database.Esqueleto.PostgreSQL as EP -import Database.Esqueleto.PostgreSQL.JSON hiding ((?.), (-.), (||.)) +import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON import Database.Persist.Postgresql (withPostgresqlConn) -import Database.PostgreSQL.Simple (SqlError(..), ExecStatus(..)) +import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) import System.Environment import Test.Hspec import Test.Hspec.QuickCheck @@ -570,11 +570,6 @@ testPostgresModule = do -- | Get the time diff and check it's less than a second liftIO $ diffUTCTime nowUtc now `shouldSatisfy` (< oneSecond) - ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- ---------------- JSON --------------- JSON --------------- JSON --------------- - testJSONInsertions :: Spec testJSONInsertions = describe "JSON Insertions" $ do @@ -619,14 +614,14 @@ testArrowJSONB = createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) ->. "a") "SELECT (? -> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":true}" + [ PersistLiteralEscaped "{\"a\":true}" , PersistText "a" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [1 :: Int,2,3]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" ->. 1) "SELECT ((? -> ?) -> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[1,2,3]}" + [ PersistLiteralEscaped "{\"a\":[1,2,3]}" , PersistText "a" , PersistInt64 1 ] it "works as expected" $ run $ do @@ -644,14 +639,14 @@ testArrowText = createSaneSQL (jsonbVal (object ["a" .= True]) ->>. "a") "SELECT (? ->> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":true}" + [ PersistLiteralEscaped "{\"a\":true}" , PersistText "a" ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [1 :: Int,2,3]] createSaneSQL (jsonbVal obj ->. "a" ->>. 1) "SELECT ((? -> ?) ->> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[1,2,3]}" + [ PersistLiteralEscaped "{\"a\":[1,2,3]}" , PersistText "a" , PersistInt64 1 ] it "works as expected" $ run $ do @@ -670,14 +665,14 @@ testHashArrowJSONB = createSaneSQL @JSONValue (jsonbVal (object ["a" .= True]) #>. list) "SELECT (? #> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":true}" + [ PersistLiteralEscaped "{\"a\":true}" , persistTextArray list ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj #>. ["a","1"] #>. ["b"]) "SELECT ((? #> ?) #> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" + [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] it "works as expected" $ run $ do @@ -696,14 +691,14 @@ testHashArrowText = createSaneSQL (jsonbVal (object ["a" .= True]) #>>. list) "SELECT (? #>> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":true}" + [ PersistLiteralEscaped "{\"a\":true}" , persistTextArray list ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL (jsonbVal obj #>. ["a","1"] #>>. ["b"]) "SELECT ((? #> ?) #>> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" + [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" , persistTextArray ["a","1"] , persistTextArray ["b"] ] it "works as expected" $ run $ do @@ -725,130 +720,155 @@ testFilterOperators = testInclusion :: Spec testInclusion = do - describe "@>" $ do - it "creates sane SQL" $ - createSaneSQL - (jsonbVal (object ["a" .= False, "b" .= True]) @>. jsonbVal (object ["a" .= False])) - "SELECT (? @> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , PersistDbSpecific "{\"a\":false}" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL - (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True])) - "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , PersistText "a" - , PersistDbSpecific "{\"b\":true}" ] - it "works as expected" $ run $ do - x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1) - y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]]) - z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14]) - liftIO $ length x `shouldBe` 2 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 1 - describe "<@" $ do - it "creates sane SQL" $ - createSaneSQL - (jsonbVal (object ["a" .= False]) <@. jsonbVal (object ["a" .= False, "b" .= True])) - "SELECT (? <@ ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false}" - , PersistDbSpecific "{\"a\":false,\"b\":true}" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL - (jsonbVal obj ->. "a" <@. jsonbVal (object ["b" .= True, "c" .= Null])) - "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , PersistText "a" - , PersistDbSpecific "{\"b\":true,\"c\":null}" ] - it "works as expected" $ run $ do - x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1]) - y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null]) - z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"]) - liftIO $ length x `shouldBe` 2 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 1 + describe "@>" $ do + it "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj @>. jsonbVal (object ["a" .= False])) + "SELECT (? @> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistLiteralEscaped "{\"a\":false}" + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj ->. "a" @>. jsonbVal (object ["b" .= True])) + "SELECT ((? -> ?) @> ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + , PersistLiteralEscaped "{\"b\":true}" + ] + it "works as expected" $ run $ do + x <- selectJSONwhere $ \v -> v @>. jsonbVal (Number 1) + y <- selectJSONwhere $ \v -> v @>. jsonbVal (toJSON [object ["a" .= Number 3.14]]) + z <- selectJSONwhere $ \v -> v ->. 1 @>. jsonbVal (object ["a" .= Number 3.14]) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + describe "<@" $ do + it "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal (object ["a" .= False]) <@. jsonbVal obj ) + "SELECT (? <@ ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":false}" + , PersistLiteralEscaped encoded + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + obj' = object ["b" .= True, "c" .= Null] + encoded = BSL.toStrict $ encode obj' + createSaneSQL + (jsonbVal obj ->. "a" <@. jsonbVal obj') + "SELECT ((? -> ?) <@ ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped "{\"a\":[{\"b\":true}]}" + , PersistText "a" + , PersistLiteralEscaped encoded + ] + it "works as expected" $ run $ do + x <- selectJSONwhere $ \v -> v <@. jsonbVal (toJSON [Number 1]) + y <- selectJSONwhere $ \v -> v <@. jsonbVal (object ["a" .= (1 :: Int), "b" .= False, "c" .= Null]) + z <- selectJSONwhere $ \v -> v #>. ["a","b"] <@. jsonbVal (object ["b" .= False, "c" .= String "message"]) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 testQMark :: Spec -testQMark = - describe "Question Mark" $ do - it "creates sane SQL" $ - createSaneSQL - (jsonbVal (object ["a" .= False, "b" .= True]) JSON.?. "a") - "SELECT (? ?? ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , PersistText "a" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL - (jsonbVal obj #>. ["a","0"] JSON.?. "b") - "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , persistTextArray ["a","0"] - , PersistText "b" ] - it "works as expected" $ run $ do - x <- selectJSONwhere (JSON.?. "a") - y <- selectJSONwhere (JSON.?. "test") - z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b" - liftIO $ length x `shouldBe` 2 - liftIO $ length y `shouldBe` 2 - liftIO $ length z `shouldBe` 1 +testQMark = do + describe "Question Mark" $ do + it "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj JSON.?. "a") + "SELECT (? ?? ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj #>. ["a","0"] JSON.?. "b") + "SELECT ((? #> ?) ?? ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , PersistText "b" + ] + it "works as expected" $ run $ do + x <- selectJSONwhere (JSON.?. "a") + y <- selectJSONwhere (JSON.?. "test") + z <- selectJSONwhere $ \v -> v ->. "a" JSON.?. "b" + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 2 + liftIO $ length z `shouldBe` 1 testQMarkAny :: Spec -testQMarkAny = - describe "Question Mark (Any)" $ do - it "creates sane SQL" $ - createSaneSQL - (jsonbVal (object ["a" .= False, "b" .= True]) ?|. ["a","c"]) - "SELECT (? ??| ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , persistTextArray ["a","c"] ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL - (jsonbVal obj #>. ["a","0"] ?|. ["b","c"]) - "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , persistTextArray ["a","0"] - , persistTextArray ["b","c"] ] - it "works as expected" $ run $ do - x <- selectJSONwhere (?|. ["b","test"]) - y <- selectJSONwhere (?|. ["a"]) - z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"] - w <- selectJSONwhere (?|. []) - liftIO $ length x `shouldBe` 3 - liftIO $ length y `shouldBe` 2 - liftIO $ length z `shouldBe` 1 - liftIO $ length w `shouldBe` 0 +testQMarkAny = do + describe "Question Mark (Any)" $ do + it "creates sane SQL" $ do + let obj = (object ["a" .= False, "b" .= True]) + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj ?|. ["a","c"]) + "SELECT (? ??| ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","c"] + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj #>. ["a","0"] ?|. ["b","c"]) + "SELECT ((? #> ?) ??| ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , persistTextArray ["b","c"] + ] + it "works as expected" $ run $ do + x <- selectJSONwhere (?|. ["b","test"]) + y <- selectJSONwhere (?|. ["a"]) + z <- selectJSONwhere $ \v -> v ->. (-3) ?|. ["a"] + w <- selectJSONwhere (?|. []) + liftIO $ length x `shouldBe` 3 + liftIO $ length y `shouldBe` 2 + liftIO $ length z `shouldBe` 1 + liftIO $ length w `shouldBe` 0 testQMarkAll :: Spec -testQMarkAll = - describe "Question Mark (All)" $ do - it "creates sane SQL" $ - createSaneSQL - (jsonbVal (object ["a" .= False, "b" .= True]) ?&. ["a","c"]) - "SELECT (? ??& ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , persistTextArray ["a","c"] ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL - (jsonbVal obj #>. ["a","0"] ?&. ["b","c"]) - "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , persistTextArray ["a","0"] - , persistTextArray ["b","c"] ] - it "works as expected" $ run $ do - x <- selectJSONwhere (?&. ["test"]) - y <- selectJSONwhere (?&. ["a","b"]) - z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"] - w <- selectJSONwhere (?&. []) - liftIO $ length x `shouldBe` 2 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 1 - liftIO $ length w `shouldBe` 9 - +testQMarkAll = do + describe "Question Mark (All)" $ do + it "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj ?&. ["a","c"]) + "SELECT (? ??& ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","c"] + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL + (jsonbVal obj #>. ["a","0"] ?&. ["b","c"]) + "SELECT ((? #> ?) ??& ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , persistTextArray ["b","c"] + ] + it "works as expected" $ run $ do + x <- selectJSONwhere (?&. ["test"]) + y <- selectJSONwhere (?&. ["a","b"]) + z <- selectJSONwhere $ \v -> v ->. "a" ?&. ["b"] + w <- selectJSONwhere (?&. []) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 1 + liftIO $ length w `shouldBe` 9 testConcatDeleteOperators :: Spec testConcatDeleteOperators = do @@ -859,120 +879,135 @@ testConcatDeleteOperators = do testHashMinusOperator testConcatenationOperator :: Spec -testConcatenationOperator = - describe "Concatenation" $ do - it "creates sane SQL" $ - createSaneSQL @JSONValue - (jsonbVal (object ["a" .= False, "b" .= True]) - JSON.||. jsonbVal (object ["c" .= Null])) - "SELECT (? || ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , PersistDbSpecific "{\"c\":null}" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL @JSONValue - (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null])) - "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , PersistText "a" - , PersistDbSpecific "[null]" ] - it "works as expected" $ run $ do - x <- selectJSON $ \v -> do - where_ $ v @>. jsonbVal (object []) - where_ $ v JSON.||. jsonbVal (object ["x" .= True]) - @>. jsonbVal (object ["x" .= True]) - y <- selectJSONwhere $ \v -> - v JSON.||. jsonbVal (toJSON [String "a", String "b"]) - ->>. 4 ==. just (val "b") - z <- selectJSONwhere $ \v -> - v JSON.||. jsonbVal (toJSON [Bool False]) - ->. 0 JSON.@>. jsonbVal (Number 1) - w <- selectJSON $ \v -> do - where_ . not_ $ v @>. jsonbVal (object []) - where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1") - liftIO $ length x `shouldBe` 2 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 2 - liftIO $ length w `shouldBe` 7 - sqlFailWith "22023" $ selectJSONwhere $ \v -> - v JSON.||. jsonbVal (toJSON $ String "test") - @>. jsonbVal (String "test") +testConcatenationOperator = do + describe "Concatenation" $ do + it "creates sane SQL" $ do + let objAB = object ["a" .= False, "b" .= True] + objC = object ["c" .= Null] + createSaneSQL @JSONValue + (jsonbVal objAB + JSON.||. jsonbVal objC) + "SELECT (? || ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped $ BSL.toStrict $ encode objAB + , PersistLiteralEscaped $ BSL.toStrict $ encode objC + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" JSON.||. jsonbVal (toJSON [Null])) + "SELECT ((? -> ?) || ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + , PersistLiteralEscaped "[null]" + ] + it "works as expected" $ run $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) + where_ $ v JSON.||. jsonbVal (object ["x" .= True]) + @>. jsonbVal (object ["x" .= True]) + y <- selectJSONwhere $ \v -> + v JSON.||. jsonbVal (toJSON [String "a", String "b"]) + ->>. 4 ==. just (val "b") + z <- selectJSONwhere $ \v -> + v JSON.||. jsonbVal (toJSON [Bool False]) + ->. 0 JSON.@>. jsonbVal (Number 1) + w <- selectJSON $ \v -> do + where_ . not_ $ v @>. jsonbVal (object []) + where_ $ jsonbVal (String "test1") JSON.||. v ->>. 0 ==. just (val "test1") + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 2 + liftIO $ length w `shouldBe` 7 testMinusOperator :: Spec testMinusOperator = - describe "Minus Operator" $ do - it "creates sane SQL" $ - createSaneSQL @JSONValue - (jsonbVal (object ["a" .= False, "b" .= True]) JSON.-. "a") - "SELECT (? - ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , PersistText "a" ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL @JSONValue - (jsonbVal obj ->. "a" JSON.-. 0) - "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , PersistText "a" - , PersistInt64 0 ] - it "works as expected" $ run $ do - x <- selectJSON $ \v -> do - where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) - where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True]) - y <- selectJSON $ \v -> do - where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) - where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null]) - z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"] - w <- selectJSON_ $ \v -> do - v JSON.-. "test" @>. jsonbVal (toJSON [String "test"]) - liftIO $ length x `shouldBe` 2 - liftIO $ length y `shouldBe` 1 - liftIO $ length z `shouldBe` 0 - liftIO $ length w `shouldBe` 0 - sqlFailWith "22023" $ selectJSONwhere $ \v -> - v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int])) - where selectJSON_ f = selectJSON $ \v -> do - where_ $ v @>. jsonbVal (object []) - ||. v @>. jsonbVal (toJSON ([] :: [Int])) - where_ $ f v + describe "Minus Operator" $ do + it "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj JSON.-. "a") + "SELECT (? - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj ->. "a" JSON.-. 0) + "SELECT ((? -> ?) - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , PersistText "a" + , PersistInt64 0 + ] + it "works as expected" $ run $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v JSON.-. 0 @>. jsonbVal (toJSON [Bool True]) + y <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v JSON.-. (-1) @>. jsonbVal (toJSON [Null]) + z <- selectJSON_ $ \v -> v JSON.-. "b" ?&. ["a", "b"] + w <- selectJSON_ $ \v -> do + v JSON.-. "test" @>. jsonbVal (toJSON [String "test"]) + liftIO $ length x `shouldBe` 2 + liftIO $ length y `shouldBe` 1 + liftIO $ length z `shouldBe` 0 + liftIO $ length w `shouldBe` 0 + sqlFailWith "22023" $ selectJSONwhere $ \v -> + v JSON.-. 0 @>. jsonbVal (toJSON ([] :: [Int])) + where + selectJSON_ f = selectJSON $ \v -> do + where_ + $ v @>. jsonbVal (object []) + ||. v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ f v testMinusOperatorV10 :: Spec -testMinusOperatorV10 = - describe "Minus Operator (PSQL >= v10)" $ do - it "creates sane SQL" $ - createSaneSQL @JSONValue - (jsonbVal (object ["a" .= False, "b" .= True]) --. ["a","b"]) - "SELECT (? - ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" - , persistTextArray ["a","b"] ] - it "creates sane SQL (chained)" $ do - let obj = object ["a" .= [object ["b" .= True]]] - createSaneSQL @JSONValue - (jsonbVal obj #>. ["a","0"] --. ["b"]) - "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" - , persistTextArray ["a","0"] - , persistTextArray ["b"] ] - it "works as expected" $ run $ do - x <- selectJSON $ \v -> do - where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) - where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"]) - y <- selectJSON $ \v -> do - where_ $ v @>. jsonbVal (object []) - where_ $ v --. ["a","b"] <@. jsonbVal (object []) - z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)]) - w <- selectJSON_ $ \v -> do - v --. ["test"] @>. jsonbVal (toJSON [String "test"]) - liftIO $ length x `shouldBe` 0 - liftIO $ length y `shouldBe` 2 - liftIO $ length z `shouldBe` 1 - liftIO $ length w `shouldBe` 0 - sqlFailWith "22023" $ selectJSONwhere $ \v -> - v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int])) - where selectJSON_ f = selectJSON $ \v -> do - where_ $ v @>. jsonbVal (object []) +testMinusOperatorV10 = do + describe "Minus Operator (PSQL >= v10)" $ do + it "creates sane SQL" $ do + let obj = object ["a" .= False, "b" .= True] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj --. ["a","b"]) + "SELECT (? - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","b"] + ] + it "creates sane SQL (chained)" $ do + let obj = object ["a" .= [object ["b" .= True]]] + encoded = BSL.toStrict $ encode obj + createSaneSQL @JSONValue + (jsonbVal obj #>. ["a","0"] --. ["b"]) + "SELECT ((? #> ?) - ?)\nFROM \"Json\"\n" + [ PersistLiteralEscaped encoded + , persistTextArray ["a","0"] + , persistTextArray ["b"] + ] + it "works as expected" $ run $ do + x <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (toJSON ([] :: [Int])) + where_ $ v --. ["test","a"] @>. jsonbVal (toJSON [String "test"]) + y <- selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) + where_ $ v --. ["a","b"] <@. jsonbVal (object []) + z <- selectJSON_ $ \v -> v --. ["b"] <@. jsonbVal (object ["a" .= (1 :: Int)]) + w <- selectJSON_ $ \v -> do + v --. ["test"] @>. jsonbVal (toJSON [String "test"]) + liftIO $ length x `shouldBe` 0 + liftIO $ length y `shouldBe` 2 + liftIO $ length z `shouldBe` 1 + liftIO $ length w `shouldBe` 0 + sqlFailWith "22023" $ selectJSONwhere $ \v -> + v --. ["a"] @>. jsonbVal (toJSON ([] :: [Int])) + where + selectJSON_ f = selectJSON $ \v -> do + where_ $ v @>. jsonbVal (object []) ||. v @>. jsonbVal (toJSON ([] :: [Int])) - where_ $ f v + where_ $ f v testHashMinusOperator :: Spec testHashMinusOperator = @@ -981,14 +1016,14 @@ testHashMinusOperator = createSaneSQL @JSONValue (jsonbVal (object ["a" .= False, "b" .= True]) #-. ["a"]) "SELECT (? #- ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":false,\"b\":true}" + [ PersistLiteralEscaped (BSL.toStrict $ encode $ object ["a" .= False, "b" .= True]) , persistTextArray ["a"] ] it "creates sane SQL (chained)" $ do let obj = object ["a" .= [object ["b" .= True]]] createSaneSQL @JSONValue (jsonbVal obj ->. "a" #-. ["0","b"]) "SELECT ((? -> ?) #- ?)\nFROM \"Json\"\n" - [ PersistDbSpecific "{\"a\":[{\"b\":true}]}" + [ PersistLiteralEscaped (BSL.toStrict $ encode obj) , PersistText "a" , persistTextArray ["0","b"] ] it "works as expected" $ run $ do @@ -1309,20 +1344,30 @@ fromValue act = from $ \x -> do persistTextArray :: [T.Text] -> PersistValue persistTextArray = PersistArray . fmap PersistText -sqlFailWith :: (MonadCatch m, MonadIO m) => ByteString -> SqlPersistT (R.ResourceT m) a -> SqlPersistT (R.ResourceT m) () +sqlFailWith :: (HasCallStack, MonadCatch m, MonadIO m, Show a) => ByteString -> SqlPersistT (R.ResourceT m) a -> SqlPersistT (R.ResourceT m) () sqlFailWith errState f = do - p <- (f >> return True) `catch` success - when p failed - where success SqlError{sqlState} - | sqlState == errState = return False - | otherwise = do - liftIO $ expectationFailure $ T.unpack $ T.concat - [ "should fail with: ", errStateT - , ", but received: ", TE.decodeUtf8 sqlState - ] - return False - failed = liftIO $ expectationFailure $ "should fail with: " `mappend` T.unpack errStateT - errStateT = TE.decodeUtf8 errState + eres <- try f + case eres of + Left err -> + success err + Right a -> + liftIO $ expectationFailure $ mconcat + [ "should fail with error code: " + , T.unpack errStateT + , ", but got: " + , show a + ] + where + success SqlError{sqlState} + | sqlState == errState = + pure () + | otherwise = do + liftIO $ expectationFailure $ T.unpack $ T.concat + [ "should fail with: ", errStateT + , ", but received: ", TE.decodeUtf8 sqlState + ] + errStateT = + TE.decodeUtf8 errState selectJSONwhere :: MonadIO m @@ -1406,8 +1451,26 @@ migrateIt = do cleanUniques withConn :: RunDbMonad m => (SqlBackend -> R.ResourceT m a) -> m a -withConn = - R.runResourceT . withPostgresqlConn "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" +withConn f = do + ea <- try go + case ea of + Left (SomeException se) -> do + ea' <- try go + case ea' of + Left (SomeException se1) -> + if show se == show se1 + then throwM se + else throwM se1 + Right a -> + pure a + Right a -> + pure a + where + go = + R.runResourceT $ + withPostgresqlConn + "host=localhost port=5432 user=esqutest password=esqutest dbname=esqutest" + f -- | Show the SQL generated by a query showQuery :: (Monad m, ES.SqlSelect a r, BackendCompatible SqlBackend backend)