From 85c6354291b7346237c18cb46e2160c668c2d8b8 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Sat, 23 Mar 2019 15:29:50 +0000 Subject: [PATCH] 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 | 2 +- migrations/2019_03_19.model | 2 +- src/Data/Aeson/Local.hs | 7 +++- src/Database/Persist/JSON.hs | 69 +++++++++++++++++++++++++++++++++++ src/Vervis/Federation.hs | 7 ++-- src/Vervis/Handler/Inbox.hs | 2 +- src/Vervis/Migration/Model.hs | 1 + src/Vervis/Model.hs | 2 +- vervis.cabal | 1 + 9 files changed, 84 insertions(+), 9 deletions(-) create mode 100644 src/Database/Persist/JSON.hs diff --git a/config/models b/config/models index f8b8313..1576630 100644 --- a/config/models +++ b/config/models @@ -13,7 +13,7 @@ -- . RemoteRawObject - content Value + content PersistJSONObject received UTCTime ------------------------------------------------------------------------------- diff --git a/migrations/2019_03_19.model b/migrations/2019_03_19.model index a6f3980..7f52356 100644 --- a/migrations/2019_03_19.model +++ b/migrations/2019_03_19.model @@ -1,5 +1,5 @@ RemoteRawObject - content Value + content PersistJSONObject received UTCTime RemoteDiscussion diff --git a/src/Data/Aeson/Local.hs b/src/Data/Aeson/Local.hs index 39a75ef..21177d5 100644 --- a/src/Data/Aeson/Local.hs +++ b/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 diff --git a/src/Database/Persist/JSON.hs b/src/Database/Persist/JSON.hs new file mode 100644 index 0000000..695e3bd --- /dev/null +++ b/src/Database/Persist/JSON.hs @@ -0,0 +1,69 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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" diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 7c86f7a..7273498 100644 --- a/src/Vervis/Federation.hs +++ b/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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 83e06ef..a4ba298 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/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) $ diff --git a/src/Vervis/Migration/Model.hs b/src/Vervis/Migration/Model.hs index b76c6c1..df47720 100644 --- a/src/Vervis/Migration/Model.hs +++ b/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) diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 9f68b7a..63db429 100644 --- a/src/Vervis/Model.hs +++ b/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 diff --git a/vervis.cabal b/vervis.cabal index 8804f85..3cb6a5b 100644 --- a/vervis.cabal +++ b/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