Add new Postgresql.JSON.Experimental #283
There are no files selected for viewing
| 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 | ||
|
There was a problem hiding this comment. Are the There was a problem hiding this comment. 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) <> "'" | ||
|
There was a problem hiding this comment. This doesn't seem right. We're using the Haskell names for the database representation of the This is one of the big problems I ran into with trying to have There was a problem hiding this comment. 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. There was a problem hiding this comment. Am I right when I say this There was a problem hiding this comment. Correct, the goal being to make something that automatically just works with the default JSON parser that gets generated. There was a problem hiding this comment.
@parsonsmatt I am not actually clear on what you mean by this? We aren't letting postgres do its default conversion. There was a problem hiding this comment. 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.
There was a problem hiding this comment. This could work sure, if we used a more general There was a problem hiding this comment. So there isn't really a great way to do this in general without that 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 There was a problem hiding this comment. It should be noted that using the QQ's There was a problem hiding this comment. 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 ''UserThis would expect the JSON record to have the type name prefixes. I don't think the So I think we do need a |
||
| , ERaw noMeta $ \_ info -> (viewFieldBuilder ent info fieldDef, []) | ||
| )) (getEntityFields ed) | ||
| idField = fmap (\fieldDef -> | ||
| ( unsafeSqlValue "'id'" | ||
|
There was a problem hiding this comment. This isn't necessarily proper, as you can specify the primary column name: There was a problem hiding this comment. The actual field name in the SQL is irrelevant, it's the representation that FromJSON expects that matters. Entity assumes a key of There was a problem hiding this comment. 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 There was a problem hiding this comment. 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 | ||
|
There was a problem hiding this comment. No need to import 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" | ||
|
|
||
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
wait we have a
Coercibleinstance onSqlExpr? That's no good :|