S2S: sharerCreateNoteF & projectCreateNoteF can handle sharer-hosted tickets

This commit is contained in:
fr33domlover 2020-05-11 18:59:29 +00:00
parent edaa3c49b2
commit c91908941b
3 changed files with 242 additions and 191 deletions

View file

@ -149,11 +149,6 @@ parseComment luParent = do
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
_ -> throwE "Not a local message route"
data NoteContext
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
deriving Eq
noteC
:: Entity Person
-> Sharer

View file

@ -14,7 +14,8 @@
-}
module Vervis.ActivityPub
( hostIsLocal
( NoteContext (..)
, hostIsLocal
, verifyHostLocal
, parseContext
, parseParent
@ -43,6 +44,7 @@ module Vervis.ActivityPub
, deliverLocal
, RemoteRecipient (..)
, deliverLocal'
, insertRemoteActivityToLocalInboxes
)
where
@ -119,6 +121,11 @@ import Vervis.Time
import Vervis.Widget.Repo
import Vervis.Widget.Sharer
data NoteContext
= NoteContextSharerTicket ShrIdent TicketAuthorLocalId
| NoteContextProjectTicket ShrIdent PrjIdent LocalTicketId
deriving Eq
hostIsLocal :: (MonadSite m, SiteEnv m ~ App) => Host -> m Bool
hostIsLocal h = asksSite $ (== h) . appInstanceHost . appSettings
@ -132,7 +139,7 @@ verifyHostLocal h t = do
parseContext
:: (MonadSite m, SiteEnv m ~ App)
=> FedURI
-> ExceptT Text m (Either (ShrIdent, PrjIdent, KeyHashid LocalTicket) FedURI)
-> ExceptT Text m (Either NoteContext FedURI)
parseContext uContext = do
let ObjURI hContext luContext = uContext
local <- hostIsLocal hContext
@ -142,7 +149,12 @@ parseContext uContext = do
Nothing -> throwE "Local context isn't a valid route"
Just r -> return r
case route of
ProjectTicketR shr prj num -> return (shr, prj, num)
SharerTicketR shr talkhid ->
NoteContextSharerTicket shr <$>
decodeKeyHashidE talkhid "Note context invalid talkhid"
ProjectTicketR shr prj ltkhid ->
NoteContextProjectTicket shr prj <$>
decodeKeyHashidE ltkhid "Note context invalid ltkhid"
_ -> throwE "Local context isn't a ticket route"
else return $ Right uContext
@ -735,15 +747,25 @@ data RemoteRecipient = RemoteRecipient
-- * Insert activity to inboxes of actors
-- * If collections are listed, insert activity to the local members and return
-- the remote members
deliverLocal'
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-> LocalActor
-> InboxId
-> OutboxItemId
insertActivityToLocalInboxes
:: PersistRecordBackend record SqlBackend
=> (InboxId -> InboxItemId -> record)
-- ^ Database record to insert as an new inbox item to each inbox
-> Bool
-- ^ Whether to deliver to collection only if owner actor is addressed
-> Maybe LocalActor
-- ^ An actor whose collections are excluded from requiring an owner, i.e.
-- even if owner is required, this actor's collections will be delivered
-- to, even if this actor isn't addressed. This is meant to be the
-- activity's author.
-> Maybe InboxId
-- ^ A user person's inbox to exclude from delivery, even if this person is
-- listed in the recipient set. This is meant to be the activity's
-- author.
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author ibidAuthor obiid recips = do
ibidsSharer <- L.delete ibidAuthor <$> getSharerInboxes recips
insertActivityToLocalInboxes makeInboxItem requireOwner mauthor mibidAuthor recips = do
ibidsSharer <- deleteAuthor <$> getSharerInboxes recips
ibidsOther <- concat <$> traverse getOtherInboxes recips
(ibidsFollowers, remotesFollowers) <- do
@ -754,13 +776,23 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
ibidsTeams <- foldl' LO.union [] <$> traverse getTeams recips
let ibids = L.delete ibidAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther
let ibids = deleteAuthor (ibidsFollowers `LO.union` ibidsTeams `LO.union` ibidsSharer) ++ ibidsOther
ibiids <- insertMany $ replicate (length ibids) $ InboxItem True
insertMany_ $
map (\ (ibid, ibiid) -> InboxItemLocal ibid obiid ibiid)
(zip ibids ibiids)
insertMany_ $ zipWith makeInboxItem ibids ibiids
return remotesFollowers
where
isAuthor :: LocalActor -> Bool
isAuthor =
case mauthor of
Nothing -> const False
Just author -> (== author)
deleteAuthor :: [InboxId] -> [InboxId]
deleteAuthor =
case mibidAuthor of
Nothing -> id
Just ibidAuthor -> L.delete ibidAuthor
getSharerInboxes :: LocalRecipientSet -> AppDB [InboxId]
getSharerInboxes sharers = do
let shrs =
@ -801,7 +833,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[shr | (shr, s) <- sharers
, let d = localRecipSharerDirect s
in localRecipSharerFollowers d &&
(localRecipSharer d || not requireOwner || LocalActorSharer shr == author)
(localRecipSharer d || not requireOwner || isAuthor (LocalActorSharer shr))
]
sids <- selectKeysList [SharerIdent <-. shrs] []
map (personFollowers . entityVal) <$> selectList [PersonIdent <-. sids] []
@ -838,7 +870,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[prj | (prj, j) <- projects
, let d = localRecipProjectDirect j
in localRecipProjectFollowers d &&
(localRecipProject d || not requireOwner || LocalActorProject shr prj == author)
(localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj))
]
fsidsJ <-
map (projectFollowers . entityVal) <$>
@ -848,7 +880,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
then
[ (prj, localRecipProjectTicketRelated j)
| (prj, j) <- projects
, localRecipProject (localRecipProjectDirect j) || LocalActorProject shr prj == author
, localRecipProject (localRecipProjectDirect j) || isAuthor (LocalActorProject shr prj)
]
else
map (second localRecipProjectTicketRelated) projects
@ -882,7 +914,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[rp | (rp, r) <- repos
, let d = localRecipRepoDirect r
in localRecipRepoFollowers d &&
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
(localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp))
]
in map (repoFollowers . entityVal) <$>
selectList [RepoSharer ==. sid, RepoIdent <-. rps] []
@ -935,7 +967,7 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
getProjectTeams sid projects = do
let prjs =
[prj | (prj, LocalProjectRelatedSet d ts) <- projects
, (localRecipProject d || not requireOwner || LocalActorProject shr prj == author) &&
, (localRecipProject d || not requireOwner || isAuthor (LocalActorProject shr prj)) &&
(localRecipProjectTeam d || any (localRecipTicketTeam . snd) ts)
]
jids <- selectKeysList [ProjectSharer ==. sid, ProjectIdent <-. prjs] []
@ -946,8 +978,36 @@ deliverLocal' requireOwner author ibidAuthor obiid recips = do
[rp | (rp, r) <- repos
, let d = localRecipRepoDirect r
in localRecipRepoTeam d &&
(localRecipRepo d || not requireOwner || LocalActorRepo shr rp == author)
(localRecipRepo d || not requireOwner || isAuthor (LocalActorRepo shr rp))
]
rids <- selectKeysList [RepoSharer ==. sid, RepoIdent <-. rps] []
pids <- map (repoCollabPerson . entityVal) <$> selectList [RepoCollabRepo <-. rids] []
map (personInbox . entityVal) <$> selectList [PersonId <-. pids] [Asc PersonInbox]
-- | Given a list of local recipients, which may include actors and
-- collections,
--
-- * Insert activity to inboxes of actors
-- * If collections are listed, insert activity to the local members and return
-- the remote members
deliverLocal'
:: Bool -- ^ Whether to deliver to collection only if owner actor is addressed
-> LocalActor
-> InboxId
-> OutboxItemId
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal' requireOwner author ibidAuthor obiid =
insertActivityToLocalInboxes makeItem requireOwner (Just author) (Just ibidAuthor)
where
makeItem ibid ibiid = InboxItemLocal ibid obiid ibiid
insertRemoteActivityToLocalInboxes
:: Bool
-> RemoteActivityId
-> LocalRecipientSet
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
insertRemoteActivityToLocalInboxes requireOwner ractid =
insertActivityToLocalInboxes makeItem requireOwner Nothing Nothing
where
makeItem ibid ibiid = InboxItemRemote ibid ractid ibiid

