forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Switch OutboxItem's Activity from plain BL to an upgraded PersistJSONObject

Browse source
This commit is contained in:
fr33domlover 2019-06-29 03:19:00 +00:00
parent e10b4d452a
commit 6d72d676e7
16 changed files with 122 additions and 71 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
config/models
View file

@ -47,7 +47,7 @@ Outbox
OutboxItem
outbox OutboxId
activity PersistJSONBL
activity PersistJSONObject
published UTCTime
Inbox

2
migrations/2019_03_19.model
View file

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

2
migrations/2019_03_30.model
View file

@ -1,6 +1,6 @@
OutboxItem
person PersonId
activity PersistJSONValue
activity PersistJSONObject
published UTCTime
FollowerSet

2
migrations/2019_04_22.model
View file

@ -1,7 +1,7 @@
RemoteActivity
instance InstanceId
ident Text
content PersistJSONValue
content PersistJSONObject
received UTCTime
UniqueRemoteActivity instance ident

2
migrations/2019_05_24.model
View file

@ -23,7 +23,7 @@ Person
OutboxItem
person PersonId
activity PersistActivity
activity PersistJSONObject
published UTCTime
Discussion

2
migrations/2019_06_12.model
View file

@ -25,7 +25,7 @@ Person
OutboxItem
person PersonId
activity PersistActivity
activity PersistJSONObject
published UTCTime
Inbox

2
migrations/2019_06_24.model
View file

@ -29,7 +29,7 @@ Outbox
OutboxItem
outbox OutboxId
activity PersistActivity
activity PersistJSONObject
published UTCTime
Inbox

82
src/Database/Persist/JSON.hs
View file

