forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Decouple OutboxItem from Person via a new table named Outbox

Browse source
This commit is contained in:
fr33domlover 2019-06-15 18:51:26 +00:00
parent 6452d239f2
commit 499479b662
8 changed files with 113 additions and 34 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

6
config/models
View file

@ -35,14 +35,18 @@ Person
resetPassKeyCreated UTCTime
about Text
inbox InboxId
outbox OutboxId
UniquePersonIdent ident
UniquePersonLogin login
UniquePersonEmail email
UniquePersonInbox inbox
UniquePersonOutbox outbox
Outbox
OutboxItem
person PersonId
outbox OutboxId
activity PersistActivity
published UTCTime

26
migrations/2019_06_15.model Normal file
View file

@ -0,0 +1,26 @@
Person
ident Int64
login Text
passphraseHash ByteString
email Text
verified Bool
verifiedKey Text
verifiedKeyCreated UTCTime
resetPassKey Text
resetPassKeyCreated UTCTime
about Text
inbox Int64
outbox OutboxId
UniquePersonIdent ident
UniquePersonLogin login
UniquePersonEmail email
UniquePersonInbox inbox
Outbox
OutboxItem
person PersonId
outbox OutboxId
activity PersistJSONObject
published UTCTime

38
src/Vervis/API.hs
View file

