Skip to content

Commit

Permalink
fix: JSONEncoded should be of type json rather than jsonb
Browse files Browse the repository at this point in the history
Resolves #344
  • Loading branch information
TeofilC committed Oct 18, 2024
1 parent c482564 commit 91e8859
Show file tree
Hide file tree
Showing 5 changed files with 70 additions and 10 deletions.
3 changes: 3 additions & 0 deletions changelog.d/20241018_113208_teofilcamarasu_jsonb.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,3 @@
### Fixed

- `JSONEncoded` should be encoded as `json` not `jsonb`. Resolves #344
4 changes: 3 additions & 1 deletion rel8.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -242,7 +242,8 @@ library
test-suite tests
type: exitcode-stdio-1.0
build-depends:
base
aeson
, base
, bytestring
, case-insensitive
, containers
Expand All @@ -262,6 +263,7 @@ test-suite tests
, tmp-postgres ^>=1.34.1.0
, transformers
, uuid
, vector

other-modules:
Rel8.Generic.Rel8able.Test
Expand Down
2 changes: 1 addition & 1 deletion src/Rel8/Type/JSONBEncoded.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
39 changes: 33 additions & 6 deletions src/Rel8/Type/JSONEncoded.hs
Original file line number Diff line number Diff line change
@@ -1,29 +1,56 @@
{-# 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
-- using a JSON encoding described by @aeson@'s 'ToJSON' and 'FromJSON' type
-- 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"
}
32 changes: 30 additions & 2 deletions tests/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 )
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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"
Expand Down

0 comments on commit 91e8859

Please sign in to comment.