View file

@ -27,6 +27,7 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Bifunctor
import Data.ByteString (ByteString)
import Data.Either
import Data.Foldable
import Data.Function
import Data.List (sort, deleteBy, nub, union, unionBy, partition)
@ -55,6 +56,7 @@ import Web.ActivityPub
import Yesod.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Yesod.MonadSite
import Control.Monad.Trans.Except.Local
import Data.Tuple.Local
@ -69,6 +71,7 @@ import Vervis.Foundation
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Settings
import Vervis.Ticket
sharerCreateNoteF
:: UTCTime
@ -101,20 +104,19 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
Right _ ->
Right <$> insertToInbox luCreate (personInbox personRecip)
where
checkContextParent context mparent = runExceptT $ do
checkContextParent (Left context) mparent = runExceptT $ do
did <-
case context of
Left (shr, prj, ltkhid) -> do
mdid <- lift $ runMaybeT $ do
sid <- MaybeT $ getKeyBy $ UniqueSharer shr
jid <- MaybeT $ getKeyBy $ UniqueProject prj sid
ltid <- decodeKeyHashidM ltkhid
lt <- MaybeT $ get ltid
tpl <-
MaybeT $ getValBy $
UniqueTicketProjectLocal $ localTicketTicket lt
guard $ ticketProjectLocalProject tpl == jid
NoteContextSharerTicket shr talid -> do
(_, Entity _ lt, _, project) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Note context no such local sharer-hosted ticket"
return $ localTicketDiscuss lt
NoteContextProjectTicket shr prj ltid -> do
(_, _, _, Entity _ lt, _, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Note context no such local project-hosted ticket"
return $ localTicketDiscuss lt
did <- fromMaybeE mdid "Context: No such local ticket"
for_ mparent $ \ parent ->
case parent of
Left (shrP, lmidP) ->
@ -129,7 +131,7 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
m <- lift $ getJust mid
unless (messageRoot m == did) $
throwE "Remote parent belongs to a different discussion"
Right (ObjURI hContext luContext) -> do
checkContextParent (Right (ObjURI hContext luContext)) mparent = runExceptT $ do
mdid <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hContext
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luContext
@ -167,12 +169,6 @@ sharerCreateNoteF now shrRecip author body (Note mluNote _ _ muParent muContext
return $ "Activity already exists in inbox of /s/" <> recip
Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
data CreateNoteRecipColl
= CreateNoteRecipProjectFollowers
| CreateNoteRecipTicketParticipants
| CreateNoteRecipTicketTeam
deriving Eq
projectCreateNoteF
:: UTCTime
-> ShrIdent
@ -195,68 +191,109 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
if uParent == uContext
then return Nothing
else Just <$> parseParent uParent
case context of
Right _ -> return $ recip <> " not using; context isn't local"
Left (shr, prj, ltkhid) ->
if shr /= shrRecip || prj /= prjRecip
then return $ recip <> " not using; context is a different project"
else do
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward shrRecip prjRecip
hLocal <- getsYesod $ appInstanceHost . appSettings
let colls =
findRelevantCollections hLocal ltkhid $
activityAudience $ actbActivity body
case context of
Right _ -> return "Not using; context isn't local"
Left (NoteContextSharerTicket shr talid) -> do
mremotesHttp <- runDBExcept $ do
(sid, fsidProject, fsidTicket, jid, ibid, did, meparent) <- getContextAndParent ltkhid mparent
lift $ join <$> do
mmid <- insertToDiscussion luCreate luNote published ibid did meparent fsidTicket
for mmid $ \ (ractid, mid) -> do
updateOrphans luNote did mid
for msig $ \ sig -> do
remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
(jid, ibid) <- lift getProjectRecip404
(_, _, _, project) <- do
mticket <- lift $ getSharerTicket shr talid
fromMaybeE mticket "Context: No such sharer-ticket"
case project of
Left (Entity _ tpl)
| ticketProjectLocalProject tpl == jid -> do
mractid <- lift $ insertToProjectInbox ibid luCreate
case mractid of
Nothing -> return $ Left "Activity already in my inbox"
Just ractid ->
case msig of
Nothing ->
return $ Left
"Context is a sharer-ticket, \
\but no inbox forwarding \
\header for me, so doing \
\nothing, just storing in inbox"
Just sig -> lift $ Right <$> do
let sieve =
makeRecipientSet
[]
[ LocalPersonCollectionProjectFollowers shrRecip prjRecip
, LocalPersonCollectionProjectTeam shrRecip prjRecip
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
forkHandler handler $
deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
return $ recip <> " inserted new ticket comment"
where
findRelevantCollections hLocal ctx = nub . mapMaybe decide . concatRecipients
where
decide u = do
let ObjURI h lu = u
guard $ h == hLocal
route <- decodeRouteLocal lu
case route of
ProjectFollowersR shr prj
| shr == shrRecip && prj == prjRecip
-> Just CreateNoteRecipProjectFollowers
ProjectTicketParticipantsR shr prj tkhid
| shr == shrRecip && prj == prjRecip && tkhid == ctx
-> Just CreateNoteRecipTicketParticipants
ProjectTicketTeamR shr prj tkhid
| shr == shrRecip && prj == prjRecip && tkhid == ctx
-> Just CreateNoteRecipTicketTeam
_ -> Nothing
recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
getContextAndParent ltkhid mparent = do
mt <- do
sid <- lift $ getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- lift $ getBy404 $ UniqueProject prjRecip sid
ltid <- decodeKeyHashidE ltkhid "Context: Not a valid ticket khid"
mlt <- lift $ get ltid
for mlt $ \ lt -> do
mtpl <- lift $ getValBy $ UniqueTicketProjectLocal $ localTicketTicket lt
tpl <- fromMaybeE mtpl "No TPL"
unless (ticketProjectLocalProject tpl == jid) $
throwE "Context: Local ticket khid belongs to different project"
return (jid, projectInbox j, projectFollowers j, sid, lt)
(jid, ibid, fsidProject, sid, lt) <- fromMaybeE mt "Context: No such local ticket"
_ -> return $ Left "Context is a sharer-ticket of another project"
case mremotesHttp of
Left msg -> return msg
Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
return "Stored to inbox and did inbox forwarding"
Left (NoteContextProjectTicket shr prj ltid) -> do
mremotesHttp <- runDBExcept $ do
(jid, ibid) <- lift getProjectRecip404
(_, _, _, Entity _ lt, Entity _ tpl, _) <- do
mticket <- lift $ getProjectTicket shr prj ltid
fromMaybeE mticket "Context: No such project-ticket"
if ticketProjectLocalProject tpl == jid
then do
mractid <- lift $ insertToProjectInbox ibid luCreate
case mractid of
Nothing -> return $ Left "Activity already in my inbox"
Just ractid -> do
let did = localTicketDiscuss lt
meparent <- for mparent $ \ parent ->
case parent of
Left (shrParent, lmidParent) -> Left <$> getLocalParentMessageId did shrParent lmidParent
Right p@(ObjURI hParent luParent) -> do
meparent <- traverse (getParent did) mparent
mmid <- lift $ insertToDiscussion luNote published did meparent ractid
case mmid of
Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do
updateOrphans luNote did mid
case msig of
Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
Just sig -> Right <$> do
ltkhid <- encodeKeyHashid ltid
let sieve =
makeRecipientSet
[]
[ LocalPersonCollectionProjectFollowers shrRecip prjRecip
, LocalPersonCollectionProjectTeam shrRecip prjRecip
, LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
, LocalPersonCollectionProjectTicketTeam shrRecip prjRecip ltkhid
]
remoteRecips <- insertRemoteActivityToLocalInboxes False ractid $ localRecipSieve' sieve False False localRecips
(sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
else return $ Left "Context is a project-ticket of another project"
case mremotesHttp of
Left msg -> return msg
Right (sig, remotesHttp) -> do
forkWorker "projectCreateNoteF inbox forwarding by http" $ deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
return "Stored to inbox, cached comment, and did inbox forwarding"
where
getProjectRecip404 = do
sid <- getKeyBy404 $ UniqueSharer shrRecip
Entity jid j <- getBy404 $ UniqueProject prjRecip sid
return (jid, projectInbox j)
insertToProjectInbox ibid luCreate = do
let iidAuthor = remoteAuthorInstance author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
ibiid <- insert $ InboxItem False
new <- isRight <$> insertBy' (InboxItemRemote ibid ractid ibiid)
return $
if new
then Just ractid
else Nothing
getParent did (Left (shrParent, lmidParent)) = Left <$> getLocalParentMessageId did shrParent lmidParent
getParent did (Right p@(ObjURI hParent luParent)) = do
mrm <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance hParent
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid luParent
@ -269,17 +306,9 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
throwE "Remote parent belongs to a different discussion"
return mid
Nothing -> return $ Right p
return (sid, fsidProject, localTicketFollowers lt, jid, ibid, did, meparent)
insertToDiscussion luCreate luNote published ibid did meparent fsid = do
insertToDiscussion luNote published did meparent ractid = do
let iidAuthor = remoteAuthorInstance author
raidAuthor = remoteAuthorId author
roid <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luCreate)
ractid <- either entityKey id <$> insertBy' RemoteActivity
{ remoteActivityIdent = roid
, remoteActivityContent = persistJSONFromBL $ actbBL body
, remoteActivityReceived = now
}
mid <- insert Message
{ messageCreated = published
, messageSource = src
@ -290,11 +319,11 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
_ -> Nothing
, messageRoot = did
}
roid2 <-
roidNote <-
either entityKey id <$> insertBy' (RemoteObject iidAuthor luNote)
mrmid <- insertUnique RemoteMessage
{ remoteMessageAuthor = raidAuthor
, remoteMessageIdent = roid2
, remoteMessageIdent = roidNote
, remoteMessageRest = mid
, remoteMessageCreate = ractid
, remoteMessageLostParent =
@ -306,11 +335,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
Nothing -> do
delete mid
return Nothing
Just _ -> do
-- insertUnique_ $ RemoteFollow raidAuthor fsid False True
ibiid <- insert $ InboxItem False
insert_ $ InboxItemRemote ibid ractid ibiid
return $ Just (ractid, mid)
Just _ -> return $ Just mid
updateOrphans luNote did mid = do
let hAuthor = objUriAuthority $ remoteAuthorURI author
uNote = ObjURI hAuthor luNote
@ -341,32 +366,3 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
rm E.^. RemoteMessageLostParent E.==. E.just (E.val uNote) E.&&.
m E.^. MessageRoot `op` E.val did
return (rm E.^. RemoteMessageId, m E.^. MessageId)
deliverLocal
:: RemoteActivityId
-> [CreateNoteRecipColl]
-> SharerId
-> FollowerSetId
-> FollowerSetId
-> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)]
deliverLocal ractid recips sid fsidProject fsidTicket = do
(teamPids, teamRemotes) <-
if CreateNoteRecipTicketTeam `elem` recips
then getTicketTeam sid
else return ([], [])
(tfsPids, tfsRemotes) <-
if CreateNoteRecipTicketParticipants `elem` recips
then getFollowers fsidTicket
else return ([], [])
(jfsPids, jfsRemotes) <-
if CreateNoteRecipProjectFollowers `elem` recips
then getFollowers fsidProject
else return ([], [])
let pids = union teamPids tfsPids `union` jfsPids
remotes = teamRemotes `unionRemotes` tfsRemotes `unionRemotes` jfsRemotes
for_ pids $ \ pid -> do
ibid <- personInbox <$> getJust pid
ibiid <- insert $ InboxItem True
mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid
when (isNothing mibrid) $
delete ibiid
return remotes