Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add new Postgresql.JSON.Experimental #283

Open
wants to merge 5 commits into
base: master
Choose a base branch
from
Open

Add new Postgresql.JSON.Experimental #283

Show file tree
Hide file tree
Changes from 1 commit
Commits
Show all changes
5 commits
Select commit Hold shift + click to select a range
67ab9c6
Add new Postgresql.JSON.Experimental that supports jsonbAgg and toJso…
belevy Sep 12, 2021
59ab459
Add initial exemplary test
belevy Sep 12, 2021
82f484a
Add more tests for toJson. Fix bug with value toJson
belevy Sep 13, 2021
ab00454
Extract postgres specific functionality into typeclass over jsonValue…
belevy Sep 19, 2021
1d2fc6d
Simplify viewFieldBuilder
belevy Nov 28, 2021
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions esqueleto.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
8 changes: 4 additions & 4 deletions src/Database/Esqueleto/Internal/Internal.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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) =
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down
196 changes: 196 additions & 0 deletions src/Database/Esqueleto/Internal/JSON.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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
Copy link
Contributor

@Vlix Vlix Mar 10, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Are the jsonValue type variables all here in these class definitions so this can later be ported over to the JSONB type, because this is considered experimental at the moment so you want to keep it separate?

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

MySQL supports JSON as well. The intention is to add support in a db agnostic manner with as much independent of db specifics as possible

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) <> "'"
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This doesn't seem right. We're using the Haskell names for the database representation of the Entity, which isn't going to be how the database wants to handle the JSON object.

This is one of the big problems I ran into with trying to have jsonb_agg on Entity a. The {To,From}JSON instances don't work out. So I ended up writing a newtype JSONViaPostgres a that would dig into the EntityDef and figure out how to decode the Postgres JSON. But that also requires that you have a more-or-less standardly defined JSON instance for the record in question.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Does persistent support a way to read the to/from json field name given a field?

We can sidestep the issue of to/from by using a custom decoder. As long as we are consistent at the boundaries we could even avoid the need to specify JSON instances for the types.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Am I right when I say this SqlToJSON instance tries to put all the columns in their own field of a JSON object? (Just checking if I'm reading this right)

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Correct, the goal being to make something that automatically just works with the default JSON parser that gets generated.

Copy link
Collaborator Author

@belevy belevy Mar 14, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

which isn't going to be how the database wants to handle the JSON object.

@parsonsmatt I am not actually clear on what you mean by this? We aren't letting postgres do its default conversion.

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, I think I'm unsure that this is the right approach for converting something to a JSON representation.

I think I'd rather see something like:

newtype JsonEntity a = JsonEntity (Entity a)

instance PersistEntity a => FromJSON (JsonEntity a) where
    parseJSON = withObject "JsonEntity" $ \o -> do
        let edef = entityDef (Proxy @a)
        ...

which definitely parses how a database would convert things to JSON. Then we aren't having to worry about custom encoders or decoders.

persistent-2.14's tabulateEntityA could be useful here, but we may also need the FieldDict class from prairie to make it work how we want.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This could work sure, if we used a more general newtype SqlJson a = SqlJson a we can have it default to the underlying FromJSON and avoid surfacing the actual newtype to the end user though. The entity instance could then be defined as overlapping that default.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

So there isn't really a great way to do this in general without that FieldDict class since we need to know that the value on the other side has a FromJSON dictionary.

Is there an example of someone using an exotic JSON parser? The thing that I need the default parser for is the underlying record not the Entity record since the entityIdFromJSON delegates to the FromJSON instance on the record.

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

It should be noted that using the QQ's json tag will actually only allow you to configure the outer encoder/decoder but the record its self is always just haskellName: someValue

Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't think it even has to be an exotic parse, just a different set of options. Like,

mkPersist sqlSettings [persistLowerCase|
    User
        name Text
        age Int
|]

deriveJSON defaultOptions ''User

This would expect the JSON record to have the type name prefixes. I don't think the haskellName has those. Any other modification to those options would break parsing the records from the database.

So I think we do need a newtype with a custom FromJSON instance, and we also need the FieldDict class. I'll see about re-exporting that from persistent and generating those instances.

, ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, [])
)) (getEntityFields ed)
idField = fmap (\fieldDef ->
( unsafeSqlValue "'id'"
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This isn't necessarily proper, as you can specify the primary column name:

User
    Id UUID sql="my_user_id"

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The actual field name in the SQL is irrelevant, it's the representation that FromJSON expects that matters. Entity assumes a key of id

Copy link
Contributor

@Vlix Vlix Mar 10, 2022 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Is it not possible to use the database names? 🤔 To me that sounds more robust/portable.

Though I guess if it only happens within one query, it doesn't really matter.

EDIT: Oh, that might also make it possible to get back easily using jsonb_to_record

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Indeed the db names could be used and a custom JSON decoder could be used to extract the fields.

, 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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No need to import Data.ByteString.Lazy, aeson's got your back:

either Text.pack pure $
    Aeson.eitherDecodeStrict bs

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"

Loading