From 67ab9c6fdce4089ede61f729432825e3c1bfd344 Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 12 Sep 2021 10:03:41 -0500 Subject: [PATCH 1/5] Add new Postgresql.JSON.Experimental that supports jsonbAgg and toJsonb on newtype JsonValue. Also added multiset and multisetAgg convienience functions --- esqueleto.cabal | 1 + src/Database/Esqueleto/Internal/Internal.hs | 47 +-- .../Esqueleto/PostgreSQL/JSON/Experimental.hs | 291 ++++++++++++++++++ 3 files changed, 317 insertions(+), 22 deletions(-) create mode 100644 src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs diff --git a/esqueleto.cabal b/esqueleto.cabal index 56c96681f..c57779c9f 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -38,6 +38,7 @@ library Database.Esqueleto.PostgreSQL Database.Esqueleto.PostgreSQL.JSON Database.Esqueleto.Record + Database.Esqueleto.PostgreSQL.JSON.Experimental Database.Esqueleto.SQLite Database.Esqueleto.Experimental.From Database.Esqueleto.Experimental.From.CommonTableExpression diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 2690ea15b..4cf7aae8f 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -560,7 +560,7 @@ subSelectForeign expr foreignKey k = -- 'subSelectMaybe'. For the most common safe use of this, see 'subSelectCount'. -- -- @since 3.2.0 -subSelectUnsafe :: PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +subSelectUnsafe :: SqlSelect (SqlExpr a) r => SqlQuery (SqlExpr a) -> SqlExpr a subSelectUnsafe = sub SELECT -- | Project a field of an entity. @@ -568,12 +568,9 @@ subSelectUnsafe = sub SELECT => SqlExpr (Entity val) -> EntityField val typ -> SqlExpr (Value typ) -ERaw m f ^. field +ent ^. field | isIdField field = idFieldValue - | Just alias <- sqlExprMetaAlias m = - ERaw noMeta $ \_ info -> - f Never info <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef), []) - | otherwise = ERaw noMeta $ \_ info -> (dot info $ persistFieldDef field, []) + | otherwise = ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) where fieldDef = if isIdField field then @@ -583,25 +580,27 @@ ERaw m f ^. field persistFieldDef field idFieldValue = case getEntityKeyFields ed of - idField :| [] -> - ERaw noMeta $ \_ info -> (dot info idField, []) + idField :| [] -> ERaw noMeta $ \_ info -> (viewFieldBuilder ent info idField, []) idFields -> - let renderedFields info = dot info <$> NEL.toList idFields + let renderedFields info = viewFieldBuilder ent info <$> NEL.toList idFields in ERaw noMeta{ sqlExprMetaCompositeFields = Just renderedFields} $ \p info -> (parensM p $ uncommas $ renderedFields info, []) ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) - dot info fieldDef' = - sourceIdent info <> "." <> fieldIdent - where - sourceIdent = fmap fst $ f Never - fieldIdent - | Just baseI <- sqlExprMetaAlias m = - useIdent info $ aliasedEntityColumnIdent baseI fieldDef' - | otherwise = - fromDBName info (coerce $ fieldDB fieldDef') +viewFieldBuilder :: SqlExpr (Entity val) -> IdentInfo -> FieldDef -> TLB.Builder +viewFieldBuilder (ERaw m f) info fieldDef + | Just alias <- sqlExprMetaAlias m = + fst (f Never info) <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef)) + | otherwise = sourceIdent info <> "." <> fieldIdent + where + sourceIdent = fst <$> f Never + fieldIdent + | Just baseI <- sqlExprMetaAlias m = + useIdent info $ aliasedEntityColumnIdent baseI fieldDef + | otherwise = + fromDBName info (coerce $ fieldDB fieldDef) -- | Project an SqlExpression that may be null, guarding against null cases. withNonNull @@ -2374,7 +2373,7 @@ setAux field value = \ent -> ERaw noMeta $ \_ info -> (valueToSet, valueVals) = valueF Parens info in (fieldName info field <> " = " <> valueToSet, valueVals) -sub :: PersistField a => Mode -> SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a) +sub :: (SqlSelect (SqlExpr a) r) => Mode -> SqlQuery (SqlExpr a) -> SqlExpr a sub mode query = ERaw noMeta $ \_ info -> first parens $ toRawSql mode info query fromDBName :: IdentInfo -> DBName -> TLB.Builder @@ -2684,18 +2683,22 @@ instance ( UnsafeSqlFunctionArgument a ) => UnsafeSqlFunctionArgument (a, b, c, d, e, f, g, h, i, j) where toArgList = toArgList . from10 +-- | (Internal) Coerce a SqlExpr from any arbitrary a to any arbitrary b +-- You should /not/ use this function unless you know what you're doing! +veryVeryUnsafeCoerceSqlExpr :: SqlExpr a -> SqlExpr b +veryVeryUnsafeCoerceSqlExpr = coerce -- | (Internal) Coerce a value's type from 'SqlExpr (Value a)' to -- 'SqlExpr (Value b)'. You should /not/ use this function -- unless you know what you're doing! veryUnsafeCoerceSqlExprValue :: SqlExpr (Value a) -> SqlExpr (Value b) -veryUnsafeCoerceSqlExprValue = coerce +veryUnsafeCoerceSqlExprValue = veryVeryUnsafeCoerceSqlExpr -- | (Internal) Coerce a value's type from 'SqlExpr (ValueList -- a)' to 'SqlExpr (Value a)'. Does not work with empty lists. veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a) -veryUnsafeCoerceSqlExprValueList = coerce +veryUnsafeCoerceSqlExprValueList = veryVeryUnsafeCoerceSqlExpr ---------------------------------------------------------------------- @@ -3381,7 +3384,7 @@ instance PersistField a => SqlSelect (SqlExpr (Value a)) (Value a) where sqlSelectProcessRow pvs = Value <$> fromPersistValue (PersistList pvs) -- | Materialize a @SqlExpr (Value a)@. -materializeExpr :: IdentInfo -> SqlExpr (Value a) -> (TLB.Builder, [PersistValue]) +materializeExpr :: IdentInfo -> SqlExpr a -> (TLB.Builder, [PersistValue]) materializeExpr info (ERaw m f) | Just fields <- sqlExprMetaCompositeFields m = (uncommas $ fmap parens $ fields info, []) | Just alias <- sqlExprMetaAlias m diff --git a/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs new file mode 100644 index 000000000..b44ae434c --- /dev/null +++ b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs @@ -0,0 +1,291 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Database.Esqueleto.PostgreSQL.JSON.Experimental + where + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Experimental.ToAliasReference +import Database.Esqueleto.Experimental.ToMaybe +import Database.Esqueleto.Internal.Internal +import Database.Persist + +newtype JsonValue a = JsonValue { unJsonValue :: a } + deriving (Show, Eq) + +instance (Aeson.FromJSON a) + => SqlSelect (SqlExpr (JsonValue a)) (JsonValue a) where + -- returns the list of 'PersistValue's that will be given to + -- 'rawQuery'. + sqlSelectCols info a = materializeExpr info a + + -- | Number of columns that will be consumed. + sqlSelectColCount _ = 1 + + -- | Transform a row of the result into the data type. + sqlSelectProcessRow [PersistByteString bs] = + case Aeson.decode $ LBS.fromStrict bs of + Just r -> Right $ JsonValue r + Nothing -> Left "Failed to decode" + sqlSelectProcessRow _ = Left "Expected ByteString but database returned unexpected type" + +instance ToMaybe (SqlExpr (JsonValue a)) where + type ToMaybeT (SqlExpr (JsonValue a)) = SqlExpr (JsonValue (Maybe (Nullable a))) + toMaybe = veryVeryUnsafeCoerceSqlExpr + +instance ToAlias (SqlExpr (JsonValue a)) where + toAlias e@(ERaw m f) + | Just _ <- sqlExprMetaAlias m = pure e + | otherwise = do + ident <- newIdentFor (DBName "v") + pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f +instance ToAliasReference (SqlExpr (JsonValue a)) where + toAliasReference aliasSource (ERaw m _) + | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> + (useIdent info aliasSource <> "." <> useIdent info alias, []) + toAliasReference _ e = pure e + +jsonAgg :: SqlExpr (JsonValue a) -> SqlExpr (JsonValue [a]) +jsonAgg v = + veryVeryUnsafeCoerceSqlExpr $ + unsafeSqlFunction "coalesce" + [ unsafeSqlFunction "jsonb_agg" $ veryVeryUnsafeCoerceSqlExpr v + , ERaw noMeta $ \_ _ -> ("'[]'::jsonb", []) + ] + +multisetAgg :: (Aeson.FromJSON b, PgToJsonb (SqlExpr a) b) => SqlExpr a -> SqlExpr (JsonValue [b]) +multisetAgg = jsonAgg . toJsonb + +multiset :: (Aeson.FromJSON b, PgToJsonb a b) => SqlQuery a -> SqlExpr (JsonValue [b]) +multiset q = + subSelectUnsafe $ jsonAgg . toJsonb <$> q + +class PgToJsonb a b | a -> b where + toJsonb :: a -> SqlExpr (JsonValue b) + +instance PgToJsonb (SqlExpr a) b => PgToJsonb (SqlExpr (Maybe a)) (Maybe b) where + toJsonb = veryVeryUnsafeCoerceSqlExpr . toJsonb @(SqlExpr a) . veryVeryUnsafeCoerceSqlExpr + +instance PgToJsonb (SqlExpr (JsonValue a)) a where + toJsonb = id + +instance PgToJsonb (SqlExpr (Value a)) a where + toJsonb = veryVeryUnsafeCoerceSqlExpr . unsafeSqlFunction "toJsonb" + +instance forall a. PersistEntity a + => PgToJsonb (SqlExpr (Entity a)) (Entity a) where + toJsonb ent = + unsafeJsonbBuildObject fields + where + ed = entityDef $ Proxy @a + baseFields = fmap (\fieldDef -> + ( "'" <> unFieldNameHS (fieldHaskell fieldDef) <> "'" + , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) + )) (getEntityFields ed) + idField = fmap (\fieldDef -> + ( "'id'" + , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) + )) (getEntityIdField ed) + + fields = maybe baseFields (:baseFields) idField + +class TupleToSqlExpr a where + tupleToSqlExpr :: IdentInfo -> a -> ([TLB.Builder], [PersistValue]) + +instance TupleToSqlExpr (SqlExpr a) where + tupleToSqlExpr info (ERaw _ f) = + let (t, v) = f Never info + in ([t], v) + +instance (TupleToSqlExpr a, TupleToSqlExpr b) => TupleToSqlExpr (a, b) where + tupleToSqlExpr info (a, b) = + tupleToSqlExpr info a <> tupleToSqlExpr info b + +instance ( TupleToSqlExpr a + , TupleToSqlExpr b + , TupleToSqlExpr c + ) => TupleToSqlExpr (a, b, c) where + tupleToSqlExpr info = + tupleToSqlExpr info . from3 +instance ( TupleToSqlExpr a + , TupleToSqlExpr b + , TupleToSqlExpr c + , TupleToSqlExpr d + ) => TupleToSqlExpr (a, b, c, d) where + tupleToSqlExpr info = + tupleToSqlExpr info . from4 + +instance ( TupleToSqlExpr a + , TupleToSqlExpr b + , TupleToSqlExpr c + , TupleToSqlExpr d + , TupleToSqlExpr e + ) => TupleToSqlExpr (a, b, c, d, e) where + tupleToSqlExpr info = + tupleToSqlExpr info . from5 + +instance ( TupleToSqlExpr a + , TupleToSqlExpr b + , TupleToSqlExpr c + , TupleToSqlExpr d + , TupleToSqlExpr e + , TupleToSqlExpr f + ) => TupleToSqlExpr (a, b, c, d, e, f) where + tupleToSqlExpr info = + tupleToSqlExpr info . from6 + +instance ( TupleToSqlExpr a + , TupleToSqlExpr b + , TupleToSqlExpr c + , TupleToSqlExpr d + , TupleToSqlExpr e + , TupleToSqlExpr f + , TupleToSqlExpr g + ) => TupleToSqlExpr (a, b, c, d, e, f, g) where + tupleToSqlExpr info = + tupleToSqlExpr info . from7 + +instance ( TupleToSqlExpr a + , TupleToSqlExpr b + , TupleToSqlExpr c + , TupleToSqlExpr d + , TupleToSqlExpr e + , TupleToSqlExpr f + , TupleToSqlExpr g + , TupleToSqlExpr h + ) => TupleToSqlExpr (a, b, c, d, e, f, g, h) where + tupleToSqlExpr info = + tupleToSqlExpr info . from8 + + +instance ( PgToJsonb a a' + , PgToJsonb b b' + ) + => PgToJsonb (a, b) (a', b') where + toJsonb (a, b) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + ) + +instance ( PgToJsonb a a' + , PgToJsonb b b' + , PgToJsonb c c' + ) + => PgToJsonb (a, b, c) (a', b', c') where + toJsonb (a, b, c) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + , toJsonb c + ) + +instance ( PgToJsonb a a' + , PgToJsonb b b' + , PgToJsonb c c' + , PgToJsonb d d' + ) + => PgToJsonb (a, b, c, d) (a', b', c', d') where + toJsonb (a, b, c, d) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + , toJsonb c + , toJsonb d + ) +instance ( PgToJsonb a a' + , PgToJsonb b b' + , PgToJsonb c c' + , PgToJsonb d d' + , PgToJsonb e e' + ) + => PgToJsonb (a, b, c, d, e) (a', b', c', d', e') where + toJsonb (a, b, c, d, e) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + , toJsonb c + , toJsonb d + , toJsonb e + ) +instance ( PgToJsonb a a' + , PgToJsonb b b' + , PgToJsonb c c' + , PgToJsonb d d' + , PgToJsonb e e' + , PgToJsonb f f' + ) + => PgToJsonb (a, b, c, d, e, f) (a', b', c', d', e', f') where + toJsonb (a, b, c, d, e, f) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + , toJsonb c + , toJsonb d + , toJsonb e + , toJsonb f + ) +instance ( PgToJsonb a a' + , PgToJsonb b b' + , PgToJsonb c c' + , PgToJsonb d d' + , PgToJsonb e e' + , PgToJsonb f f' + , PgToJsonb g g' + ) + => PgToJsonb (a, b, c, d, e, f, g) (a', b', c', d', e', f', g') where + toJsonb (a, b, c, d, e, f, g) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + , toJsonb c + , toJsonb d + , toJsonb e + , toJsonb f + , toJsonb g + ) +instance ( PgToJsonb a a' + , PgToJsonb b b' + , PgToJsonb c c' + , PgToJsonb d d' + , PgToJsonb e e' + , PgToJsonb f f' + , PgToJsonb g g' + , PgToJsonb h h' + ) + => PgToJsonb (a, b, c, d, e, f, g, h) (a', b', c', d', e', f', g', h') where + toJsonb (a, b, c, d, e, f, g, h) = + unsafeJsonbBuildArray $ flip tupleToSqlExpr + ( toJsonb a + , toJsonb b + , toJsonb c + , toJsonb d + , toJsonb e + , toJsonb f + , toJsonb g + , toJsonb h + ) + +unsafeJsonbBuildArray :: (IdentInfo -> ([TLB.Builder], [PersistValue])) -> SqlExpr a +unsafeJsonbBuildArray f = + ERaw noMeta $ \_ info -> + let (t, v) = f info + in ("jsonb_build_array(" <> uncommas t <> ")", v) + +unsafeJsonbBuildObject :: [(Text, SqlExpr SomeValue)] -> SqlExpr (JsonValue a) +unsafeJsonbBuildObject fields = + ERaw noMeta $ \p info -> + let (texts, vals) = foldMap (\(haskellName, ERaw _ f) -> + let (t, v) = f p info + in ([TLB.fromText haskellName, t], v)) fields + in ("jsonb_build_object(" <> uncommas texts <> ")", vals) From 59ab459b26c8a9ed14a095482ed292c9929eaaf4 Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 12 Sep 2021 18:58:55 -0500 Subject: [PATCH 2/5] Add initial exemplary test --- test/Common/Test/Models.hs | 8 +-- test/PostgreSQL/Test.hs | 99 +++++++++++--------------------------- 2 files changed, 31 insertions(+), 76 deletions(-) diff --git a/test/Common/Test/Models.hs b/test/Common/Test/Models.hs index dc6b94530..1b6e24498 100644 --- a/test/Common/Test/Models.hs +++ b/test/Common/Test/Models.hs @@ -49,21 +49,21 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase| YetAnother argh ShoopId - Person + Person json name String age Int Maybe weight Int Maybe favNum Int deriving Eq Show Ord - BlogPost + BlogPost json title String authorId PersonId deriving Eq Show - Comment + Comment json body String blog BlogPostId deriving Eq Show - CommentReply + CommentReply json body String comment CommentId Profile diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 3ff87a1da..88ba19981 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -44,6 +44,7 @@ import Database.Esqueleto.PostgreSQL (random_) import qualified Database.Esqueleto.PostgreSQL as EP import Database.Esqueleto.PostgreSQL.JSON hiding ((-.), (?.), (||.)) import qualified Database.Esqueleto.PostgreSQL.JSON as JSON +import qualified Database.Esqueleto.PostgreSQL.JSON.Experimental as JSONE import qualified Database.Persist.Class as P import Database.Persist.Postgresql (createPostgresqlPool, withPostgresqlConn) import Database.PostgreSQL.Simple (ExecStatus(..), SqlError(..)) @@ -407,10 +408,6 @@ testStringAggWith = do liftIO $ (words ret) `shouldBe` (L.reverse . L.sort . L.nub $ map personName people) - - - - testAggregateFunctions :: SpecDb testAggregateFunctions = do describe "arrayAgg" $ do @@ -1467,74 +1464,30 @@ testLateralQuery = do let _ = res :: [(Entity Lord, Value (Maybe Int))] asserting noExceptions -testValuesExpression :: SpecDb -testValuesExpression = do - describe "(VALUES (..)) query" $ do - itDb "works with joins and other sql expressions" $ do - p1k <- insert p1 - p2k <- insert p2 - p3k <- insert p3 - let exprs :: NE.NonEmpty (SqlExpr (Value Int), SqlExpr (Value Text)) - exprs = (val 10, val "ten") - NE.:| [ (val 20, val "twenty") - , (val 30, val "thirty") ] - query = do - (bound, boundName) :& person <- Experimental.from $ - EP.values exprs - `Experimental.InnerJoin` table @Person - `Experimental.on` (\((bound, boundName) :& person) -> person^.PersonAge >=. just bound) - groupBy bound - orderBy [ asc bound ] - pure (bound, count @Int $ person^.PersonName) - result <- select query - liftIO $ result `shouldBe` [ (Value 10, Value 2) - , (Value 20, Value 1) - , (Value 30, Value 1) ] - - itDb "supports single-column query" $ do - let query = do - vInt <- Experimental.from $ EP.values $ val 1 NE.:| [ val 2, val 3 ] - pure (vInt :: SqlExpr (Value Int)) - result <- select query - asserting noExceptions - liftIO $ result `shouldBe` [ Value 1, Value 2, Value 3 ] - - itDb "supports multi-column query (+ nested simple expression and null)" $ do - let query = do - (vInt, vStr, vDouble) <- Experimental.from - $ EP.values $ (val 1, val "str1", coalesce [just $ val 1.0, nothing]) - NE.:| [ (val 2, val "str2", just $ val 2.5) - , (val 3, val "str3", nothing) ] - pure ( vInt :: SqlExpr (Value Int) - , vStr :: SqlExpr (Value Text) - , vDouble :: SqlExpr (Value (Maybe Double)) ) - result <- select query - asserting noExceptions - liftIO $ result `shouldBe` [ (Value 1, Value "str1", Value $ Just 1.0) - , (Value 2, Value "str2", Value $ Just 2.5) - , (Value 3, Value "str3", Value Nothing) ] - -testSubselectAliasingBehavior :: SpecDb -testSubselectAliasingBehavior = do - describe "Aliasing behavior" $ do - itDb "correctly realiases entities accross multiple subselects" $ do - _ <- select $ do - Experimental.from $ Experimental.from $ Experimental.from $ table @Lord - asserting noExceptions - - itDb "doesnt erroneously repeat variable names when using subselect + union" $ do - let lordQuery = do - l <- Experimental.from $ table @Lord - pure (l ^. LordCounty, l ^. LordDogs) - personQuery = do - p <- Experimental.from $ table @Person - pure (p ^. PersonName, just $ p ^. PersonFavNum) - _ <- select $ - Experimental.from $ do - (str, _) <- Experimental.from $ lordQuery `union_` personQuery - pure (str, val @Int 1) - asserting noExceptions - +testNestedMultiset :: SpecDb +testNestedMultiset = + itDb "supports nested multiset" $ do + p1e <- insert' p1 + p2e <- insert' p2 + [b1e, b2e, b3e] <- mapM (insert' . BlogPost "") [entityKey p1e, entityKey p1e, entityKey p2e] + [c1e, c2e] <- mapM (insert' . Comment "") [entityKey b1e, entityKey b2e] + let q = do + person <- Experimental.from $ table @Person + pure ( person + , JSONE.multiset $ do + posts <- Experimental.from $ table @BlogPost + where_ $ posts ^. BlogPostAuthorId ==. person ^. PersonId + pure ( posts + , JSONE.multiset $ do + comments <- Experimental.from $ table @Comment + where_ $ comments ^. CommentBlog ==. posts ^. BlogPostId + pure comments + ) + ) + res <- select q + asserting $ res `shouldMatchList` [ (p1e, JSONE.JsonValue [(b1e, [c1e]), (b2e, [c2e])]) + , (p2e, JSONE.JsonValue [(b3e, [])]) + ] type JSONValue = Maybe (JSONB A.Value) @@ -1631,6 +1584,8 @@ spec = beforeAll mkConnectionPool $ do testValuesExpression testSubselectAliasingBehavior testPostgresqlLocking + describe "PostgreSQL Experimental JSON" $ + testNestedMultiset insertJsonValues :: SqlPersistT IO () insertJsonValues = do From 82f484a5141649d7b01a4c9adbdbeab67f61a334 Mon Sep 17 00:00:00 2001 From: belevy Date: Mon, 13 Sep 2021 15:02:09 -0500 Subject: [PATCH 3/5] Add more tests for toJson. Fix bug with value toJson --- .../Esqueleto/PostgreSQL/JSON/Experimental.hs | 2 +- test/MySQL/Test.hs | 2 +- test/PostgreSQL/Test.hs | 89 ++++++++++++++----- 3 files changed, 67 insertions(+), 26 deletions(-) diff --git a/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs index b44ae434c..927af974e 100644 --- a/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs +++ b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs @@ -80,7 +80,7 @@ instance PgToJsonb (SqlExpr (JsonValue a)) a where toJsonb = id instance PgToJsonb (SqlExpr (Value a)) a where - toJsonb = veryVeryUnsafeCoerceSqlExpr . unsafeSqlFunction "toJsonb" + toJsonb = veryVeryUnsafeCoerceSqlExpr . unsafeSqlFunction "to_jsonb" instance forall a. PersistEntity a => PgToJsonb (SqlExpr (Entity a)) (Entity a) where diff --git a/test/MySQL/Test.hs b/test/MySQL/Test.hs index 6941328f9..0aceceff6 100644 --- a/test/MySQL/Test.hs +++ b/test/MySQL/Test.hs @@ -23,9 +23,9 @@ import Database.Persist.MySQL , connectPassword , connectPort , connectUser + , createMySQLPool , defaultConnectInfo , withMySQLConn - , createMySQLPool ) import Test.Hspec diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 88ba19981..7795c27c5 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1464,30 +1464,71 @@ testLateralQuery = do let _ = res :: [(Entity Lord, Value (Maybe Int))] asserting noExceptions +testToJson :: SpecDb +testToJson = do + itDb "to_json supports Value" $ do + r <- select $ pure $ JSONE.toJsonb $ val @Int 1 + asserting $ r `shouldBe` [JSONE.JsonValue 1] + itDb "to_json supports Entity" $ do + p1e <- insert' p1 + r <- select $ JSONE.toJsonb <$> Experimental.from (table @Person) + asserting $ r `shouldBe` [JSONE.JsonValue p1e] + itDb "to_json supports tuples" $ do + p1e <- insert' p1 + r <- select $ do + p <- Experimental.from $ table @Person + pure $ JSONE.toJsonb $ (p, val @Int 1) + asserting $ r `shouldBe` [JSONE.JsonValue (p1e, 1)] + itDb "to_json supports 3 tuples" $ do + p1e <- insert' p1 + r <- select $ do + p <- Experimental.from $ table @Person + pure $ JSONE.toJsonb $ (val @Int 1, p, val @Int 2) + asserting $ r `shouldBe` [JSONE.JsonValue (1, p1e, 2)] + +testJsonAgg :: SpecDb +testJsonAgg = do + itDb "json_agg supports Value" $ do + r <- select $ pure $ JSONE.jsonAgg $ JSONE.toJsonb $ val @Int 1 + asserting $ r `shouldBe` [JSONE.JsonValue [1]] + itDb "json_agg supports Entities" $ do + p1e <- insert' p1 + p2e <- insert' p2 + r <- select $ JSONE.jsonAgg . JSONE.toJsonb <$> Experimental.from (table @Person) + asserting $ r `shouldBe` [JSONE.JsonValue [p1e, p2e]] + itDb "json_agg supports Tuples" $ do + p1e <- insert' p1 + p2e <- insert' p2 + r <- select $ do + p <- Experimental.from $ table @Person + p' <- Experimental.from $ table @Person + pure $ JSONE.jsonAgg $ JSONE.toJsonb (p, p') + asserting $ r `shouldBe` [JSONE.JsonValue [(p1e, p1e), (p1e, p2e), (p2e, p1e), (p2e, p2e)]] + testNestedMultiset :: SpecDb testNestedMultiset = itDb "supports nested multiset" $ do - p1e <- insert' p1 - p2e <- insert' p2 - [b1e, b2e, b3e] <- mapM (insert' . BlogPost "") [entityKey p1e, entityKey p1e, entityKey p2e] - [c1e, c2e] <- mapM (insert' . Comment "") [entityKey b1e, entityKey b2e] - let q = do - person <- Experimental.from $ table @Person - pure ( person - , JSONE.multiset $ do - posts <- Experimental.from $ table @BlogPost - where_ $ posts ^. BlogPostAuthorId ==. person ^. PersonId - pure ( posts - , JSONE.multiset $ do - comments <- Experimental.from $ table @Comment - where_ $ comments ^. CommentBlog ==. posts ^. BlogPostId - pure comments - ) - ) - res <- select q - asserting $ res `shouldMatchList` [ (p1e, JSONE.JsonValue [(b1e, [c1e]), (b2e, [c2e])]) - , (p2e, JSONE.JsonValue [(b3e, [])]) - ] + p1e <- insert' p1 + p2e <- insert' p2 + [b1e, b2e, b3e] <- mapM (insert' . BlogPost "") [entityKey p1e, entityKey p1e, entityKey p2e] + [c1e, c2e] <- mapM (insert' . Comment "") [entityKey b1e, entityKey b2e] + let q = do + person <- Experimental.from $ table @Person + pure ( person + , JSONE.multiset $ do + posts <- Experimental.from $ table @BlogPost + where_ $ posts ^. BlogPostAuthorId ==. person ^. PersonId + pure ( posts + , JSONE.multiset $ do + comments <- Experimental.from $ table @Comment + where_ $ comments ^. CommentBlog ==. posts ^. BlogPostId + pure comments + ) + ) + res <- select q + asserting $ res `shouldMatchList` [ (p1e, JSONE.JsonValue [(b1e, [c1e]), (b2e, [c2e])]) + , (p2e, JSONE.JsonValue [(b3e, [])]) + ] type JSONValue = Maybe (JSONB A.Value) @@ -1581,10 +1622,10 @@ spec = beforeAll mkConnectionPool $ do testJSONInsertions testJSONOperators testLateralQuery - testValuesExpression - testSubselectAliasingBehavior testPostgresqlLocking - describe "PostgreSQL Experimental JSON" $ + describe "PostgreSQL Experimental JSON" $ do + testToJson + testJsonAgg testNestedMultiset insertJsonValues :: SqlPersistT IO () From ab004546f04ca285547b33168bd793755b439b68 Mon Sep 17 00:00:00 2001 From: belevy Date: Sun, 19 Sep 2021 01:11:27 -0500 Subject: [PATCH 4/5] Extract postgres specific functionality into typeclass over jsonValue type --- esqueleto.cabal | 1 + src/Database/Esqueleto/Internal/Internal.hs | 8 +- src/Database/Esqueleto/Internal/JSON.hs | 196 ++++++++++++ .../Esqueleto/PostgreSQL/JSON/Experimental.hs | 288 +++--------------- test/PostgreSQL/Test.hs | 24 +- 5 files changed, 251 insertions(+), 266 deletions(-) create mode 100644 src/Database/Esqueleto/Internal/JSON.hs diff --git a/esqueleto.cabal b/esqueleto.cabal index c57779c9f..dac0ee8c7 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -33,6 +33,7 @@ library Database.Esqueleto.Legacy Database.Esqueleto.Experimental Database.Esqueleto.Internal.Internal + Database.Esqueleto.Internal.JSON Database.Esqueleto.Internal.ExprParser Database.Esqueleto.MySQL Database.Esqueleto.PostgreSQL diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index 4cf7aae8f..a1e519737 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -2520,7 +2520,7 @@ valueToFunctionArg info (ERaw _ f) = f Never info -- from 'unsafeSqlBinOp' applies to this function as well. unsafeSqlFunction :: UnsafeSqlFunctionArgument a - => TLB.Builder -> a -> SqlExpr (Value b) + => TLB.Builder -> a -> SqlExpr b unsafeSqlFunction name arg = ERaw noMeta $ \_ info -> let (argsTLB, argsVals) = @@ -2556,7 +2556,7 @@ unsafeSqlFunctionParens name arg = -- | (Internal) An explicit SQL type cast using CAST(value as type). -- See 'unsafeSqlBinOp' for warnings. -unsafeSqlCastAs :: T.Text -> SqlExpr (Value a) -> SqlExpr (Value b) +unsafeSqlCastAs :: T.Text -> SqlExpr a -> SqlExpr b unsafeSqlCastAs t (ERaw _ f) = ERaw noMeta $ \_ -> ((first (\value -> "CAST" <> parens (value <> " AS " <> TLB.fromText t))) . f Never) -- | (Internal) This class allows 'unsafeSqlFunction' to work with different @@ -2575,8 +2575,8 @@ class UnsafeSqlFunctionArgument a where instance UnsafeSqlFunctionArgument () where toArgList _ = [] -instance (a ~ Value b) => UnsafeSqlFunctionArgument (SqlExpr a) where - toArgList = (:[]) . veryUnsafeCoerceSqlExprValue +instance UnsafeSqlFunctionArgument (SqlExpr a) where + toArgList = (:[]) . veryVeryUnsafeCoerceSqlExpr instance UnsafeSqlFunctionArgument a => UnsafeSqlFunctionArgument [a] where toArgList = concatMap toArgList diff --git a/src/Database/Esqueleto/Internal/JSON.hs b/src/Database/Esqueleto/Internal/JSON.hs new file mode 100644 index 000000000..13fe9913e --- /dev/null +++ b/src/Database/Esqueleto/Internal/JSON.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Database.Esqueleto.Internal.JSON + where + +import qualified Data.Aeson as Aeson +import Data.Bifunctor (first) +import qualified Data.ByteString.Lazy as LBS +import Data.Proxy (Proxy(..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Lazy.Builder as TLB +import Database.Esqueleto.Internal.Internal +import Database.Persist + +class SqlToJson jsonValue a b | jsonValue a -> b where + toJson :: a -> SqlExpr (jsonValue b) + +class JsonAgg jsonValue where + jsonAgg :: SqlExpr (jsonValue a) -> SqlExpr (jsonValue [a]) + +class JsonBuildArray jsonValue where + unsafeJsonbBuildArray :: UnsafeSqlFunctionArgument a => a -> SqlExpr (jsonValue b) + +class JsonBuildObject jsonValue where + unsafeJsonbBuildObject :: [(SqlExpr (Value Text), SqlExpr SomeValue)] -> SqlExpr (jsonValue a) + +multiset :: forall jsonValue a b r. + ( Aeson.FromJSON b + , SqlToJson jsonValue a b + , JsonAgg jsonValue + , SqlSelect (SqlExpr (jsonValue [b])) r + ) + => SqlQuery a -> SqlExpr (jsonValue [b]) +multiset q = + subSelectUnsafe $ jsonAgg . toJson <$> q + +instance SqlToJson jsonValue (SqlExpr a) b + => SqlToJson jsonValue (SqlExpr (Maybe a)) (Maybe b) where + toJson = + let unMaybe :: SqlExpr (Maybe a) -> SqlExpr a + unMaybe = veryVeryUnsafeCoerceSqlExpr + in veryVeryUnsafeCoerceSqlExpr . toJson @jsonValue . unMaybe + + +instance forall a jsonValue . (PersistEntity a, JsonBuildObject jsonValue) + => SqlToJson jsonValue (SqlExpr (Entity a)) (Entity a) where + toJson ent = + unsafeJsonbBuildObject fields + where + ed = entityDef $ Proxy @a + baseFields = fmap (\fieldDef -> + ( unsafeSqlValue $ TLB.fromText $ "'" <> unFieldNameHS (fieldHaskell fieldDef) <> "'" + , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) + )) (getEntityFields ed) + idField = fmap (\fieldDef -> + ( unsafeSqlValue "'id'" + , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) + )) (getEntityIdField ed) + + fields = maybe baseFields (:baseFields) idField + + +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b) (a', b') where + toJson (a, b) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + ) + +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , SqlToJson jsonValue c c' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b, c) (a', b', c') where + toJson (a, b, c) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + , toJson @jsonValue c + ) + +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , SqlToJson jsonValue c c' + , SqlToJson jsonValue d d' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b, c, d) (a', b', c', d') where + toJson (a, b, c, d) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + , toJson @jsonValue c + , toJson @jsonValue d + ) +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , SqlToJson jsonValue c c' + , SqlToJson jsonValue d d' + , SqlToJson jsonValue e e' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b, c, d, e) (a', b', c', d', e') where + toJson (a, b, c, d, e) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + , toJson @jsonValue c + , toJson @jsonValue d + , toJson @jsonValue e + ) +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , SqlToJson jsonValue c c' + , SqlToJson jsonValue d d' + , SqlToJson jsonValue e e' + , SqlToJson jsonValue f f' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b, c, d, e, f) (a', b', c', d', e', f') where + toJson (a, b, c, d, e, f) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + , toJson @jsonValue c + , toJson @jsonValue d + , toJson @jsonValue e + , toJson @jsonValue f + ) +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , SqlToJson jsonValue c c' + , SqlToJson jsonValue d d' + , SqlToJson jsonValue e e' + , SqlToJson jsonValue f f' + , SqlToJson jsonValue g g' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b, c, d, e, f, g) (a', b', c', d', e', f', g') where + toJson (a, b, c, d, e, f, g) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + , toJson @jsonValue c + , toJson @jsonValue d + , toJson @jsonValue e + , toJson @jsonValue f + , toJson @jsonValue g + ) +instance ( SqlToJson jsonValue a a' + , SqlToJson jsonValue b b' + , SqlToJson jsonValue c c' + , SqlToJson jsonValue d d' + , SqlToJson jsonValue e e' + , SqlToJson jsonValue f f' + , SqlToJson jsonValue g g' + , SqlToJson jsonValue h h' + , JsonBuildArray jsonValue + ) + => SqlToJson jsonValue (a, b, c, d, e, f, g, h) (a', b', c', d', e', f', g', h') where + toJson (a, b, c, d, e, f, g, h) = + unsafeJsonbBuildArray + ( toJson @jsonValue a + , toJson @jsonValue b + , toJson @jsonValue c + , toJson @jsonValue d + , toJson @jsonValue e + , toJson @jsonValue f + , toJson @jsonValue g + , toJson @jsonValue h + ) + +sqlSelectProcessRowJSON :: (Applicative f, Aeson.FromJSON r) + => [PersistValue] -> Either Text (f r) +sqlSelectProcessRowJSON [PersistByteString bs] = + case Aeson.eitherDecode $ LBS.fromStrict bs of + Right r -> Right $ pure r + Left e -> Left $ Text.pack e +sqlSelectProcessRowJSON [PersistText t] = + first (<> (" " <> t)) $ sqlSelectProcessRowJSON [PersistByteString (encodeUtf8 t)] + +sqlSelectProcessRowJSON _ = Left "Expected ByteString but database returned unexpected type" + diff --git a/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs index 927af974e..738ff641f 100644 --- a/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs +++ b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs @@ -2,290 +2,78 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} module Database.Esqueleto.PostgreSQL.JSON.Experimental where import qualified Data.Aeson as Aeson -import qualified Data.ByteString.Lazy as LBS -import Data.Proxy (Proxy(..)) -import Data.Text (Text) -import qualified Data.Text.Lazy.Builder as TLB import Database.Esqueleto.Experimental.ToAlias import Database.Esqueleto.Experimental.ToAliasReference import Database.Esqueleto.Experimental.ToMaybe import Database.Esqueleto.Internal.Internal -import Database.Persist +import qualified Database.Esqueleto.Internal.JSON as Internal -newtype JsonValue a = JsonValue { unJsonValue :: a } +newtype JsonBValue a = JsonBValue { unJsonBValue :: a } deriving (Show, Eq) +instance Functor JsonBValue where + fmap f = JsonBValue . f . unJsonBValue + +instance Applicative JsonBValue where + pure = JsonBValue + (<*>) f v = JsonBValue $ unJsonBValue f $ unJsonBValue v + instance (Aeson.FromJSON a) - => SqlSelect (SqlExpr (JsonValue a)) (JsonValue a) where - -- returns the list of 'PersistValue's that will be given to - -- 'rawQuery'. + => SqlSelect (SqlExpr (JsonBValue a)) (JsonBValue a) where sqlSelectCols info a = materializeExpr info a - - -- | Number of columns that will be consumed. sqlSelectColCount _ = 1 + sqlSelectProcessRow = Internal.sqlSelectProcessRowJSON - -- | Transform a row of the result into the data type. - sqlSelectProcessRow [PersistByteString bs] = - case Aeson.decode $ LBS.fromStrict bs of - Just r -> Right $ JsonValue r - Nothing -> Left "Failed to decode" - sqlSelectProcessRow _ = Left "Expected ByteString but database returned unexpected type" - -instance ToMaybe (SqlExpr (JsonValue a)) where - type ToMaybeT (SqlExpr (JsonValue a)) = SqlExpr (JsonValue (Maybe (Nullable a))) +instance ToMaybe (SqlExpr (JsonBValue a)) where + type ToMaybeT (SqlExpr (JsonBValue a)) = SqlExpr (JsonBValue (Maybe (Nullable a))) toMaybe = veryVeryUnsafeCoerceSqlExpr -instance ToAlias (SqlExpr (JsonValue a)) where +instance ToAlias (SqlExpr (JsonBValue a)) where toAlias e@(ERaw m f) | Just _ <- sqlExprMetaAlias m = pure e | otherwise = do ident <- newIdentFor (DBName "v") pure $ ERaw noMeta{sqlExprMetaAlias = Just ident} f -instance ToAliasReference (SqlExpr (JsonValue a)) where +instance ToAliasReference (SqlExpr (JsonBValue a)) where toAliasReference aliasSource (ERaw m _) | Just alias <- sqlExprMetaAlias m = pure $ ERaw m{sqlExprMetaIsReference = True} $ \_ info -> (useIdent info aliasSource <> "." <> useIdent info alias, []) toAliasReference _ e = pure e -jsonAgg :: SqlExpr (JsonValue a) -> SqlExpr (JsonValue [a]) -jsonAgg v = - veryVeryUnsafeCoerceSqlExpr $ - unsafeSqlFunction "coalesce" - [ unsafeSqlFunction "jsonb_agg" $ veryVeryUnsafeCoerceSqlExpr v - , ERaw noMeta $ \_ _ -> ("'[]'::jsonb", []) - ] - -multisetAgg :: (Aeson.FromJSON b, PgToJsonb (SqlExpr a) b) => SqlExpr a -> SqlExpr (JsonValue [b]) -multisetAgg = jsonAgg . toJsonb - -multiset :: (Aeson.FromJSON b, PgToJsonb a b) => SqlQuery a -> SqlExpr (JsonValue [b]) -multiset q = - subSelectUnsafe $ jsonAgg . toJsonb <$> q - -class PgToJsonb a b | a -> b where - toJsonb :: a -> SqlExpr (JsonValue b) - -instance PgToJsonb (SqlExpr a) b => PgToJsonb (SqlExpr (Maybe a)) (Maybe b) where - toJsonb = veryVeryUnsafeCoerceSqlExpr . toJsonb @(SqlExpr a) . veryVeryUnsafeCoerceSqlExpr - -instance PgToJsonb (SqlExpr (JsonValue a)) a where - toJsonb = id - -instance PgToJsonb (SqlExpr (Value a)) a where - toJsonb = veryVeryUnsafeCoerceSqlExpr . unsafeSqlFunction "to_jsonb" - -instance forall a. PersistEntity a - => PgToJsonb (SqlExpr (Entity a)) (Entity a) where - toJsonb ent = - unsafeJsonbBuildObject fields - where - ed = entityDef $ Proxy @a - baseFields = fmap (\fieldDef -> - ( "'" <> unFieldNameHS (fieldHaskell fieldDef) <> "'" - , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) - )) (getEntityFields ed) - idField = fmap (\fieldDef -> - ( "'id'" - , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) - )) (getEntityIdField ed) - - fields = maybe baseFields (:baseFields) idField - -class TupleToSqlExpr a where - tupleToSqlExpr :: IdentInfo -> a -> ([TLB.Builder], [PersistValue]) +instance Internal.JsonBuildArray JsonBValue where + unsafeJsonbBuildArray = + unsafeSqlFunction "jsonb_build_array" -instance TupleToSqlExpr (SqlExpr a) where - tupleToSqlExpr info (ERaw _ f) = - let (t, v) = f Never info - in ([t], v) +instance Internal.JsonBuildObject JsonBValue where + unsafeJsonbBuildObject = + unsafeSqlFunction "jsonb_build_object" -instance (TupleToSqlExpr a, TupleToSqlExpr b) => TupleToSqlExpr (a, b) where - tupleToSqlExpr info (a, b) = - tupleToSqlExpr info a <> tupleToSqlExpr info b +instance Internal.SqlToJson JsonBValue (SqlExpr (JsonBValue a)) a where + toJson = id -instance ( TupleToSqlExpr a - , TupleToSqlExpr b - , TupleToSqlExpr c - ) => TupleToSqlExpr (a, b, c) where - tupleToSqlExpr info = - tupleToSqlExpr info . from3 -instance ( TupleToSqlExpr a - , TupleToSqlExpr b - , TupleToSqlExpr c - , TupleToSqlExpr d - ) => TupleToSqlExpr (a, b, c, d) where - tupleToSqlExpr info = - tupleToSqlExpr info . from4 +instance Internal.SqlToJson JsonBValue (SqlExpr (Value a)) a where + toJson = unsafeSqlFunction "to_jsonb" -instance ( TupleToSqlExpr a - , TupleToSqlExpr b - , TupleToSqlExpr c - , TupleToSqlExpr d - , TupleToSqlExpr e - ) => TupleToSqlExpr (a, b, c, d, e) where - tupleToSqlExpr info = - tupleToSqlExpr info . from5 - -instance ( TupleToSqlExpr a - , TupleToSqlExpr b - , TupleToSqlExpr c - , TupleToSqlExpr d - , TupleToSqlExpr e - , TupleToSqlExpr f - ) => TupleToSqlExpr (a, b, c, d, e, f) where - tupleToSqlExpr info = - tupleToSqlExpr info . from6 - -instance ( TupleToSqlExpr a - , TupleToSqlExpr b - , TupleToSqlExpr c - , TupleToSqlExpr d - , TupleToSqlExpr e - , TupleToSqlExpr f - , TupleToSqlExpr g - ) => TupleToSqlExpr (a, b, c, d, e, f, g) where - tupleToSqlExpr info = - tupleToSqlExpr info . from7 - -instance ( TupleToSqlExpr a - , TupleToSqlExpr b - , TupleToSqlExpr c - , TupleToSqlExpr d - , TupleToSqlExpr e - , TupleToSqlExpr f - , TupleToSqlExpr g - , TupleToSqlExpr h - ) => TupleToSqlExpr (a, b, c, d, e, f, g, h) where - tupleToSqlExpr info = - tupleToSqlExpr info . from8 - - -instance ( PgToJsonb a a' - , PgToJsonb b b' - ) - => PgToJsonb (a, b) (a', b') where - toJsonb (a, b) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - ) - -instance ( PgToJsonb a a' - , PgToJsonb b b' - , PgToJsonb c c' - ) - => PgToJsonb (a, b, c) (a', b', c') where - toJsonb (a, b, c) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - , toJsonb c +instance Internal.JsonAgg JsonBValue where + jsonAgg v = + unsafeSqlFunction "coalesce" + ( unsafeSqlFunction "jsonb_agg" v + , unsafeSqlValue "'[]'::jsonb" ) -instance ( PgToJsonb a a' - , PgToJsonb b b' - , PgToJsonb c c' - , PgToJsonb d d' - ) - => PgToJsonb (a, b, c, d) (a', b', c', d') where - toJsonb (a, b, c, d) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - , toJsonb c - , toJsonb d - ) -instance ( PgToJsonb a a' - , PgToJsonb b b' - , PgToJsonb c c' - , PgToJsonb d d' - , PgToJsonb e e' - ) - => PgToJsonb (a, b, c, d, e) (a', b', c', d', e') where - toJsonb (a, b, c, d, e) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - , toJsonb c - , toJsonb d - , toJsonb e - ) -instance ( PgToJsonb a a' - , PgToJsonb b b' - , PgToJsonb c c' - , PgToJsonb d d' - , PgToJsonb e e' - , PgToJsonb f f' - ) - => PgToJsonb (a, b, c, d, e, f) (a', b', c', d', e', f') where - toJsonb (a, b, c, d, e, f) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - , toJsonb c - , toJsonb d - , toJsonb e - , toJsonb f - ) -instance ( PgToJsonb a a' - , PgToJsonb b b' - , PgToJsonb c c' - , PgToJsonb d d' - , PgToJsonb e e' - , PgToJsonb f f' - , PgToJsonb g g' - ) - => PgToJsonb (a, b, c, d, e, f, g) (a', b', c', d', e', f', g') where - toJsonb (a, b, c, d, e, f, g) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - , toJsonb c - , toJsonb d - , toJsonb e - , toJsonb f - , toJsonb g - ) -instance ( PgToJsonb a a' - , PgToJsonb b b' - , PgToJsonb c c' - , PgToJsonb d d' - , PgToJsonb e e' - , PgToJsonb f f' - , PgToJsonb g g' - , PgToJsonb h h' - ) - => PgToJsonb (a, b, c, d, e, f, g, h) (a', b', c', d', e', f', g', h') where - toJsonb (a, b, c, d, e, f, g, h) = - unsafeJsonbBuildArray $ flip tupleToSqlExpr - ( toJsonb a - , toJsonb b - , toJsonb c - , toJsonb d - , toJsonb e - , toJsonb f - , toJsonb g - , toJsonb h - ) +-- Re-Exports with specified types +toJsonb :: Internal.SqlToJson JsonBValue a a' => a -> SqlExpr (JsonBValue a') +toJsonb = Internal.toJson -unsafeJsonbBuildArray :: (IdentInfo -> ([TLB.Builder], [PersistValue])) -> SqlExpr a -unsafeJsonbBuildArray f = - ERaw noMeta $ \_ info -> - let (t, v) = f info - in ("jsonb_build_array(" <> uncommas t <> ")", v) +jsonbAgg :: SqlExpr (JsonBValue a) -> SqlExpr (JsonBValue [a]) +jsonbAgg = Internal.jsonAgg -unsafeJsonbBuildObject :: [(Text, SqlExpr SomeValue)] -> SqlExpr (JsonValue a) -unsafeJsonbBuildObject fields = - ERaw noMeta $ \p info -> - let (texts, vals) = foldMap (\(haskellName, ERaw _ f) -> - let (t, v) = f p info - in ([TLB.fromText haskellName, t], v)) fields - in ("jsonb_build_object(" <> uncommas texts <> ")", vals) +multiset :: (Internal.SqlToJson JsonBValue a a', Aeson.FromJSON a') + => SqlQuery a -> SqlExpr (JsonBValue [a']) +multiset = Internal.multiset diff --git a/test/PostgreSQL/Test.hs b/test/PostgreSQL/Test.hs index 7795c27c5..cd2e88949 100644 --- a/test/PostgreSQL/Test.hs +++ b/test/PostgreSQL/Test.hs @@ -1468,42 +1468,42 @@ testToJson :: SpecDb testToJson = do itDb "to_json supports Value" $ do r <- select $ pure $ JSONE.toJsonb $ val @Int 1 - asserting $ r `shouldBe` [JSONE.JsonValue 1] + asserting $ r `shouldBe` [JSONE.JsonBValue 1] itDb "to_json supports Entity" $ do p1e <- insert' p1 r <- select $ JSONE.toJsonb <$> Experimental.from (table @Person) - asserting $ r `shouldBe` [JSONE.JsonValue p1e] + asserting $ r `shouldBe` [JSONE.JsonBValue p1e] itDb "to_json supports tuples" $ do p1e <- insert' p1 r <- select $ do p <- Experimental.from $ table @Person pure $ JSONE.toJsonb $ (p, val @Int 1) - asserting $ r `shouldBe` [JSONE.JsonValue (p1e, 1)] + asserting $ r `shouldBe` [JSONE.JsonBValue (p1e, 1)] itDb "to_json supports 3 tuples" $ do p1e <- insert' p1 r <- select $ do p <- Experimental.from $ table @Person pure $ JSONE.toJsonb $ (val @Int 1, p, val @Int 2) - asserting $ r `shouldBe` [JSONE.JsonValue (1, p1e, 2)] + asserting $ r `shouldBe` [JSONE.JsonBValue (1, p1e, 2)] testJsonAgg :: SpecDb testJsonAgg = do itDb "json_agg supports Value" $ do - r <- select $ pure $ JSONE.jsonAgg $ JSONE.toJsonb $ val @Int 1 - asserting $ r `shouldBe` [JSONE.JsonValue [1]] + r <- select $ pure $ JSONE.jsonbAgg $ JSONE.toJsonb $ val @Int 1 + asserting $ r `shouldBe` [JSONE.JsonBValue [1]] itDb "json_agg supports Entities" $ do p1e <- insert' p1 p2e <- insert' p2 - r <- select $ JSONE.jsonAgg . JSONE.toJsonb <$> Experimental.from (table @Person) - asserting $ r `shouldBe` [JSONE.JsonValue [p1e, p2e]] + r <- select $ JSONE.jsonbAgg . JSONE.toJsonb <$> Experimental.from (table @Person) + asserting $ r `shouldBe` [JSONE.JsonBValue [p1e, p2e]] itDb "json_agg supports Tuples" $ do p1e <- insert' p1 p2e <- insert' p2 r <- select $ do p <- Experimental.from $ table @Person p' <- Experimental.from $ table @Person - pure $ JSONE.jsonAgg $ JSONE.toJsonb (p, p') - asserting $ r `shouldBe` [JSONE.JsonValue [(p1e, p1e), (p1e, p2e), (p2e, p1e), (p2e, p2e)]] + pure $ JSONE.jsonbAgg $ JSONE.toJsonb (p, p') + asserting $ r `shouldBe` [JSONE.JsonBValue [(p1e, p1e), (p1e, p2e), (p2e, p1e), (p2e, p2e)]] testNestedMultiset :: SpecDb testNestedMultiset = @@ -1526,8 +1526,8 @@ testNestedMultiset = ) ) res <- select q - asserting $ res `shouldMatchList` [ (p1e, JSONE.JsonValue [(b1e, [c1e]), (b2e, [c2e])]) - , (p2e, JSONE.JsonValue [(b3e, [])]) + asserting $ res `shouldMatchList` [ (p1e, JSONE.JsonBValue [(b1e, [c1e]), (b2e, [c2e])]) + , (p2e, JSONE.JsonBValue [(b3e, [])]) ] type JSONValue = Maybe (JSONB A.Value) From 1d2fc6d9ad9bfeae7c78a9ea8966bb8b26a9067e Mon Sep 17 00:00:00 2001 From: Ben Levy Date: Sun, 28 Nov 2021 17:13:29 -0600 Subject: [PATCH 5/5] Simplify viewFieldBuilder --- src/Database/Esqueleto/Internal/Internal.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/src/Database/Esqueleto/Internal/Internal.hs b/src/Database/Esqueleto/Internal/Internal.hs index a1e519737..8b1efee99 100644 --- a/src/Database/Esqueleto/Internal/Internal.hs +++ b/src/Database/Esqueleto/Internal/Internal.hs @@ -590,10 +590,8 @@ ent ^. field ed = entityDef $ getEntityVal (Proxy :: Proxy (SqlExpr (Entity val))) viewFieldBuilder :: SqlExpr (Entity val) -> IdentInfo -> FieldDef -> TLB.Builder -viewFieldBuilder (ERaw m f) info fieldDef - | Just alias <- sqlExprMetaAlias m = - fst (f Never info) <> ("." <> useIdent info (aliasedEntityColumnIdent alias fieldDef)) - | otherwise = sourceIdent info <> "." <> fieldIdent +viewFieldBuilder (ERaw m f) info fieldDef = + sourceIdent info <> "." <> fieldIdent where sourceIdent = fst <$> f Never fieldIdent