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.
Isn't
fst (f Never info)literallysourceIdent info?Maybe define
sourceIdentasfst (f Never info)and use in both places?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.
a better question, does this branch ever differ from the otherwise branch? both branches appear to produce identical results for the
Just aliascase.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.
Ah, very true.
fieldIdent'sJustcase will never get triggered 🙃 (And is indeed the same)