Switch jsonb support from persistent-postgresql to a custom module

The custom module provides a parametric wrapper, allowing any specific
FromJSON/ToJSON instance to be used. It's a standalone module though, and not a
wrapper of persistent-postgresql, because persistent-postgresql uses aeson
Value and it prevents using toEncoding to get from the value directly to a
string.

config/models

@@ -13,7 +13,7 @@
 -- <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 RemoteRawObject
-    content  Value
+    content  PersistJSONObject
     received UTCTime
 
 -------------------------------------------------------------------------------

migrations/2019_03_19.model

@@ -1,5 +1,5 @@
 RemoteRawObject
-    content  Value
+    content  PersistJSONObject
     received UTCTime
 
 RemoteDiscussion

src/Data/Aeson/Local.hs

@@ -60,9 +60,12 @@ _ .=? Nothing  = mempty
 k .=? (Just v) = k .= v
 
 data WithValue a = WithValue
-    { wvRaw    :: Value
+    { wvRaw    :: Object
     , wvParsed :: a
     }
 
 instance FromJSON a => FromJSON (WithValue a) where
-    parseJSON v = WithValue v <$> parseJSON v
+    parseJSON v =
+        flip WithValue
+            <$> parseJSON v
+            <*> withObject "WithValue" pure v

src/Database/Persist/JSON.hs

@@ -0,0 +1,69 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+-- | Persistent field type for efficient storage of JSON values, and storage of
+-- Haskell values in general using their JSON representation. Requires
+-- PostgreSQL, and directly uses PostgreSQL's @jsonb@ type.
+--
+-- The module "Database.Persist.PostgreSQL.JSON" from @persistent-postgresql@
+-- provides similar functionality, but it uses aeson's 'Value' type, which
+-- means all encoding has to go through 'Value' and we can't benefit from
+-- 'toEncoding'.
+module Database.Persist.JSON
+    ( PersistJSON (..)
+    , PersistJSONValue
+    , PersistJSONObject
+    )
+where
+
+import Prelude
+
+import Data.Aeson
+import Data.Aeson.Text
+import Data.Text.Lazy.Encoding
+import Database.Persist
+import Database.Persist.Sql
+
+import qualified Data.Text as T
+
+newtype PersistJSON a = PersistJSON
+    { persistJSONValue :: a
+    }
+
+type PersistJSONValue = PersistJSON Value
+
+type PersistJSONObject = PersistJSON Object
+
+-- persistent-postgresql turns jsonb values into PersistByteString, but it
+-- encodes PersistByteString in bytea encoding. So, we encode to PersistText
+-- (to create text encoding, not bytea) and decode from PersistByteString
+-- (because that's what persistent-postgresql sends, which is convenient
+-- because we can directly decode the ByteString using aeson).
+instance (FromJSON a, ToJSON a) => PersistField (PersistJSON a) where
+    toPersistValue = toPersistValue . encodeToLazyText . persistJSONValue
+    fromPersistValue (PersistByteString b) =
+        case eitherDecodeStrict b of
+            Left s -> Left $ T.concat
+                [ "Decoding jsonb value ", T.pack (show b), " failed: "
+                , T.pack s
+                ]
+            Right x -> Right $ PersistJSON x
+    fromPersistValue v =
+        Left $
+            "Expected jsonb field to be decoded by persistent-postgresql as \
+            \a PersistByteString, instead got " <> T.pack (show v)
+
+instance (FromJSON a, ToJSON a) => PersistFieldSql (PersistJSON a) where
+    sqlType _ = SqlOther "jsonb"

src/Vervis/Federation.hs

@@ -24,7 +24,7 @@ import Control.Monad
 import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
-import Data.Aeson (Value)
+import Data.Aeson (Object)
 import Data.Foldable
 import Data.Text (Text)
 import Data.Text.Encoding
@@ -39,6 +39,7 @@ import qualified Data.Text as T
 import qualified Data.Vector as V
 import qualified Database.Esqueleto as E
 
+import Database.Persist.JSON
 import Network.FedURI
 import Web.ActivityPub
 
@@ -51,7 +52,7 @@ import Vervis.Settings
 -- | Handle an activity that came to our inbox. Return a description of what we
 -- did, and whether we stored the activity or not (so that we can decide
 -- whether to log it for debugging).
-handleActivity :: Value -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool)
+handleActivity :: Object -> Text -> InstanceId -> RemoteSharerId -> Activity -> Handler (Text, Bool)
 handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience specific) =
     case specific of
         CreateActivity (Create note) -> do
@@ -199,7 +200,7 @@ handleActivity raw hActor iidActor rsidActor (Activity _id _luActor audience spe
                                             done "Got Create Note replying to remote message which belongs to a different discussion"
                                         return $ Just $ Left mid
             now <- liftIO getCurrentTime
-            rroid <- lift $ insert $ RemoteRawObject raw now
+            rroid <- lift $ insert $ RemoteRawObject (PersistJSON raw) now
             mid <- lift $ insert Message
                 { messageCreated = published
                 , messageContent = content

src/Vervis/Handler/Inbox.hs

@@ -171,7 +171,7 @@ postInboxR = do
         (h, luActor) <- f2l . actorDetailId <$> liftE result
         ActorDetail uActor iid rsid <- liftE result
         let (h, luActor) = f2l uActor
-        wv@(WithValue v (Doc h' a)) <- requireJsonBody
+        wv@(WithValue _ (Doc h' a)) <- requireJsonBody
         unless (h == h') $
             throwE "Activity host doesn't match signature key host"
         unless (activityActor a == luActor) $

src/Vervis/Migration/Model.hs

@@ -40,6 +40,7 @@ import Data.ByteString (ByteString)
 import Data.Text (Text)
 import Data.Time (UTCTime)
 import Database.Persist.Class (EntityField)
+import Database.Persist.JSON (PersistJSONObject)
 import Database.Persist.Schema.Types (Entity)
 import Database.Persist.Schema.SQL ()
 import Database.Persist.Sql (SqlBackend)

src/Vervis/Model.hs

@@ -28,7 +28,7 @@ import Yesod.Auth.Account (PersistUserCredentials (..))
 import Crypto.PublicVerifKey
 import Database.Persist.EmailAddress
 import Database.Persist.Graph.Class
-import Database.Persist.Postgresql.JSON ()
+import Database.Persist.JSON
 import Network.FedURI (FedURI, LocalURI)
 
 import Vervis.Model.Group

vervis.cabal

@@ -73,6 +73,7 @@ library
                        Data.Tree.Local
                        Database.Esqueleto.Local
                        Database.Persist.Class.Local
+                       Database.Persist.JSON
                        Database.Persist.Sql.Local
                        Database.Persist.Local
                        Database.Persist.Local.Class.PersistEntityHierarchy