@ -22,32 +22,37 @@
-- means all encoding has to go through 'Value' and we can't benefit from
-- 'toEncoding'.
module Database.Persist.JSON
( PersistJSON (..)
, PersistJSONBL (..)
, PersistJSONValue
( PersistJSON ()
, persistJSONDoc
, persistJSONObject
, persistJSONBytes
, PersistJSONObject
, persistJSONFromDoc
, persistJSONFromObject
, persistJSONFromB
, persistJSONFromBL
, persistJSONObjectFromDoc
)
where
import Data.Aeson
import Data.Aeson.Text
import Data.Text.Lazy.Encoding
import Data.ByteString (ByteString)
import Data.Text.Encoding
import Database.Persist
import Database.Persist.Sql
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
newtype PersistJSON a = PersistJSON
{ persistJSONValue :: a
}
import Data.Aeson.Local
newtype PersistJSONBL = PersistJSONBL
{ persistJSONBL :: BL.ByteString
data PersistJSON a = PersistJSON
{ persistJSONDoc :: a
, persistJSONObject :: Object
, persistJSONBytes :: ByteString
}
type PersistJSONValue = PersistJSON Value
type PersistJSONObject = PersistJSON Object
-- persistent-postgresql turns jsonb values into PersistByteString, but it
@ -56,23 +61,14 @@ type PersistJSONObject = PersistJSON Object
-- (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
toPersistValue = toPersistValue . decodeUtf8 . persistJSONBytes
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 PersistField PersistJSONBL where
toPersistValue = toPersistValue . decodeUtf8 . persistJSONBL
fromPersistValue (PersistByteString b) =
Right $ PersistJSONBL $ BL.fromStrict b
Right (WithValue o d) -> Right $ PersistJSON d o b
fromPersistValue v =
Left $
"Expected jsonb field to be decoded by persistent-postgresql as \
@ -81,5 +77,43 @@ instance PersistField PersistJSONBL where
instance (FromJSON a, ToJSON a) => PersistFieldSql (PersistJSON a) where
sqlType _ = SqlOther "jsonb"
instance PersistFieldSql PersistJSONBL where
sqlType _ = SqlOther "jsonb"
persistJSONFromDoc :: ToJSON a => a -> PersistJSON a
persistJSONFromDoc d =
let bl = encode d
in PersistJSON d (fromEnc $ decode bl) (BL.toStrict bl)
where
fromEnc Nothing = error "persistJSONFromDoc: decode failed"
fromEnc (Just o) = o
persistJSONFromObject :: FromJSON a => Object -> PersistJSON a
persistJSONFromObject o =
let doc =
case fromJSON $ Object o of
Error _ -> error "persistJSONFromObject: parseJSON failed"
Success d -> d
in PersistJSON doc o (BL.toStrict $ encode o)
persistJSONFromB :: FromJSON a => ByteString -> PersistJSON a
persistJSONFromB b =
let WithValue obj doc =
case decodeStrict b of
Nothing -> error "persistJSONFromB: decode failed"
Just x -> x
in PersistJSON doc obj b
persistJSONFromBL :: FromJSON a => BL.ByteString -> PersistJSON a
persistJSONFromBL bl =
let WithValue obj doc =
case decode bl of
Nothing -> error "persistJSONFromBL: decode failed"
Just x -> x
in PersistJSON doc obj (BL.toStrict bl)
persistJSONObjectFromDoc :: ToJSON a => a -> PersistJSON Object
persistJSONObjectFromDoc doc =
let bl = encode doc
obj =
case decode bl of
Nothing -> error "persistJSONObjectFromDoc: decode failed"
Just o -> o
in PersistJSON obj obj (BL.toStrict bl)

13
src/Vervis/API.hs
View file

@ -361,7 +361,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity =
PersistJSONBL $ encode $ activity tempUri tempUri
persistJSONObjectFromDoc $ activity tempUri tempUri
, outboxItemPublished = now
}
lmid <- insert LocalMessage
@ -379,7 +379,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
let luAct = route2local $ SharerOutboxItemR shrUser obihid
luNote = route2local $ MessageR shrUser lmhid
doc = activity luAct luNote
update obiid [OutboxItemActivity =. PersistJSONBL (encode doc)]
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (lmid, obiid, doc)
-- Deliver to local recipients. For local users, find in DB and deliver.
@ -529,14 +529,15 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSONBL $ encode $ activity Nothing
, outboxItemActivity =
persistJSONObjectFromDoc $ activity Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid
let luAct = encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
doc = activity $ Just luAct
update obiid [OutboxItemActivity =. PersistJSONBL (encode doc)]
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc, luAct)
deliverLocal pidAuthor shrProject prjProject now mprojAndDeps obiid luOffer recips = do
(pids, remotes) <- forCollect recips $ \ (shr, LocalSharerRelatedSet sharer projects) -> do
@ -640,7 +641,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity =
PersistJSONBL $ encode $ accept Nothing
persistJSONObjectFromDoc $ accept Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
@ -649,7 +650,7 @@ offerTicketC shrUser summary audience offer@(Offer ticket uTarget) = runExceptT
doc = accept $ Just luAct
update
obiid
[OutboxItemActivity =. PersistJSONBL (encode doc)]
[OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc)
insertTicket jid tidsDeps next obiidAccept = do
did <- insert Discussion

4
src/Vervis/Federation.hs
View file

@ -411,7 +411,7 @@ retryOutboxDelivery = do
(E.Value iid, E.Value h, E.Value uraid, E.Value luRecip, E.Value since, E.Value udlid, E.Value obid, E.Value fwd, E.Value act, E.Value mraid, E.Value mrcid) =
( Left <$> mraid <|> Right <$> mrcid
, ( ( (iid, h)
, ((uraid, luRecip), (udlid, fwd, obid, persistJSONBL act))
, ((uraid, luRecip), (udlid, fwd, obid, BL.fromStrict $ persistJSONBytes act))
)
, since
)
@ -433,7 +433,7 @@ retryOutboxDelivery = do
adaptLinked
(E.Value iid, E.Value h, E.Value raid, E.Value ident, E.Value inbox, E.Value since, E.Value dlid, E.Value fwd, E.Value act) =
( ( (iid, h)
, ((raid, (ident, inbox)), (dlid, fwd, persistJSONBL act))
, ((raid, (ident, inbox)), (dlid, fwd, BL.fromStrict $ persistJSONBytes act))
)
, since
)

4
src/Vervis/Federation/Discussion.hs
View file

@ -174,7 +174,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
throwE "Remote parent belongs to a different discussion"
insertToInbox luCreate ibidRecip = do
let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body
jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luCreate jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True
@ -288,7 +288,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidAuthor
, remoteActivityIdent = luCreate
, remoteActivityContent = PersistJSON $ actbObject body
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
mid <- insert Message

12
src/Vervis/Federation/Ticket.hs
View file

@ -117,7 +117,7 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
throwE "Local dep: No such ticket number in DB"
insertToInbox luOffer ibidRecip = do
let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body
jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luOffer jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True
@ -148,7 +148,7 @@ sharerAcceptOfferTicketF now shrRecip author body (Accept _uOffer _luTicket) = d
where
insertToInbox luAccept ibidRecip = do
let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body
jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luAccept jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True
@ -179,7 +179,7 @@ sharerRejectOfferTicketF now shrRecip author body (Reject _uOffer) = do
where
insertToInbox luReject ibidRecip = do
let iidAuthor = remoteAuthorInstance author
jsonObj = PersistJSON $ actbObject body
jsonObj = persistJSONFromBL $ actbBL body
ract = RemoteActivity iidAuthor luReject jsonObj now
ractid <- either entityKey id <$> insertBy' ract
ibiid <- insert $ InboxItem True
@ -283,7 +283,7 @@ projectOfferTicketF
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityInstance = iidAuthor
, remoteActivityIdent = luOffer
, remoteActivityContent = PersistJSON $ actbObject body
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
ibiid <- insert $ InboxItem False
@ -396,14 +396,14 @@ projectOfferTicketF
}
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSONBL $ encode $ accept Nothing
, outboxItemActivity = persistJSONObjectFromDoc $ accept Nothing
, outboxItemPublished = now
}
encodeRouteLocal <- getEncodeRouteLocal
obikhid <- encodeKeyHashid obiid
let luAct = encodeRouteLocal $ ProjectOutboxItemR shrRecip prjRecip obikhid
doc = accept $ Just luAct
update obiid [OutboxItemActivity =. PersistJSONBL (encode doc)]
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (obiid, doc)
publishAccept luOffer num obiid doc = do

