haskell/esqueleto
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

get persistent 2.12 going (#243)

Browse Source 
* 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
This commit is contained in:
Matt Parsons 2021-03-29 14:47:20 -06:00 committed by GitHub
parent c4ec95874f
commit 96331257e4
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
17 changed files with 457 additions and 333 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
README.md
View File

@ -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';
```

24
cabal.project
View File

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

6
changelog.md
View File

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

7
esqueleto.cabal
View File

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

3
examples/Blog.hs
View File

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

3
examples/Main.hs
View File

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

3
src/Database/Esqueleto/Experimental.hs
View File

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

2
src/Database/Esqueleto/Internal/ExprParser.hs
View File

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

27
src/Database/Esqueleto/Internal/Internal.hs
View File

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

3
src/Database/Esqueleto/Internal/PersistentImport.hs
View File

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

5
src/Database/Esqueleto/PostgreSQL.hs
View File

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

2
src/Database/Esqueleto/PostgreSQL/JSON/Instances.hs
View File

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

13
stack-8.8.yaml
View File

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

3
test/Common/Test.hs
View File

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

70
test/MySQL/Test.hs
View File

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

1
test/PostgreSQL/MigrateJSON.hs
View File

@ -30,6 +30,7 @@ import Common.Test (RunDbMonad)
share [mkPersist sqlSettings, mkMigrate "migrateJSON"] [persistUpperCase|
Json
value (JSONB Value)
deriving Show
|]
cleanJSON

617
test/PostgreSQL/Test.hs
View File

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