sup39/vervis
1
0
Fork 0
mirror of https://code.sup39.dev/repos/Wqawg synced 2024-12-29 01:04:52 +09:00
Code Issues Activity

In audience parsing, provide version without bcc & list hosts for inbox fwding

Browse source
This commit is contained in:
fr33domlover 2020-07-12 11:17:12 +00:00
parent 2a6bba89d5
commit 90086f1329
7 changed files with 178 additions and 156 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

68
src/Vervis/API.hs
View file

@ -160,7 +160,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
let shrUser = sharerIdent sharerUser let shrUser = sharerIdent sharerUser
noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note
verifyNothingE muTarget "Create Note has 'target'" verifyNothingE muTarget "Create Note has 'target'"
(localRecips, remoteRecips) <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Create Note with no recipients" fromMaybeE mrecips "Create Note with no recipients"
checkFederation remoteRecips checkFederation remoteRecips
@ -170,7 +170,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
(mproject, did, meparent) <- getTopicAndParent context mparent (mproject, did, meparent) <- getTopicAndParent context mparent
lmid <- lift $ insertMessage now content source obiidCreate did meparent lmid <- lift $ insertMessage now content source obiidCreate did meparent
docCreate <- lift $ insertCreateToOutbox now shrUser noteData obiidCreate lmid docCreate <- lift $ insertCreateToOutbox now shrUser blinded noteData obiidCreate lmid
remoteRecipsHttpCreate <- do remoteRecipsHttpCreate <- do
hashLT <- getEncodeKeyHashid hashLT <- getEncodeKeyHashid
hashTAL <- getEncodeKeyHashid hashTAL <- getEncodeKeyHashid
@ -224,9 +224,9 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
localRecipSieve' sieve True False localRecips localRecipSieve' sieve True False localRecips
checkFederation moreRemoteRecips checkFederation moreRemoteRecips
lift $ deliverRemoteDB' (objUriAuthority uContext) obiidCreate remoteRecips moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate) return (lmid, obiidCreate, docCreate, remoteRecipsHttpCreate)
lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp (objUriAuthority uContext) obiid doc remotesHttp lift $ forkWorker "createNoteC: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiid doc remotesHttp
return obiid return obiid
where where
checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do checkNote shrUser (Note mluNote luAttrib _aud muParent muContext mpublished source content) = do
@ -453,7 +453,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
Just (Right uParent) -> Just uParent Just (Right uParent) -> Just uParent
_ -> Nothing _ -> Nothing
} }
insertCreateToOutbox now shrUser (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do insertCreateToOutbox now shrUser blinded (muParent, _mparent, uContext, _context, source, content) obiidCreate lmid = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
obikhid <- encodeKeyHashid obiidCreate obikhid <- encodeKeyHashid obiidCreate
@ -463,7 +463,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid { activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
, activityActor = luAttrib , activityActor = luAttrib
, activitySummary = summary , activitySummary = summary
, activityAudience = audience , activityAudience = blinded
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = CreateNote Note { createObject = CreateNote Note
{ noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid { noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
@ -510,7 +510,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
let shrUser = sharerIdent sharerUser let shrUser = sharerIdent sharerUser
ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
context <- parseTicketContext uContext context <- parseTicketContext uContext
(localRecips, remoteRecips) <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Create Ticket with no recipients" fromMaybeE mrecips "Create Ticket with no recipients"
checkFederation remoteRecips checkFederation remoteRecips
@ -521,7 +521,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
project <- prepareProject now tracker project <- prepareProject now tracker
talid <- lift $ insertTicket now pidUser title desc source obiidCreate project talid <- lift $ insertTicket now pidUser title desc source obiidCreate project
docCreate <- lift $ insertCreateToOutbox shrUser ticketData now obiidCreate talid docCreate <- lift $ insertCreateToOutbox shrUser blinded ticketData now obiidCreate talid
remoteRecipsHttpCreate <- do remoteRecipsHttpCreate <- do
let sieve = let sieve =
case tracker of case tracker of
@ -539,7 +539,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
[LocalPersonCollectionSharerFollowers shrUser] [LocalPersonCollectionSharerFollowers shrUser]
moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips
checkFederation moreRemoteRecips checkFederation moreRemoteRecips
lift $ deliverRemoteDB' (objUriAuthority uTarget) obiidCreate remoteRecips moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
maccept <- maccept <-
case project of case project of
Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do Left proj@(shr, Entity _ j, obiidAccept) -> Just <$> do
@ -555,13 +555,13 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC doc <- lift $ insertAcceptToOutbox proj shrUser obiidCreate talid recipsA recipsC
recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC
checkFederation recips checkFederation recips
lift $ (obiidAccept,doc,) <$> deliverRemoteDB' dont obiidAccept [] recips lift $ (obiidAccept,doc,) <$> deliverRemoteDB'' [] obiidAccept [] recips
Right _ -> return Nothing Right _ -> return Nothing
return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept) return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept)
lift $ do lift $ do
forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidCreate docCreate remotesHttpCreate forkWorker "createTicketC: async HTTP Create delivery" $ deliverRemoteHttp' fwdHosts obiidCreate docCreate remotesHttpCreate
for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) -> for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
return obiidCreate return obiidCreate
where where
checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do checkTicket shr (AP.Ticket mlocal luAttrib mpublished mupdated mcontext summary content source massigned resolved mmr) mtarget = do
@ -665,7 +665,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
} }
return talid return talid
insertCreateToOutbox shrUser (uContext, title, desc, source, uTarget) now obiidCreate talid = do insertCreateToOutbox shrUser blinded (uContext, title, desc, source, uTarget) now obiidCreate talid = do
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
talkhid <- encodeKeyHashid talid talkhid <- encodeKeyHashid talid
@ -684,7 +684,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid { activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
, activityActor = luAttrib , activityActor = luAttrib
, activitySummary = summary , activitySummary = summary
, activityAudience = audience , activityAudience = blinded
, activitySpecific = CreateActivity Create , activitySpecific = CreateActivity Create
{ createObject = CreateTicket AP.Ticket { createObject = CreateTicket AP.Ticket
{ AP.ticketLocal = Just (hLocal, tlocal) { AP.ticketLocal = Just (hLocal, tlocal)
@ -742,8 +742,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept] update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
return accept return accept
dont = Authority "dont-do.any-forwarding" Nothing
data Followee data Followee
= FolloweeSharer ShrIdent = FolloweeSharer ShrIdent
| FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal) | FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)
@ -760,7 +758,7 @@ followC
-> AP.Follow URIMode -> AP.Follow URIMode
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
(localRecips, remoteRecips) <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Follow with no recipients" fromMaybeE mrecips "Follow with no recipients"
federation <- asksSite $ appFederation . appSettings federation <- asksSite $ appFederation . appSettings
@ -791,12 +789,11 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
unless (null localRecips) $ unless (null localRecips) $
throwE "Follow object is remote but local recips listed" throwE "Follow object is remote but local recips listed"
return Nothing return Nothing
let dont = Authority "dont-do.any-forwarding" Nothing
(obiidFollow, doc, remotesHttp) <- runDBExcept $ do (obiidFollow, doc, remotesHttp) <- runDBExcept $ do
Entity pidAuthor personAuthor <- lift $ getAuthor shrUser Entity pidAuthor personAuthor <- lift $ getAuthor shrUser
let ibidAuthor = personInbox personAuthor let ibidAuthor = personInbox personAuthor
obidAuthor = personOutbox personAuthor obidAuthor = personOutbox personAuthor
(obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor (obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor blinded
case mfollowee of case mfollowee of
Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow
Just (followee, actorRecip) -> do Just (followee, actorRecip) -> do
@ -804,9 +801,9 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
obiidAccept <- lift $ insertAcceptToOutbox luFollow actorRecip obidRecip obiidAccept <- lift $ insertAcceptToOutbox luFollow actorRecip obidRecip
deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip
lift $ deliverAcceptLocal obiidAccept ibidAuthor lift $ deliverAcceptLocal obiidAccept ibidAuthor
remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips [] remotesHttp <- lift $ deliverRemoteDB'' fwdHosts obiidFollow remoteRecips []
return (obiidFollow, doc, remotesHttp) return (obiidFollow, doc, remotesHttp)
lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidFollow doc remotesHttp lift $ forkWorker "Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidFollow doc remotesHttp
return obiidFollow return obiidFollow
where where
parseFollowee (SharerR shr) = Just $ FolloweeSharer shr parseFollowee (SharerR shr) = Just $ FolloweeSharer shr
@ -885,14 +882,14 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
fromMaybeE mticket "Follow object: No such repo-patch in DB" fromMaybeE mticket "Follow object: No such repo-patch in DB"
return (localTicketFollowers lt, repoInbox r, False, repoOutbox r) return (localTicketFollowers lt, repoInbox r, False, repoOutbox r)
insertFollowToOutbox obid = do insertFollowToOutbox obid blinded = do
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let activity mluAct = Doc hLocal Activity let activity mluAct = Doc hLocal Activity
{ activityId = mluAct { activityId = mluAct
, activityActor = encodeRouteLocal $ SharerR shrUser , activityActor = encodeRouteLocal $ SharerR shrUser
, activitySummary = summary , activitySummary = summary
, activityAudience = audience , activityAudience = blinded
, activitySpecific = FollowActivity follow , activitySpecific = FollowActivity follow
} }
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
@ -972,7 +969,7 @@ offerTicketC
offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do
let shrUser = sharerIdent sharerUser let shrUser = sharerIdent sharerUser
(title, desc, source, target) <- checkTicket shrUser ticket uTarget (title, desc, source, target) <- checkTicket shrUser ticket uTarget
(localRecips, remoteRecips) <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Offer Ticket with no recipients" fromMaybeE mrecips "Offer Ticket with no recipients"
federation <- asksSite $ appFederation . appSettings federation <- asksSite $ appFederation . appSettings
@ -990,7 +987,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
return (s, ej) return (s, ej)
fromMaybeE mproj "Offer target no such local project in DB" fromMaybeE mproj "Offer target no such local project in DB"
Right _ -> return Nothing Right _ -> return Nothing
(obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) (obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded
remotesHttpOffer <- do remotesHttpOffer <- do
let sieve = let sieve =
case target of case target of
@ -1016,7 +1013,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
(localRecipSieve sieve False localRecips) (localRecipSieve sieve False localRecips)
unless (federation || null moreRemoteRecips) $ unless (federation || null moreRemoteRecips) $
throwE "Federation disabled, but recipient collection remote members found" throwE "Federation disabled, but recipient collection remote members found"
lift $ deliverRemoteDB' (objUriAuthority uTarget) obiid remoteRecips moreRemoteRecips lift $ deliverRemoteDB'' fwdHosts obiid remoteRecips moreRemoteRecips
maccept <- lift $ for mproject $ \ (s, Entity jid j) -> do maccept <- lift $ for mproject $ \ (s, Entity jid j) -> do
let shrJ = sharerIdent s let shrJ = sharerIdent s
prj = projectIdent j prj = projectIdent j
@ -1033,7 +1030,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
(obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept (obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept
return (obiid, doc, remotesHttpOffer, maccept) return (obiid, doc, remotesHttpOffer, maccept)
lift $ do lift $ do
forkWorker "offerTicketC: async HTTP Offer delivery" $ deliverRemoteHttp (objUriAuthority uTarget) obiidOffer docOffer remotesHttpOffer forkWorker "offerTicketC: async HTTP Offer delivery" $ deliverRemoteHttp' fwdHosts obiidOffer docOffer remotesHttpOffer
for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) -> for_ maybeAccept $ \ (obiidAccept, docAccept, remotesHttpAccept) ->
forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
return obiidOffer return obiidOffer
@ -1071,7 +1068,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
RepoR _ _ -> throwE "Offering patch to repo not implemented yet" RepoR _ _ -> throwE "Offering patch to repo not implemented yet"
_ -> throwE "Offer target is local but isn't a project/repo route" _ -> throwE "Offer target is local but isn't a project/repo route"
else return $ Right u else return $ Right u
insertOfferToOutbox shrUser now obid = do insertOfferToOutbox shrUser now obid blinded = do
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
obiid <- insertEmptyOutboxItem obid now obiid <- insertEmptyOutboxItem obid now
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
@ -1081,7 +1078,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
{ activityId = Just luAct { activityId = Just luAct
, activityActor = encodeRouteLocal $ SharerR shrUser , activityActor = encodeRouteLocal $ SharerR shrUser
, activitySummary = summary , activitySummary = summary
, activityAudience = audience , activityAudience = blinded
, activitySpecific = , activitySpecific =
OfferActivity $ Offer (OfferTicket ticket) uTarget OfferActivity $ Offer (OfferTicket ticket) uTarget
} }
@ -1162,7 +1159,7 @@ undoC
-> Undo URIMode -> Undo URIMode
-> ExceptT Text Handler OutboxItemId -> ExceptT Text Handler OutboxItemId
undoC shrUser summary audience undo@(Undo luObject) = do undoC shrUser summary audience undo@(Undo luObject) = do
(localRecips, remoteRecips) <- do ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
mrecips <- parseAudience audience mrecips <- parseAudience audience
fromMaybeE mrecips "Follow with no recipients" fromMaybeE mrecips "Follow with no recipients"
federation <- asksSite $ appFederation . appSettings federation <- asksSite $ appFederation . appSettings
@ -1177,7 +1174,6 @@ undoC shrUser summary audience undo@(Undo luObject) = do
| shr == shrUser -> | shr == shrUser ->
decodeKeyHashidE obikhid "Undo object invalid obikhid" decodeKeyHashidE obikhid "Undo object invalid obikhid"
_ -> throwE "Undo object isn't actor's outbox item route" _ -> throwE "Undo object isn't actor's outbox item route"
let dont = Authority "dont-do.any-forwarding" Nothing
(obiidUndo, doc, remotesHttp) <- runDBExcept $ do (obiidUndo, doc, remotesHttp) <- runDBExcept $ do
Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser
obi <- do obi <- do
@ -1190,13 +1186,13 @@ undoC shrUser summary audience undo@(Undo luObject) = do
deleteFollowRemote obiidOriginal deleteFollowRemote obiidOriginal
deleteFollowRemoteRequest obiidOriginal deleteFollowRemoteRequest obiidOriginal
let obidAuthor = personOutbox personAuthor let obidAuthor = personOutbox personAuthor
(obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor (obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor blinded
let ibidAuthor = personInbox personAuthor let ibidAuthor = personInbox personAuthor
fsidAuthor = personFollowers personAuthor fsidAuthor = personFollowers personAuthor
knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips
remotesHttp <- deliverRemoteDB' dont obiidUndo remoteRecips knownRemotes remotesHttp <- deliverRemoteDB'' fwdHosts obiidUndo remoteRecips knownRemotes
return (obiidUndo, doc, remotesHttp) return (obiidUndo, doc, remotesHttp)
lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp dont obiidUndo doc remotesHttp lift $ forkWorker "undoC: Outbox POST handler: async HTTP delivery" $ deliverRemoteHttp' fwdHosts obiidUndo doc remotesHttp
return obiidUndo return obiidUndo
where where
getAuthor shr = do getAuthor shr = do
@ -1211,14 +1207,14 @@ undoC shrUser summary audience undo@(Undo luObject) = do
deleteFollowRemoteRequest obiid = do deleteFollowRemoteRequest obiid = do
mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid
traverse_ delete mfrrid traverse_ delete mfrrid
insertUndoToOutbox obid = do insertUndoToOutbox obid blinded = do
hLocal <- asksSite siteInstanceHost hLocal <- asksSite siteInstanceHost
encodeRouteLocal <- getEncodeRouteLocal encodeRouteLocal <- getEncodeRouteLocal
let activity mluAct = Doc hLocal Activity let activity mluAct = Doc hLocal Activity
{ activityId = mluAct { activityId = mluAct
, activityActor = encodeRouteLocal $ SharerR shrUser , activityActor = encodeRouteLocal $ SharerR shrUser
, activitySummary = summary , activitySummary = summary
, activityAudience = audience , activityAudience = blinded
, activitySpecific = UndoActivity undo , activitySpecific = UndoActivity undo
} }
now <- liftIO getCurrentTime now <- liftIO getCurrentTime

26
src/Vervis/ActivityPub/Recipient.hs
View file

@ -30,6 +30,7 @@ module Vervis.ActivityPub.Recipient
, renderLocalActor , renderLocalActor
, renderLocalPersonCollection , renderLocalPersonCollection
, makeRecipientSet , makeRecipientSet
, ParsedAudience (..)
, parseAudience , parseAudience
, actorRecips , actorRecips
, localRecipSieve , localRecipSieve
@ -478,16 +479,35 @@ parseRecipients recips = do
Nothing -> Left route Nothing -> Left route
Just recip -> Right recip Just recip -> Right recip
data ParsedAudience u = ParsedAudience
{ paudLocalRecips :: LocalRecipientSet
, paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]
, paudBlinded :: Audience u
, paudFwdHosts :: [Authority u]
}
parseAudience parseAudience
:: (MonadSite m, SiteEnv m ~ App) :: (MonadSite m, SiteEnv m ~ App)
=> Audience URIMode => Audience URIMode
-> ExceptT Text m (Maybe (LocalRecipientSet, [(Host, NonEmpty LocalURI)])) -> ExceptT Text m (Maybe (ParsedAudience URIMode))
parseAudience audience = do parseAudience audience = do
let recips = concatRecipients audience let recips = concatRecipients audience
for (nonEmpty recips) $ \ recipsNE -> do for (nonEmpty recips) $ \ recipsNE -> do
(localsSet, remotes) <- parseRecipients recipsNE (localsSet, remotes) <- parseRecipients recipsNE
return let remotesGrouped =
(localsSet, groupByHost $ remotes \\ audienceNonActors audience) groupByHost $ remotes \\ audienceNonActors audience
hosts = map fst remotesGrouped
return ParsedAudience
{ paudLocalRecips = localsSet
, paudRemoteActors = remotesGrouped
, paudBlinded =
audience { audienceBto = [], audienceBcc = [] }
, paudFwdHosts =
let nonActorHosts =
LO.nubSort $
map objUriAuthority $ audienceNonActors audience
in LO.isect hosts nonActorHosts
}
where where
groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)] groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
groupByHost = groupAllExtract objUriAuthority objUriLocal groupByHost = groupAllExtract objUriAuthority objUriLocal

62
src/Vervis/Federation.hs
View file

@ -93,6 +93,7 @@ import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
import Vervis.ActivityPub import Vervis.ActivityPub
import Vervis.ActivityPub.Recipient
import Vervis.ActorKey import Vervis.ActorKey
import Vervis.Federation.Auth import Vervis.Federation.Auth
import Vervis.Federation.Discussion import Vervis.Federation.Discussion
@ -262,32 +263,39 @@ handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalRepo ridAut
"Activity already exists in inbox of /s/" <> recip "Activity already exists in inbox of /s/" <> recip
Just _ -> Just _ ->
return $ "Activity inserted to inbox of /s/" <> recip return $ "Activity inserted to inbox of /s/" <> recip
handleSharerInbox shrRecip now (ActivityAuthRemote author) body = handleSharerInbox shrRecip now (ActivityAuthRemote author) body = do
luActivity <-
fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
localRecips <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
msig <- checkForward $ LocalActorSharer shrRecip
let mfwd = (localRecips,) <$> msig
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
AcceptActivity accept -> AcceptActivity accept ->
(,Nothing) <$> sharerAcceptF shrRecip now author body accept (,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote note ->
(,Nothing) <$> sharerCreateNoteF now shrRecip author body note (,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note
CreateTicket ticket -> CreateTicket ticket ->
(,Nothing) <$> sharerCreateTicketF now shrRecip author body ticket mtarget (,Nothing) <$> sharerCreateTicketF now shrRecip author body mfwd luActivity ticket mtarget
_ -> return ("Unsupported create object type for sharers", Nothing) _ -> return ("Unsupported create object type for sharers", Nothing)
FollowActivity follow -> FollowActivity follow ->
(,Nothing) <$> sharerFollowF shrRecip now author body follow (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
OfferActivity (Offer obj target) -> OfferActivity (Offer obj target) ->
case obj of case obj of
OfferTicket ticket -> OfferTicket ticket ->
(,Nothing) <$> sharerOfferTicketF now shrRecip author body ticket target (,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target
OfferDep dep -> OfferDep dep ->
sharerOfferDepF now shrRecip author body dep target sharerOfferDepF now shrRecip author body mfwd luActivity dep target
_ -> return ("Unsupported offer object type for sharers", Nothing) _ -> return ("Unsupported offer object type for sharers", Nothing)
PushActivity push -> PushActivity push ->
(,Nothing) <$> sharerPushF shrRecip now author body push (,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push
RejectActivity reject -> RejectActivity reject ->
(,Nothing) <$> sharerRejectF shrRecip now author body reject (,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
UndoActivity undo -> UndoActivity undo ->
(,Nothing) <$> sharerUndoF shrRecip now author body undo (,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo
_ -> return ("Unsupported activity type for sharers", Nothing) _ -> return ("Unsupported activity type for sharers", Nothing)
handleProjectInbox handleProjectInbox
@ -302,25 +310,32 @@ handleProjectInbox shrRecip prjRecip now auth body = do
case auth of case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local
ActivityAuthRemote ra -> return ra ActivityAuthRemote ra -> return ra
luActivity <-
fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
localRecips <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
msig <- checkForward $ LocalActorProject shrRecip prjRecip
let mfwd = (localRecips,) <$> msig
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote note ->
(,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body note (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note
CreateTicket ticket -> CreateTicket ticket ->
(,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body ticket mtarget (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket mtarget
_ -> error "Unsupported create object type for projects" _ -> error "Unsupported create object type for projects"
FollowActivity follow -> FollowActivity follow ->
(,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body follow (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
OfferActivity (Offer obj target) -> OfferActivity (Offer obj target) ->
case obj of case obj of
OfferTicket ticket -> OfferTicket ticket ->
(,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
OfferDep dep -> OfferDep dep ->
projectOfferDepF now shrRecip prjRecip remoteAuthor body dep target projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
_ -> return ("Unsupported offer object type for projects", Nothing) _ -> return ("Unsupported offer object type for projects", Nothing)
UndoActivity undo -> UndoActivity undo ->
(,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body undo (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
_ -> return ("Unsupported activity type for projects", Nothing) _ -> return ("Unsupported activity type for projects", Nothing)
where where
errorLocalForwarded (ActivityAuthLocalPerson pid) = errorLocalForwarded (ActivityAuthLocalPerson pid) =
@ -345,21 +360,28 @@ handleRepoInbox shrRecip rpRecip now auth body = do
case auth of case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local ActivityAuthLocal local -> throwE $ errorLocalForwarded local
ActivityAuthRemote ra -> return ra ActivityAuthRemote ra -> return ra
luActivity <-
fromMaybeE (activityId $ actbActivity body) "Activity without 'id'"
localRecips <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients"
msig <- checkForward $ LocalActorRepo shrRecip rpRecip
let mfwd = (localRecips,) <$> msig
case activitySpecific $ actbActivity body of case activitySpecific $ actbActivity body of
CreateActivity (Create obj mtarget) -> CreateActivity (Create obj mtarget) ->
case obj of case obj of
CreateNote note -> CreateNote note ->
(,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body note (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note
_ -> error "Unsupported create object type for repos" _ -> error "Unsupported create object type for repos"
FollowActivity follow -> FollowActivity follow ->
(,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body follow (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
OfferActivity (Offer obj target) -> OfferActivity (Offer obj target) ->
case obj of case obj of
OfferDep dep -> OfferDep dep ->
repoOfferDepF now shrRecip rpRecip remoteAuthor body dep target repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
_ -> return ("Unsupported offer object type for repos", Nothing) _ -> return ("Unsupported offer object type for repos", Nothing)
UndoActivity undo-> UndoActivity undo->
(,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body undo (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body mfwd luActivity undo
_ -> return ("Unsupported activity type for repos", Nothing) _ -> return ("Unsupported activity type for repos", Nothing)
where where
errorLocalForwarded (ActivityAuthLocalPerson pid) = errorLocalForwarded (ActivityAuthLocalPerson pid) =

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

@ -212,16 +212,12 @@ sharerCreateNoteF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Note URIMode -> Note URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerCreateNoteF now shrRecip author body note = do sharerCreateNoteF now shrRecip author body mfwd luCreate note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(luNote, published, context, mparent, source, content) <- checkNote note (luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward $ LocalActorSharer shrRecip
case context of case context of
Right uContext -> runDBExcept $ do Right uContext -> runDBExcept $ do
personRecip <- lift $ do personRecip <- lift $ do
@ -261,10 +257,10 @@ sharerCreateNoteF now shrRecip author body note = do
Nothing -> return $ Left "I already have this comment, just storing in inbox" Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do Just mid -> lift $ do
updateOrphans author luNote did mid updateOrphans author luNote did mid
case msig of case mfwd of
Nothing -> Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header" return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
Just sig -> Right <$> do Just (localRecips, sig) -> Right <$> do
talkhid <- encodeKeyHashid talid talkhid <- encodeKeyHashid talid
let sieve = let sieve =
makeRecipientSet makeRecipientSet
@ -349,16 +345,12 @@ projectCreateNoteF
-> PrjIdent -> PrjIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Note URIMode -> Note URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectCreateNoteF now shrRecip prjRecip author body note = do projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(luNote, published, context, mparent, source, content) <- checkNote note (luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward $ LocalActorProject shrRecip prjRecip
case context of case context of
Right _ -> return "Not using; context isn't local" Right _ -> return "Not using; context isn't local"
Left (NoteContextSharerTicket shr talid False) -> do Left (NoteContextSharerTicket shr talid False) -> do
@ -374,14 +366,14 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
case mractid of case mractid of
Nothing -> return $ Left "Activity already in my inbox" Nothing -> return $ Left "Activity already in my inbox"
Just ractid -> Just ractid ->
case msig of case mfwd of
Nothing -> Nothing ->
return $ Left return $ Left
"Context is a sharer-ticket, \ "Context is a sharer-ticket, \
\but no inbox forwarding \ \but no inbox forwarding \
\header for me, so doing \ \header for me, so doing \
\nothing, just storing in inbox" \nothing, just storing in inbox"
Just sig -> lift $ Right <$> do Just (localRecips, sig) -> lift $ Right <$> do
let sieve = let sieve =
makeRecipientSet makeRecipientSet
[] []
@ -416,10 +408,10 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
Nothing -> return $ Left "I already have this comment, just storing in inbox" Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do Just mid -> lift $ do
updateOrphans author luNote did mid updateOrphans author luNote did mid
case msig of case mfwd of
Nothing -> Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header" return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
Just sig -> Right <$> do Just (localRecips, sig) -> Right <$> do
ltkhid <- encodeKeyHashid ltid ltkhid <- encodeKeyHashid ltid
let sieve = let sieve =
makeRecipientSet makeRecipientSet
@ -450,16 +442,12 @@ repoCreateNoteF
-> RpIdent -> RpIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Note URIMode -> Note URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
repoCreateNoteF now shrRecip rpRecip author body note = do repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(luNote, published, context, mparent, source, content) <- checkNote note (luNote, published, context, mparent, source, content) <- checkNote note
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Create Note with no recipients"
msig <- checkForward $ LocalActorRepo shrRecip rpRecip
case context of case context of
Right _ -> return "Not using; context isn't local" Right _ -> return "Not using; context isn't local"
Left (NoteContextSharerTicket _ _ False) -> Left (NoteContextSharerTicket _ _ False) ->
@ -477,14 +465,14 @@ repoCreateNoteF now shrRecip rpRecip author body note = do
case mractid of case mractid of
Nothing -> return $ Left "Activity already in my inbox" Nothing -> return $ Left "Activity already in my inbox"
Just ractid -> Just ractid ->
case msig of case mfwd of
Nothing -> Nothing ->
return $ Left return $ Left
"Context is a sharer-patch, \ "Context is a sharer-patch, \
\but no inbox forwarding \ \but no inbox forwarding \
\header for me, so doing \ \header for me, so doing \
\nothing, just storing in inbox" \nothing, just storing in inbox"
Just sig -> lift $ Right <$> do Just (localRecips, sig) -> lift $ Right <$> do
let sieve = let sieve =
makeRecipientSet makeRecipientSet
[] []
@ -520,10 +508,10 @@ repoCreateNoteF now shrRecip rpRecip author body note = do
Nothing -> return $ Left "I already have this comment, just storing in inbox" Nothing -> return $ Left "I already have this comment, just storing in inbox"
Just mid -> lift $ do Just mid -> lift $ do
updateOrphans author luNote did mid updateOrphans author luNote did mid
case msig of case mfwd of
Nothing -> Nothing ->
return $ Left "Storing in inbox, caching comment, no inbox forwarding header" return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
Just sig -> Right <$> do Just (localRecips, sig) -> Right <$> do
ltkhid <- encodeKeyHashid ltid ltkhid <- encodeKeyHashid ltid
let sieve = let sieve =
makeRecipientSet makeRecipientSet

53
src/Vervis/Federation/Offer.hs
View file

@ -38,6 +38,7 @@ import Control.Monad.Trans.Maybe
import Data.Aeson import Data.Aeson
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
import Data.List (nub, union) import Data.List (nub, union)
@ -91,15 +92,11 @@ sharerAcceptF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Accept URIMode -> Accept URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) mresult) = do sharerAcceptF shr now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) mresult) = do
luAccept <-
fromMaybeE (activityId $ actbActivity body) "Accept without 'id'"
(localRecips, _) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Accept with no recipients"
msig <- checkForward $ LocalActorSharer shr
mres <- lift $ runDB $ do mres <- lift $ runDB $ do
Entity pidRecip recip <- do Entity pidRecip recip <- do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
@ -109,9 +106,9 @@ sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) mresult) = do
mv <- runMaybeT $ asum mv <- runMaybeT $ asum
[ insertFollow pidRecip (personOutbox recip) ractid [ insertFollow pidRecip (personOutbox recip) ractid
, updateTicket pidRecip (personOutbox recip) ractid , updateTicket pidRecip (personOutbox recip) ractid
, insertDep msig (personInbox recip) ractid , insertDep mfwd (personInbox recip) ractid
] ]
for mv $ bitraverse pure $ traverse $ \ (sig, collections) -> do for mv $ bitraverse pure $ traverse $ \ ((localRecips, sig), collections) -> do
let sieve = makeRecipientSet [] collections let sieve = makeRecipientSet [] collections
remoteRecips <- remoteRecips <-
insertRemoteActivityToLocalInboxes insertRemoteActivityToLocalInboxes
@ -239,11 +236,11 @@ sharerRejectF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Reject URIMode -> Reject URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do sharerRejectF shr now author body mfwd luReject (Reject (ObjURI hOffer luOffer)) = do
luReject <-
fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
lift $ runDB $ do lift $ runDB $ do
Entity pidRecip recip <- do Entity pidRecip recip <- do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr
@ -291,11 +288,13 @@ followF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
followF followF
objRoute recipRoute getRecip recipInbox recipOutbox recipFollowers outboxItemRoute objRoute recipRoute getRecip recipInbox recipOutbox recipFollowers outboxItemRoute
now author body (AP.Follow (ObjURI hObj luObj) _mcontext hide) = do now author body mfwd luFollow (AP.Follow (ObjURI hObj luObj) _mcontext hide) = do
mobj <- do mobj <- do
local <- hostIsLocal hObj local <- hostIsLocal hObj
return $ return $
@ -305,10 +304,6 @@ followF
case mobj of case mobj of
Nothing -> return "Follow object unrelated to me, ignoring activity" Nothing -> return "Follow object unrelated to me, ignoring activity"
Just obj -> do Just obj -> do
luFollow <-
fromMaybeE
(activityId $ actbActivity body)
"Follow without 'id'"
emsg <- lift $ runDB $ do emsg <- lift $ runDB $ do
mrecip <- getRecip obj mrecip <- getRecip obj
case mrecip of case mrecip of
@ -333,7 +328,7 @@ followF
iidAuthor = remoteAuthorInstance author iidAuthor = remoteAuthorInstance author
hAuthor = objUriAuthority $ remoteAuthorURI author hAuthor = objUriAuthority $ remoteAuthorURI author
hostSection = ((iidAuthor, hAuthor), raInfo :| []) hostSection = ((iidAuthor, hAuthor), raInfo :| [])
(obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection] (obiid, doc,) <$> deliverRemoteDB'' [] obiid [] [hostSection]
else do else do
delete obiid delete obiid
return $ Left "You're already a follower of me" return $ Left "You're already a follower of me"
@ -341,11 +336,9 @@ followF
Left msg -> return msg Left msg -> return msg
Right (obiid, doc, remotesHttp) -> do Right (obiid, doc, remotesHttp) -> do
forkWorker "followF: Accept delivery" $ forkWorker "followF: Accept delivery" $
deliverRemoteHttp dont obiid doc remotesHttp deliverRemoteHttp' [] obiid doc remotesHttp
return "Follow request accepted" return "Follow request accepted"
where where
dont = Authority "dont-do.any-forwarding" Nothing
insertToInbox luFollow ibidRecip = do insertToInbox luFollow ibidRecip = do
let iidAuthor = remoteAuthorInstance author let iidAuthor = remoteAuthorInstance author
roid <- roid <-
@ -413,6 +406,8 @@ sharerFollowF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerFollowF shr = sharerFollowF shr =
@ -460,6 +455,8 @@ projectFollowF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectFollowF shr prj = projectFollowF shr prj =
@ -500,6 +497,8 @@ repoFollowF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Follow URIMode -> AP.Follow URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
repoFollowF shr rp = repoFollowF shr rp =
@ -543,13 +542,13 @@ undoF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Undo URIMode -> Undo URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
undoF undoF
recipRoute getRecip recipInbox recipFollowers trySubObjects recipRoute getRecip recipInbox recipFollowers trySubObjects
now author body (Undo luObj) = do now author body mfwd luUndo (Undo luObj) = do
luUndo <-
fromMaybeE (activityId $ actbActivity body) "Undo without 'id'"
lift $ runDB $ do lift $ runDB $ do
Entity idRecip recip <- getRecip Entity idRecip recip <- getRecip
ractid <- insertActivity luUndo ractid <- insertActivity luUndo
@ -607,6 +606,8 @@ sharerUndoF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Undo URIMode -> Undo URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerUndoF shr = sharerUndoF shr =
@ -642,6 +643,8 @@ projectUndoF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Undo URIMode -> Undo URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectUndoF shr prj = projectUndoF shr prj =
@ -680,6 +683,8 @@ repoUndoF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Undo URIMode -> Undo URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
repoUndoF shr rp = repoUndoF shr rp =

10
src/Vervis/Federation/Push.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis. {- This file is part of Vervis.
- -
- Written in 2019 by fr33domlover <fr33domlover@riseup.net>. - Written in 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- -
- ♡ Copying is an act of love. Please copy, reuse and share. - ♡ Copying is an act of love. Please copy, reuse and share.
- -
@ -26,6 +26,7 @@ import Control.Monad.Trans.Except
--import Control.Monad.Trans.Maybe --import Control.Monad.Trans.Maybe
--import Data.Aeson --import Data.Aeson
--import Data.Bifunctor --import Data.Bifunctor
import Data.ByteString (ByteString)
--import Data.Foldable --import Data.Foldable
--import Data.Function --import Data.Function
--import Data.List (nub, union) --import Data.List (nub, union)
@ -60,7 +61,7 @@ import Control.Monad.Trans.Except.Local
import Database.Persist.Local import Database.Persist.Local
import Yesod.Persist.Local import Yesod.Persist.Local
--import Vervis.ActivityPub import Vervis.ActivityPub.Recipient
import Vervis.FedURI import Vervis.FedURI
import Vervis.Federation.Auth import Vervis.Federation.Auth
import Vervis.Foundation import Vervis.Foundation
@ -72,10 +73,11 @@ sharerPushF
-> UTCTime -> UTCTime
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> Push URIMode -> Push URIMode
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerPushF shr now author body push = do sharerPushF shr now author body mfwd luPush push = do
luPush <- fromMaybeE (activityId $ actbActivity body) "Push without 'id'"
lift $ runDB $ do lift $ runDB $ do
Entity pidRecip recip <- do Entity pidRecip recip <- do
sid <- getKeyBy404 $ UniqueSharer shr sid <- getKeyBy404 $ UniqueSharer shr

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

@ -36,6 +36,7 @@ import Control.Monad.Trans.Reader
import Data.Aeson import Data.Aeson
import Data.Bifunctor import Data.Bifunctor
import Data.Bitraversable import Data.Bitraversable
import Data.ByteString (ByteString)
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
import Data.List (nub, union) import Data.List (nub, union)
@ -105,12 +106,13 @@ sharerOfferTicketF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerOfferTicketF now shrRecip author body ticket uTarget = do sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do
(hProject, shrProject, prjProject) <- parseTarget uTarget (hProject, shrProject, prjProject) <- parseTarget uTarget
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
{-deps <- -} {-deps <- -}
checkOffer ticket hProject shrProject prjProject checkOffer ticket hProject shrProject prjProject
local <- hostIsLocal hProject local <- hostIsLocal hProject
@ -203,11 +205,13 @@ projectOfferTicketF
-> PrjIdent -> PrjIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectOfferTicketF projectOfferTicketF
now shrRecip prjRecip author body ticket uTarget = do now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do
targetIsUs <- lift $ runExceptT checkTarget targetIsUs <- lift $ runExceptT checkTarget
case targetIsUs of case targetIsUs of
Left t -> do Left t -> do
@ -217,14 +221,9 @@ projectOfferTicketF
] ]
return t return t
Right () -> do Right () -> do
luOffer <-
fromMaybeE
(activityId $ actbActivity body)
"Offer without 'id'"
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
{-deps <- -} {-deps <- -}
checkOffer ticket hLocal shrRecip prjRecip checkOffer ticket hLocal shrRecip prjRecip
msig <- checkForward $ LocalActorProject shrRecip prjRecip
let colls = let colls =
findRelevantCollections shrRecip prjRecip hLocal $ findRelevantCollections shrRecip prjRecip hLocal $
activityAudience $ actbActivity body activityAudience $ actbActivity body
@ -236,7 +235,7 @@ projectOfferTicketF
ra <- getJust $ remoteAuthorId author ra <- getJust $ remoteAuthorId author
insertTicket ra luOffer jid ibid {-tids-} insertTicket ra luOffer jid ibid {-tids-}
for mticket $ \ (ractid, obiidAccept, docAccept) -> do for mticket $ \ (ractid, obiidAccept, docAccept) -> do
msr <- for msig $ \ sig -> do msr <- for mfwd $ \ (_, sig) -> do
remoteRecips <- deliverFwdLocal ractid colls sid fsid remoteRecips <- deliverFwdLocal ractid colls sid fsid
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
return (msr, obiidAccept, docAccept) return (msr, obiidAccept, docAccept)
@ -504,12 +503,12 @@ sharerCreateTicketF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> Maybe FedURI -> Maybe FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
sharerCreateTicketF now shrRecip author body ticket muTarget = do sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(targetAndContext, _, _) <- checkCreateTicket author ticket muTarget (targetAndContext, _, _) <- checkCreateTicket author ticket muTarget
runDBExcept $ do runDBExcept $ do
ibidRecip <- lift $ do ibidRecip <- lift $ do
@ -548,17 +547,16 @@ projectCreateTicketF
-> PrjIdent -> PrjIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.Ticket URIMode -> AP.Ticket URIMode
-> Maybe FedURI -> Maybe FedURI
-> ExceptT Text Handler Text -> ExceptT Text Handler Text
projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do
luCreate <-
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
(targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget (targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget
case targetAndContext of case targetAndContext of
Left (_, shrContext, prjContext) Left (_, shrContext, prjContext)
| shrRecip == shrContext && prjRecip == prjContext -> do | shrRecip == shrContext && prjRecip == prjContext -> do
msig <- checkForward $ LocalActorProject shrRecip prjRecip
msgOrRecips <- lift $ runDB $ do msgOrRecips <- lift $ runDB $ do
(sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
mractidCreate <- insertCreate luCreate ibidProject mractidCreate <- insertCreate luCreate ibidProject
@ -577,7 +575,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
Right () -> do Right () -> do
hLocal <- getsYesod siteInstanceHost hLocal <- getsYesod siteInstanceHost
let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
mremoteRecipsHttpCreateFwd <- for msig $ \ sig -> do mremoteRecipsHttpCreateFwd <- for mfwd $ \ (_, sig) -> do
remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
(sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
remoteRecipsHttpAccept <- do remoteRecipsHttpAccept <- do
@ -755,16 +753,13 @@ sharerOfferDepF
-> ShrIdent -> ShrIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.TicketDependency URIMode -> AP.TicketDependency URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
sharerOfferDepF now shrRecip author body dep uTarget = do sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
(parent, child) <- checkDepAndTarget dep uTarget (parent, child) <- checkDepAndTarget dep uTarget
(localRecips, _remoteRecips) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Offer Dep with no recipients"
msig <- checkForward $ LocalActorSharer shrRecip
personRecip <- lift $ runDB $ do personRecip <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getValBy404 $ UniquePersonIdent sid getValBy404 $ UniquePersonIdent sid
@ -825,7 +820,7 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True
for mractid $ \ (ractid, ibiid) -> do for mractid $ \ (ractid, ibiid) -> do
insertDepOffer ibiid parent child insertDepOffer ibiid parent child
mremotesHttpFwd <- lift $ for msig $ \ sig -> do mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
relevantFollowers <- askRelevantFollowers relevantFollowers <- askRelevantFollowers
let sieve = let sieve =
makeRecipientSet [] $ catMaybes makeRecipientSet [] $ catMaybes
@ -1178,16 +1173,13 @@ projectOfferDepF
-> PrjIdent -> PrjIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.TicketDependency URIMode -> AP.TicketDependency URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
projectOfferDepF now shrRecip prjRecip author body dep uTarget = do projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
(parent, child) <- checkDepAndTarget dep uTarget (parent, child) <- checkDepAndTarget dep uTarget
(localRecips, _) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Offer Dep with no recipients"
msig <- checkForward $ LocalActorProject shrRecip prjRecip
Entity jidRecip projectRecip <- lift $ runDB $ do Entity jidRecip projectRecip <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid getBy404 $ UniqueProject prjRecip sid
@ -1205,7 +1197,7 @@ projectOfferDepF now shrRecip prjRecip author body dep uTarget = do
mractid <- lift $ insertToInbox' now author body (projectInbox projectRecip) luOffer False mractid <- lift $ insertToInbox' now author body (projectInbox projectRecip) luOffer False
for mractid $ \ (ractid, ibiid) -> do for mractid $ \ (ractid, ibiid) -> do
insertDepOffer ibiid parent child insertDepOffer ibiid parent child
mremotesHttpFwd <- lift $ for msig $ \ sig -> do mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
relevantFollowers <- askRelevantFollowers relevantFollowers <- askRelevantFollowers
let rf = relevantFollowers shrRecip prjRecip let rf = relevantFollowers shrRecip prjRecip
sieve = sieve =
@ -1342,16 +1334,13 @@ repoOfferDepF
-> RpIdent -> RpIdent
-> RemoteAuthor -> RemoteAuthor
-> ActivityBody -> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> LocalURI
-> AP.TicketDependency URIMode -> AP.TicketDependency URIMode
-> FedURI -> FedURI
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
repoOfferDepF now shrRecip rpRecip author body dep uTarget = do repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
(parent, child) <- checkDepAndTarget dep uTarget (parent, child) <- checkDepAndTarget dep uTarget
(localRecips, _) <- do
mrecips <- parseAudience $ activityAudience $ actbActivity body
fromMaybeE mrecips "Offer Dep with no recipients"
msig <- checkForward $ LocalActorRepo shrRecip rpRecip
Entity ridRecip repoRecip <- lift $ runDB $ do Entity ridRecip repoRecip <- lift $ runDB $ do
sid <- getKeyBy404 $ UniqueSharer shrRecip sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueRepo rpRecip sid getBy404 $ UniqueRepo rpRecip sid
@ -1369,7 +1358,7 @@ repoOfferDepF now shrRecip rpRecip author body dep uTarget = do
mractid <- lift $ insertToInbox' now author body (repoInbox repoRecip) luOffer False mractid <- lift $ insertToInbox' now author body (repoInbox repoRecip) luOffer False
for mractid $ \ (ractid, ibiid) -> do for mractid $ \ (ractid, ibiid) -> do
insertDepOffer ibiid parent child insertDepOffer ibiid parent child
mremotesHttpFwd <- lift $ for msig $ \ sig -> do mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
relevantFollowers <- askRelevantFollowers relevantFollowers <- askRelevantFollowers
let rf = relevantFollowers shrRecip rpRecip let rf = relevantFollowers shrRecip rpRecip
sieve = sieve =