14
src/Vervis/Handler/Inbox.hs
View file

@ -234,8 +234,8 @@ getInbox here getInboxId = do
"InboxItem #" ++ show ibid ++ " neither local nor remote"
(Just _, Just _) ->
error $ "InboxItem #" ++ show ibid ++ " both local and remote"
(Just act, Nothing) -> fromJust $ decode $ persistJSONBL act
(Nothing, Just obj) -> persistJSONValue obj
(Just act, Nothing) -> persistJSONObject act
(Nothing, Just obj) -> persistJSONObject obj
getSharerInboxR :: ShrIdent -> Handler TypedContent
getSharerInboxR shr = getInbox here getInboxId
@ -434,8 +434,6 @@ getOutbox here getObid = do
provideRep (redirectFirstPage here :: Handler Html)
Just (items, navModel) -> do
let current = nmCurrent navModel
decodeToObj :: BL.ByteString -> Maybe Object
decodeToObj = decode
provideAP $ pure $ Doc host $ CollectionPage
{ collectionPageId = pageUrl current
, collectionPageType = CollectionPageTypeOrdered
@ -453,7 +451,7 @@ getOutbox here getObid = do
then Just $ pageUrl $ current + 1
else Nothing
, collectionPageStartIndex = Nothing
, collectionPageItems = map (fromJust . decodeToObj . persistJSONBL . outboxItemActivity . entityVal) items
, collectionPageItems = map (persistJSONObject . outboxItemActivity . entityVal) items
}
provideRep $ do
let pageNav = navWidget navModel
@ -476,7 +474,7 @@ getOutboxItem here getObid obikhid = do
obid <- getObid
obi <- get404 obiid
unless (outboxItemOutbox obi == obid) notFound
return $ persistJSONBL $ outboxItemActivity obi
return $ BL.fromStrict $ persistJSONBytes $ outboxItemActivity obi
provideHtmlAndAP'' body $ redirect (here, [("prettyjson", "true")])
getSharerOutboxR :: ShrIdent -> Handler TypedContent
@ -706,8 +704,8 @@ getNotificationsR shr = do
"InboxItem #" ++ show ibid ++ " neither local nor remote"
(Just _, Just _) ->
error $ "InboxItem #" ++ show ibid ++ " both local and remote"
(Just act, Nothing) -> (ibid, fromJust $ decode $ persistJSONBL act)
(Nothing, Just obj) -> (ibid, persistJSONValue obj)
(Just act, Nothing) -> (ibid, persistJSONObject act)
(Nothing, Just obj) -> (ibid, persistJSONObject obj)
postNotificationsR :: ShrIdent -> Handler Html
postNotificationsR shr = do

44
src/Vervis/Migration.hs
View file

