diff --git a/esqueleto.cabal b/esqueleto.cabal index 56c96681f..dac0ee8c7 100644 --- a/esqueleto.cabal +++ b/esqueleto.cabal @@ -33,11 +33,13 @@ 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 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..8b1efee99 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,25 @@ 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 = + 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 +2371,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 @@ -2521,7 +2518,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) = @@ -2557,7 +2554,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 @@ -2576,8 +2573,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 @@ -2684,18 +2681,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 +3382,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/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 new file mode 100644 index 000000000..738ff641f --- /dev/null +++ b/src/Database/Esqueleto/PostgreSQL/JSON/Experimental.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +module Database.Esqueleto.PostgreSQL.JSON.Experimental + where + +import qualified Data.Aeson as Aeson +import Database.Esqueleto.Experimental.ToAlias +import Database.Esqueleto.Experimental.ToAliasReference +import Database.Esqueleto.Experimental.ToMaybe +import Database.Esqueleto.Internal.Internal +import qualified Database.Esqueleto.Internal.JSON as Internal + +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 (JsonBValue a)) (JsonBValue a) where + sqlSelectCols info a = materializeExpr info a + sqlSelectColCount _ = 1 + sqlSelectProcessRow = Internal.sqlSelectProcessRowJSON + +instance ToMaybe (SqlExpr (JsonBValue a)) where + type ToMaybeT (SqlExpr (JsonBValue a)) = SqlExpr (JsonBValue (Maybe (Nullable a))) + toMaybe = veryVeryUnsafeCoerceSqlExpr + +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 (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 + +instance Internal.JsonBuildArray JsonBValue where + unsafeJsonbBuildArray = + unsafeSqlFunction "jsonb_build_array" + +instance Internal.JsonBuildObject JsonBValue where + unsafeJsonbBuildObject = + unsafeSqlFunction "jsonb_build_object" + +instance Internal.SqlToJson JsonBValue (SqlExpr (JsonBValue a)) a where + toJson = id + +instance Internal.SqlToJson JsonBValue (SqlExpr (Value a)) a where + toJson = unsafeSqlFunction "to_jsonb" + +instance Internal.JsonAgg JsonBValue where + jsonAgg v = + unsafeSqlFunction "coalesce" + ( unsafeSqlFunction "jsonb_agg" v + , unsafeSqlValue "'[]'::jsonb" + ) + +-- Re-Exports with specified types +toJsonb :: Internal.SqlToJson JsonBValue a a' => a -> SqlExpr (JsonBValue a') +toJsonb = Internal.toJson + +jsonbAgg :: SqlExpr (JsonBValue a) -> SqlExpr (JsonBValue [a]) +jsonbAgg = Internal.jsonAgg + +multiset :: (Internal.SqlToJson JsonBValue a a', Aeson.FromJSON a') + => SqlQuery a -> SqlExpr (JsonBValue [a']) +multiset = Internal.multiset 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/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 3ff87a1da..cd2e88949 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,71 @@ 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 - +testToJson :: SpecDb +testToJson = do + itDb "to_json supports Value" $ do + r <- select $ pure $ JSONE.toJsonb $ val @Int 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.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.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.JsonBValue (1, p1e, 2)] + +testJsonAgg :: SpecDb +testJsonAgg = do + itDb "json_agg supports Value" $ do + 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.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.jsonbAgg $ JSONE.toJsonb (p, p') + asserting $ r `shouldBe` [JSONE.JsonBValue [(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.JsonBValue [(b1e, [c1e]), (b2e, [c2e])]) + , (p2e, JSONE.JsonBValue [(b3e, [])]) + ] type JSONValue = Maybe (JSONB A.Value) @@ -1628,9 +1622,11 @@ spec = beforeAll mkConnectionPool $ do testJSONInsertions testJSONOperators testLateralQuery - testValuesExpression - testSubselectAliasingBehavior testPostgresqlLocking + describe "PostgreSQL Experimental JSON" $ do + testToJson + testJsonAgg + testNestedMultiset insertJsonValues :: SqlPersistT IO () insertJsonValues = do