From 06af0eac53f7c882ad34d6b58be852c2d22b759e Mon Sep 17 00:00:00 2001 From: Teo Camarasu Date: Tue, 22 Oct 2024 12:13:07 +0100 Subject: [PATCH] fix: `JSONEncoded` should be of type `json` rather than `jsonb` (#347) Resolves #344 --- .../20241018_113208_teofilcamarasu_jsonb.md | 3 ++ rel8.cabal | 4 +- src/Rel8/Type/JSONBEncoded.hs | 2 +- src/Rel8/Type/JSONEncoded.hs | 39 ++++++++++++++++--- tests/Main.hs | 32 ++++++++++++++- 5 files changed, 70 insertions(+), 10 deletions(-) create mode 100644 changelog.d/20241018_113208_teofilcamarasu_jsonb.md diff --git a/changelog.d/20241018_113208_teofilcamarasu_jsonb.md b/changelog.d/20241018_113208_teofilcamarasu_jsonb.md new file mode 100644 index 00000000..e2105bb2 --- /dev/null +++ b/changelog.d/20241018_113208_teofilcamarasu_jsonb.md @@ -0,0 +1,3 @@ +### Fixed + +- `JSONEncoded` should be encoded as `json` not `jsonb`. Resolves #344 diff --git a/rel8.cabal b/rel8.cabal index a0e149cc..6d196ecf 100644 --- a/rel8.cabal +++ b/rel8.cabal @@ -242,7 +242,8 @@ library test-suite tests type: exitcode-stdio-1.0 build-depends: - base + aeson + , base , bytestring , case-insensitive , containers @@ -262,6 +263,7 @@ test-suite tests , tmp-postgres ^>=1.34.1.0 , transformers , uuid + , vector other-modules: Rel8.Generic.Rel8able.Test diff --git a/src/Rel8/Type/JSONBEncoded.hs b/src/Rel8/Type/JSONBEncoded.hs index 2878dff0..4cf4bd50 100644 --- a/src/Rel8/Type/JSONBEncoded.hs +++ b/src/Rel8/Type/JSONBEncoded.hs @@ -30,7 +30,7 @@ import Data.Text ( pack ) -- | Like 'Rel8.JSONEncoded', but works for @jsonb@ columns. type JSONBEncoded :: Type -> Type newtype JSONBEncoded a = JSONBEncoded { fromJSONBEncoded :: a } - + deriving (Show, Eq, Ord) instance (FromJSON a, ToJSON a) => DBType (JSONBEncoded a) where typeInformation = TypeInformation diff --git a/src/Rel8/Type/JSONEncoded.hs b/src/Rel8/Type/JSONEncoded.hs index 1681a05d..8194e001 100644 --- a/src/Rel8/Type/JSONEncoded.hs +++ b/src/Rel8/Type/JSONEncoded.hs @@ -1,18 +1,35 @@ {-# language StandaloneKindSignatures #-} +{-# language OverloadedStrings #-} +{-# language TypeApplications #-} module Rel8.Type.JSONEncoded ( JSONEncoded(..) ) where -- aeson -import Data.Aeson ( FromJSON, ToJSON, parseJSON, toJSON ) +import Data.Aeson ( FromJSON, ToJSON, parseJSON ) import Data.Aeson.Types ( parseEither ) +import qualified Data.Aeson as Aeson -- base import Data.Kind ( Type ) +import Data.Bifunctor (first) import Prelude +-- hasql +import qualified Hasql.Decoders as Hasql + -- rel8 import Rel8.Type ( DBType(..) ) -import Rel8.Type.Information ( parseTypeInformation ) +import Rel8.Type.Information ( TypeInformation(..) ) +import Rel8.Type.Decoder ( Decoder(..) ) + +-- opaleye +import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye +import qualified Opaleye.Internal.HaskellDB.Sql.Default as Opaleye ( quote ) + +-- text +import qualified Data.Text as Text +import qualified Data.Text.Lazy as Lazy +import qualified Data.Text.Lazy.Encoding as Lazy -- | A deriving-via helper type for column types that store a Haskell value @@ -20,10 +37,20 @@ import Rel8.Type.Information ( parseTypeInformation ) -- classes. type JSONEncoded :: Type -> Type newtype JSONEncoded a = JSONEncoded { fromJSONEncoded :: a } + deriving (Show, Eq, Ord) instance (FromJSON a, ToJSON a) => DBType (JSONEncoded a) where - typeInformation = parseTypeInformation f g typeInformation - where - f = fmap JSONEncoded . parseEither parseJSON - g = toJSON . fromJSONEncoded + typeInformation = TypeInformation + { encode = + Opaleye.ConstExpr . Opaleye.OtherLit . Opaleye.quote . + Lazy.unpack . Lazy.decodeUtf8 . + Aeson.encode . fromJSONEncoded + , decode = + Decoder + { binary = Hasql.refine (first Text.pack . fmap JSONEncoded . parseEither parseJSON) Hasql.json + , parser = fmap JSONEncoded . Aeson.eitherDecodeStrict + , delimiter = ',' + } + , typeName = "json" + } diff --git a/tests/Main.hs b/tests/Main.hs index 7371e057..75398c6c 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -18,6 +18,11 @@ module Main ) where +-- aeson +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Aeson.Key +import qualified Data.Aeson.KeyMap as Aeson.KeyMap + -- base import Control.Applicative ( empty, liftA2, liftA3 ) import Control.Exception ( bracket, throwIO ) @@ -99,6 +104,9 @@ import qualified Database.Postgres.Temp as TmpPostgres -- uuid import qualified Data.UUID +-- vector +import qualified Data.Vector as Vector + main :: IO () main = defaultMain tests @@ -455,13 +463,16 @@ testDBType getTestDatabase = testGroup "DBType instances" , dbTypeTest "Lazy ByteString" $ Data.ByteString.Lazy.fromStrict <$> Gen.bytes (Range.linear 0 128) , dbTypeTest "Lazy Text" $ Data.Text.Lazy.fromStrict . removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode , dbTypeTest "LocalTime" genLocalTime - , dbTypeTest "Scientific" $ (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100) + , dbTypeTest "Scientific" $ genScientific , dbTypeTest "Text" $ removeNull <$> Gen.text (Range.linear 0 10) Gen.unicode , dbTypeTest "TimeOfDay" genTimeOfDay , dbTypeTest "UTCTime" $ UTCTime <$> genDay <*> genDiffTime , dbTypeTest "UUID" $ Data.UUID.fromWords <$> genWord32 <*> genWord32 <*> genWord32 <*> genWord32 , dbTypeTest "INet" genNetAddrIP , dbTypeTest "INet" genIPRange + , dbTypeTest "Value" genValue + , dbTypeTest "JSONEncoded" genJSONEncoded + , dbTypeTest "JSONBEncoded" genJSONBEncoded ] where @@ -517,7 +528,8 @@ testDBType getTestDatabase = testGroup "DBType instances" diff res''''' (==) (concat xsss) - + genScientific :: Gen Scientific + genScientific = (/ 10) . fromIntegral @Int @Scientific <$> Gen.integral (Range.linear (-100) 100) genComposite :: Gen Composite genComposite = do @@ -593,6 +605,22 @@ testDBType getTestDatabase = testGroup "DBType instances" in Gen.choice [ Data.IP.IPv4Range <$> (Data.IP.makeAddrRange <$> genIPv4 <*> genIP4Mask), Data.IP.IPv6Range <$> (Data.IP.makeAddrRange <$> genIPv6 <*> genIP6Mask)] + genKey :: Gen Aeson.Key + genKey = Aeson.Key.fromText <$> Gen.text (Range.linear 0 10) Gen.unicode + + genValue :: Gen Aeson.Value + genValue = Gen.recursive Gen.choice + [ pure Aeson.Null + , Aeson.Bool <$> Gen.bool + , Aeson.Number <$> genScientific + , Aeson.String <$> Gen.text (Range.linear 0 10) Gen.unicode] + [ Aeson.Object . Aeson.KeyMap.fromMap <$> Gen.map (Range.linear 0 10) ((,) <$> genKey <*> genValue) + , Aeson.Array . Vector.fromList <$> Gen.list (Range.linear 0 10) genValue + ] + + genJSONEncoded = Rel8.JSONEncoded <$> genValue + genJSONBEncoded = Rel8.JSONBEncoded <$> genValue + testDBEq :: IO TmpPostgres.DB -> TestTree testDBEq getTestDatabase = testGroup "DBEq instances"