@ -20,11 +20,12 @@ where
import Control.Applicative
import Control.Exception
import Control.Monad (unless)
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Data.Aeson
import Data.ByteString (ByteString)
import Data.Default.Class
import Data.Default.Instances.ByteString ()
@ -52,6 +53,7 @@ import Text.Hamlet
import Web.Hashids
import Web.PathPieces (toPathPiece)
import qualified Data.HashMap.Strict as M
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Database.Esqueleto as E
@ -323,15 +325,31 @@ changes hLocal ctx =
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = RejectActivity $ Reject fedUri
}
insertEntity $ OutboxItem201905 pid (PersistJSON doc) defaultTime
insertEntity $ OutboxItem201905 pid (persistJSONObjectFromDoc doc) defaultTime
)
(Just $ \ (Entity obid ob) -> do
let actNoteId (Activity _ _ _ _ (CreateActivity (Create note))) = noteId note
actNoteId _ = Nothing
let actNoteId a = do
String atyp <- M.lookup "type" a
guard $ atyp == "Create"
Object o <- M.lookup "object" a
String otyp <- M.lookup "type" o
guard $ otyp == "Note"
Just $
let t = case M.lookup "id" o of
Nothing -> error "Mig77: Note 'id' not found"
Just (String s) -> s
_ -> error "Mig77: Note 'id' not a string"
fu = case parseFedURI t of
Left _ -> error "Mig77: Note 'id' invalid FedURI"
Right u -> u
(h, lu) = f2l fu
in if h == hLocal
then lu
else error "Mig77: Note 'id' on foreign host"
obNoteId (Entity i o) =
if i == obid
then Nothing
else (,i) <$> actNoteId (docValue $ persistJSONValue $ outboxItem201905Activity o)
else (,i) <$> actNoteId (persistJSONObject $ outboxItem201905Activity o)
obs <-
mapMaybe obNoteId <$>
selectList ([] :: [Filter OutboxItem201905]) []
@ -459,7 +477,7 @@ changes hLocal ctx =
tempUri = LocalURI "" ""
newObid <- insert OutboxItem201905
{ outboxItem201905Person = pid
, outboxItem201905Activity = PersistJSON $ activity tempUri tempUri
, outboxItem201905Activity = persistJSONObjectFromDoc $ activity tempUri tempUri
, outboxItem201905Published = message201905Created m
}
let notePath = T.concat
@ -473,7 +491,7 @@ changes hLocal ctx =
luAct = LocalURI obPath ""
luNote = LocalURI notePath ""
doc = activity luAct luNote
update newObid [OutboxItem201905Activity =. PersistJSON doc]
update newObid [OutboxItem201905Activity =. persistJSONObjectFromDoc doc]
return newObid
update lmid [LocalMessage201905Create =. obidNew]
@ -690,7 +708,7 @@ changes hLocal ctx =
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = RejectActivity $ Reject fedUri
}
insertEntity $ OutboxItem20190612 pid (PersistJSON doc) defaultTime
insertEntity $ OutboxItem20190612 pid (persistJSONObjectFromDoc doc) defaultTime
)
(Just $ \ (Entity obidTemp obTemp) -> do
ts <- selectList ([] :: [Filter Ticket20190612]) []
@ -763,7 +781,7 @@ changes hLocal ctx =
tempUri = LocalURI "" ""
obidNew <- insert OutboxItem20190612
{ outboxItem20190612Person = pidAuthor
, outboxItem20190612Activity = PersistJSON $ doc tempUri
, outboxItem20190612Activity = persistJSONObjectFromDoc $ doc tempUri
, outboxItem20190612Published =
ticket20190612Created ticket
}
@ -773,7 +791,7 @@ changes hLocal ctx =
encodeRouteLocal $
SharerOutboxItemR shrAuthor obkhidNew
act = doc luAct
update obidNew [OutboxItem20190612Activity =. PersistJSON act]
update obidNew [OutboxItem20190612Activity =. persistJSONObjectFromDoc act]
update talid [TicketAuthorLocal20190612Offer =. obidNew]
ibiid <- insert $ InboxItem20190612 False
insert_ $ InboxItemLocal20190612 ibidProject obidNew ibiid
@ -855,7 +873,7 @@ changes hLocal ctx =
, activityAudience = Audience [] [] [] [] [] []
, activitySpecific = RejectActivity $ Reject fedUri
}
insertEntity $ OutboxItem20190624 obid (PersistJSON doc) defaultTime
insertEntity $ OutboxItem20190624 obid (persistJSONObjectFromDoc doc) defaultTime
)
(Just $ \ (Entity obiidTemp obiTemp) -> do
ts <- selectList ([] :: [Filter Ticket20190624]) []
@ -918,7 +936,7 @@ changes hLocal ctx =
}
obiidNew <- insert OutboxItem20190624
{ outboxItem20190624Outbox = obidProject
, outboxItem20190624Activity = PersistJSON $ doc Nothing
, outboxItem20190624Activity = persistJSONObjectFromDoc $ doc Nothing
, outboxItem20190624Published =
ticket20190624Created ticket
}
@ -928,7 +946,7 @@ changes hLocal ctx =
encodeRouteLocal $
ProjectOutboxItemR shrProject prj obikhidNew
act = doc $ Just luAct
update obiidNew [OutboxItem20190624Activity =. PersistJSON act]
update obiidNew [OutboxItem20190624Activity =. persistJSONObjectFromDoc act]
update tid [Ticket20190624Accept =. obiidNew]
ibiid <- insert $ InboxItem20190624 True
insert_ $ InboxItemLocal20190624 ibidAuthor obiidNew ibiid

2
src/Vervis/Migration/Model.hs
View file

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

4
templates/person/outbox.hamlet
View file

@ -20,8 +20,8 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
^{pageNav}
<div>
$forall Entity _ (OutboxItem _ (PersistJSONBL body) published) <- items
$forall Entity _ (OutboxItem _ doc published) <- items
<div>#{showTime published}
<div>^{renderPrettyJSON' body}
<div>^{renderPrettyJSON' $ BL.fromStrict $ persistJSONBytes doc}
^{pageNav}