From 3fb9a6441ff488573239a2df90b7480f970f4cae Mon Sep 17 00:00:00 2001
From: Teo Camarasu <teofilcamarasu@gmail.com>
Date: Fri, 18 Oct 2024 11:45:23 +0100
Subject: [PATCH] fix: `JSONEncoded` should be of type `json` rather than
 `jsonb`

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"