@ -162,8 +162,8 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
federation <- getsYesod $ appFederation . appSettings
unless (federation || null remoteRecips) $
throwE "Federation disabled, but remote recipients specified"
(lmid, obid, doc, remotesHttp) <- runDBExcept $ do
(pid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
(lmid, obiid, doc, remotesHttp) <- runDBExcept $ do
(pid, obid, shrUser) <- verifyIsLoggedInUser luAttrib "Note attributed to different actor"
(did, meparent, mcollections) <- case mticket of
Just (shr, prj, num) -> do
mt <- lift $ runMaybeT $ do
@ -231,13 +231,13 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
\ commented on a #
<a href=#{renderFedURI uContext}>ticket</a>.
|]
(lmid, obid, doc) <- lift $ insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary
moreRemotes <- deliverLocal pid obid localRecips mcollections
(lmid, obiid, doc) <- lift $ insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary
moreRemotes <- deliverLocal pid obiid localRecips mcollections
unless (federation || null moreRemotes) $
throwE "Federation disabled but remote collection members found"
remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obid remoteRecips moreRemotes
return (lmid, obid, doc, remotesHttp)
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obid doc remotesHttp
remotesHttp <- lift $ deliverRemoteDB (furiHost uContext) obiid remoteRecips moreRemotes
return (lmid, obiid, doc, remotesHttp)
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp (furiHost uContext) obiid doc remotesHttp
return lmid
where
nonEmptyE :: Monad m => [a] -> e -> ExceptT e m (NonEmpty a)
@ -401,20 +401,24 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
verifyOnlySharers :: LocalRecipientSet -> ExceptT Text Handler [ShrIdent]
verifyOnlySharers lrs = catMaybes <$> traverse (atMostSharer "Note with remote context but local project-related recipients") lrs
verifyIsLoggedInUser :: LocalURI -> Text -> ExceptT Text AppDB (PersonId, ShrIdent)
verifyIsLoggedInUser
:: LocalURI
-> Text
-> ExceptT Text AppDB (PersonId, OutboxId, ShrIdent)
verifyIsLoggedInUser lu t = do
Entity pid p <- requireVerifiedAuth
s <- lift $ getJust $ personIdent p
route2local <- getEncodeRouteLocal
let shr = sharerIdent s
if route2local (SharerR shr) == lu
then return (pid, shr)
then return (pid, personOutbox p, shr)
else throwE t
insertMessage
:: LocalURI
-> ShrIdent
-> PersonId
-> OutboxId
-> FedURI
-> DiscussionId
-> Maybe FedURI
@ -423,7 +427,7 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
-> Text
-> Html
-> AppDB (LocalMessageId, OutboxItemId, Doc Activity)
insertMessage luAttrib shrUser pid uContext did muParent meparent source content summary = do
insertMessage luAttrib shrUser pid obid uContext did muParent meparent source content summary = do
now <- liftIO getCurrentTime
mid <- insert Message
{ messageCreated = now
@ -454,28 +458,28 @@ createNoteC host (Note mluNote luAttrib aud muParent muContext mpublished source
}
}
tempUri = LocalURI "" ""
obid <- insert OutboxItem
{ outboxItemPerson = pid
obiid <- insert OutboxItem
{ outboxItemOutbox = obid
, outboxItemActivity = PersistJSON $ activity tempUri tempUri
, outboxItemPublished = now
}
lmid <- insert LocalMessage
{ localMessageAuthor = pid
, localMessageRest = mid
, localMessageCreate = obid
, localMessageCreate = obiid
, localMessageUnlinkedParent =
case meparent of
Just (Right uParent) -> Just uParent
_ -> Nothing
}
route2local <- getEncodeRouteLocal
obhid <- encodeKeyHashid obid
obihid <- encodeKeyHashid obiid
lmhid <- encodeKeyHashid lmid
let luAct = route2local $ OutboxItemR shrUser obhid
let luAct = route2local $ OutboxItemR shrUser obihid
luNote = route2local $ MessageR shrUser lmhid
doc = activity luAct luNote
update obid [OutboxItemActivity =. PersistJSON doc]
return (lmid, obid, doc)
update obiid [OutboxItemActivity =. PersistJSON doc]
return (lmid, obiid, doc)
-- Deliver to local recipients. For local users, find in DB and deliver.
-- For local collections, expand them, deliver to local users, and return a

17
src/Vervis/Federation.hs
View file

@ -410,22 +410,25 @@ handleSharerInbox
-> Activity
-> ExceptT Text Handler Text
handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
(shrActivity, obid) <- do
(shrActivity, obiid) <- do
route <-
case decodeRouteLocal $ activityId activity of
Nothing -> throwE "Local activity: Not a valid route"
Just r -> return r
case route of
OutboxItemR shr obkhid ->
(shr,) <$> decodeKeyHashidE obkhid "Local activity: ID is invalid hashid"
OutboxItemR shr obikhid ->
(shr,) <$> decodeKeyHashidE obikhid "Local activity: ID is invalid hashid"
_ -> throwE "Local activity: Not an activity route"
runDBExcept $ do
Entity pidRecip personRecip <- lift $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniquePersonIdent sid
mob <- lift $ get obid
ob <- fromMaybeE mob "Local activity: No such ID in DB"
let pidOutbox = outboxItemPerson ob
mobi <- lift $ get obiid
obi <- fromMaybeE mobi "Local activity: No such ID in DB"
mpidOutbox <-
lift $ getKeyBy $ UniquePersonOutbox $ outboxItemOutbox obi
pidOutbox <-
fromMaybeE mpidOutbox "Local activity not in a user outbox"
p <- lift $ getJust pidOutbox
s <- lift $ getJust $ personIdent p
unless (sharerIdent s == shrActivity) $
@ -437,7 +440,7 @@ handleSharerInbox _now shrRecip (Left pidAuthor) _raw activity = do
else lift $ do
ibiid <- insert $ InboxItem True
let ibid = personInbox personRecip
miblid <- insertUnique $ InboxItemLocal ibid obid ibiid
miblid <- insertUnique $ InboxItemLocal ibid obiid ibiid
let recip = shr2text shrRecip
case miblid of
Nothing -> do

2
src/Vervis/Foundation.hs
View file

@ -589,6 +589,7 @@ instance AccountDB AccountPersistDB' where
return $ Left $ mr $ MsgUsernameExists name
Right sid -> do
ibid <- insert Inbox
obid <- insert Outbox
let defTime = UTCTime (ModifiedJulianDay 0) 0
person = Person
{ personIdent = sid
@ -602,6 +603,7 @@ instance AccountDB AccountPersistDB' where
, personResetPassKeyCreated = defTime
, personAbout = ""
, personInbox = ibid
, personOutbox = obid
}
pid <- insert person
return $ Right $ Entity pid person

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

@ -369,9 +369,10 @@ getOutboxR :: ShrIdent -> Handler TypedContent
getOutboxR shr = do
(total, pages, mpage) <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
pid <- getKeyBy404 $ UniquePersonIdent sid
let countAllItems = count [OutboxItemPerson ==. pid]
selectItems off lim = selectList [OutboxItemPerson ==. pid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
p <- getValBy404 $ UniquePersonIdent sid
let obid = personOutbox p
countAllItems = count [OutboxItemOutbox ==. obid]
selectItems off lim = selectList [OutboxItemOutbox ==. obid] [Desc OutboxItemId, OffsetBy off, LimitTo lim]
getPageAndNavCount countAllItems selectItems
let here = OutboxR shr
encodeRouteLocal <- getEncodeRouteLocal
@ -423,14 +424,14 @@ getOutboxR shr = do
defaultLayout $(widgetFile "person/outbox")
getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
getOutboxItemR shr obkhid = do
obid <- decodeKeyHashid404 obkhid
getOutboxItemR shr obikhid = do
obiid <- decodeKeyHashid404 obikhid
doc <- runDB $ do
sid <- getKeyBy404 $ UniqueSharer shr
pid <- getKeyBy404 $ UniquePersonIdent sid
ob <- get404 obid
unless (outboxItemPerson ob == pid) notFound
return $ persistJSONValue $ outboxItemActivity ob
p <- getValBy404 $ UniquePersonIdent sid
obi <- get404 obiid
unless (outboxItemOutbox obi == personOutbox p) notFound
return $ persistJSONValue $ outboxItemActivity obi
selectRep $ do
provideAP $ pure doc
provideRep $ defaultLayout $

31
src/Vervis/Migration.hs
View file

@ -788,6 +788,37 @@ changes hLocal ctx =
-- 115
, addUnique "TicketAuthorLocal" $
Unique "UniqueTicketAuthorLocaleOffer" ["offer"]
-- 116
, addEntity $ ST.Entity "Outbox" [] []
-- 117
, addFieldRefRequired'
"Person"
Outbox20190615
(Just $ do
pids <- selectKeysList ([] :: [Filter Person20190615]) []
for_ pids $ \ pid -> do
obid <- insert Outbox20190615
update pid [Person20190615Outbox =. obid]
)
"outbox"
"Outbox"
-- 118
, addUnique "Person" $ Unique "UniquePersonOutbox" ["outbox"]
-- 119
, addFieldRefRequired'
"OutboxItem"
Outbox20190615
(Just $ do
obiids <- selectList ([] :: [Filter OutboxItem20190615]) []
for_ obiids $ \ (Entity obiid obi) -> do
person <- getJust $ outboxItem20190615Person obi
let obid = person20190615Outbox person
update obiid [OutboxItem20190615Outbox =. obid]
)
"outbox"
"Outbox"
-- 120
, removeField "OutboxItem" "person"
]
migrateDB

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

@ -91,6 +91,11 @@ module Vervis.Migration.Model
, Ticket20190612Generic (..)
, Ticket20190612
, TicketAuthorLocal20190612Generic (..)
, Person20190615Generic (..)
, Person20190615
, Outbox20190615Generic (..)
, OutboxItem20190615Generic (..)
, OutboxItem20190615
)
where
@ -199,3 +204,6 @@ makeEntitiesMigration "20190610"
makeEntitiesMigration "20190612"
$(modelFile "migrations/2019_06_12.model")
makeEntitiesMigration "20190615"
$(modelFile "migrations/2019_06_15.model")