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