In audience parsing, provide version without bcc & list hosts for inbox fwding
This commit is contained in:
parent
2a6bba89d5
commit
90086f1329
7 changed files with 178 additions and 156 deletions
|
@ -160,7 +160,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
|
|||
let shrUser = sharerIdent sharerUser
|
||||
noteData@(muParent, mparent, uContext, context, source, content) <- checkNote shrUser note
|
||||
verifyNothingE muTarget "Create Note has 'target'"
|
||||
(localRecips, remoteRecips) <- do
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Create Note with no recipients"
|
||||
checkFederation remoteRecips
|
||||
|
@ -170,7 +170,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
|
|||
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
|
||||
(mproject, did, meparent) <- getTopicAndParent context mparent
|
||||
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
|
||||
hashLT <- getEncodeKeyHashid
|
||||
hashTAL <- getEncodeKeyHashid
|
||||
|
@ -224,9 +224,9 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
|
|||
lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $
|
||||
localRecipSieve' sieve True False localRecips
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB' (objUriAuthority uContext) obiidCreate remoteRecips moreRemoteRecips
|
||||
lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
|
||||
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
|
||||
where
|
||||
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
|
||||
_ -> 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
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhid <- encodeKeyHashid obiidCreate
|
||||
|
@ -463,7 +463,7 @@ createNoteC (Entity pidUser personUser) sharerUser summary audience note muTarge
|
|||
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
, activityActor = luAttrib
|
||||
, activitySummary = summary
|
||||
, activityAudience = audience
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createObject = CreateNote Note
|
||||
{ noteId = Just $ encodeRouteLocal $ MessageR shrUser lmkhid
|
||||
|
@ -510,7 +510,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
let shrUser = sharerIdent sharerUser
|
||||
ticketData@(uContext, title, desc, source, uTarget) <- checkTicket shrUser ticket muTarget
|
||||
context <- parseTicketContext uContext
|
||||
(localRecips, remoteRecips) <- do
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Create Ticket with no recipients"
|
||||
checkFederation remoteRecips
|
||||
|
@ -521,7 +521,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
obiidCreate <- lift $ insertEmptyOutboxItem (personOutbox personUser) now
|
||||
project <- prepareProject now tracker
|
||||
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
|
||||
let sieve =
|
||||
case tracker of
|
||||
|
@ -539,7 +539,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
[LocalPersonCollectionSharerFollowers shrUser]
|
||||
moreRemoteRecips <- lift $ deliverLocal' True (LocalActorSharer shrUser) (personInbox personUser) obiidCreate $ localRecipSieve sieve False localRecips
|
||||
checkFederation moreRemoteRecips
|
||||
lift $ deliverRemoteDB' (objUriAuthority uTarget) obiidCreate remoteRecips moreRemoteRecips
|
||||
lift $ deliverRemoteDB'' fwdHosts obiidCreate remoteRecips moreRemoteRecips
|
||||
maccept <-
|
||||
case project of
|
||||
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
|
||||
recips <- lift $ deliverLocal' True (LocalActorProject shr prj) (projectInbox j) obiidAccept $ makeRecipientSet recipsA recipsC
|
||||
checkFederation recips
|
||||
lift $ (obiidAccept,doc,) <$> deliverRemoteDB' dont obiidAccept [] recips
|
||||
lift $ (obiidAccept,doc,) <$> deliverRemoteDB'' [] obiidAccept [] recips
|
||||
Right _ -> return Nothing
|
||||
return (talid, obiidCreate, docCreate, remoteRecipsHttpCreate, maccept)
|
||||
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) ->
|
||||
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp dont obiidAccept docAccept remotesHttpAccept
|
||||
forkWorker "createTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
|
||||
return obiidCreate
|
||||
where
|
||||
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
|
||||
|
||||
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
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
talkhid <- encodeKeyHashid talid
|
||||
|
@ -684,7 +684,7 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
{ activityId = Just $ encodeRouteLocal $ SharerOutboxItemR shrUser obikhid
|
||||
, activityActor = luAttrib
|
||||
, activitySummary = summary
|
||||
, activityAudience = audience
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = CreateActivity Create
|
||||
{ createObject = CreateTicket AP.Ticket
|
||||
{ AP.ticketLocal = Just (hLocal, tlocal)
|
||||
|
@ -742,8 +742,6 @@ createTicketC (Entity pidUser personUser) sharerUser summary audience ticket muT
|
|||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc accept]
|
||||
return accept
|
||||
|
||||
dont = Authority "dont-do.any-forwarding" Nothing
|
||||
|
||||
data Followee
|
||||
= FolloweeSharer ShrIdent
|
||||
| FolloweeSharerTicket ShrIdent (KeyHashid TicketAuthorLocal)
|
||||
|
@ -760,7 +758,7 @@ followC
|
|||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
|
||||
(localRecips, remoteRecips) <- do
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Follow with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
|
@ -791,12 +789,11 @@ followC shrUser summary audience follow@(AP.Follow uObject muContext hide) = do
|
|||
unless (null localRecips) $
|
||||
throwE "Follow object is remote but local recips listed"
|
||||
return Nothing
|
||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||
(obiidFollow, doc, remotesHttp) <- runDBExcept $ do
|
||||
Entity pidAuthor personAuthor <- lift $ getAuthor shrUser
|
||||
let ibidAuthor = personInbox personAuthor
|
||||
obidAuthor = personOutbox personAuthor
|
||||
(obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor
|
||||
(obiidFollow, doc, luFollow) <- lift $ insertFollowToOutbox obidAuthor blinded
|
||||
case mfollowee of
|
||||
Nothing -> lift $ insert_ $ FollowRemoteRequest pidAuthor uObject muContext (not hide) obiidFollow
|
||||
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
|
||||
deliverFollowLocal pidAuthor fsid unread obiidFollow obiidAccept ibidRecip
|
||||
lift $ deliverAcceptLocal obiidAccept ibidAuthor
|
||||
remotesHttp <- lift $ deliverRemoteDB' dont obiidFollow remoteRecips []
|
||||
remotesHttp <- lift $ deliverRemoteDB'' fwdHosts obiidFollow remoteRecips []
|
||||
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
|
||||
where
|
||||
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"
|
||||
return (localTicketFollowers lt, repoInbox r, False, repoOutbox r)
|
||||
|
||||
insertFollowToOutbox obid = do
|
||||
insertFollowToOutbox obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let activity mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary = summary
|
||||
, activityAudience = audience
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = FollowActivity follow
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
|
@ -972,7 +969,7 @@ offerTicketC
|
|||
offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTarget = do
|
||||
let shrUser = sharerIdent sharerUser
|
||||
(title, desc, source, target) <- checkTicket shrUser ticket uTarget
|
||||
(localRecips, remoteRecips) <- do
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Offer Ticket with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
|
@ -990,7 +987,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
return (s, ej)
|
||||
fromMaybeE mproj "Offer target no such local project in DB"
|
||||
Right _ -> return Nothing
|
||||
(obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser)
|
||||
(obiid, doc, luOffer) <- lift $ insertOfferToOutbox shrUser now (personOutbox personUser) blinded
|
||||
remotesHttpOffer <- do
|
||||
let sieve =
|
||||
case target of
|
||||
|
@ -1016,7 +1013,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
(localRecipSieve sieve False localRecips)
|
||||
unless (federation || null moreRemoteRecips) $
|
||||
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
|
||||
let shrJ = sharerIdent s
|
||||
prj = projectIdent j
|
||||
|
@ -1033,7 +1030,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
(obiidAccept,docAccept,) <$> deliverRemoteDB'' [] obiidAccept [] knownRemoteRecipsAccept
|
||||
return (obiid, doc, remotesHttpOffer, maccept)
|
||||
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) ->
|
||||
forkWorker "offerTicketC: async HTTP Accept delivery" $ deliverRemoteHttp' [] obiidAccept docAccept remotesHttpAccept
|
||||
return obiidOffer
|
||||
|
@ -1071,7 +1068,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
RepoR _ _ -> throwE "Offering patch to repo not implemented yet"
|
||||
_ -> throwE "Offer target is local but isn't a project/repo route"
|
||||
else return $ Right u
|
||||
insertOfferToOutbox shrUser now obid = do
|
||||
insertOfferToOutbox shrUser now obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obiid <- insertEmptyOutboxItem obid now
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
|
@ -1081,7 +1078,7 @@ offerTicketC (Entity pidUser personUser) sharerUser summary audience ticket uTar
|
|||
{ activityId = Just luAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary = summary
|
||||
, activityAudience = audience
|
||||
, activityAudience = blinded
|
||||
, activitySpecific =
|
||||
OfferActivity $ Offer (OfferTicket ticket) uTarget
|
||||
}
|
||||
|
@ -1162,7 +1159,7 @@ undoC
|
|||
-> Undo URIMode
|
||||
-> ExceptT Text Handler OutboxItemId
|
||||
undoC shrUser summary audience undo@(Undo luObject) = do
|
||||
(localRecips, remoteRecips) <- do
|
||||
ParsedAudience localRecips remoteRecips blinded fwdHosts <- do
|
||||
mrecips <- parseAudience audience
|
||||
fromMaybeE mrecips "Follow with no recipients"
|
||||
federation <- asksSite $ appFederation . appSettings
|
||||
|
@ -1177,7 +1174,6 @@ undoC shrUser summary audience undo@(Undo luObject) = do
|
|||
| shr == shrUser ->
|
||||
decodeKeyHashidE obikhid "Undo object invalid obikhid"
|
||||
_ -> throwE "Undo object isn't actor's outbox item route"
|
||||
let dont = Authority "dont-do.any-forwarding" Nothing
|
||||
(obiidUndo, doc, remotesHttp) <- runDBExcept $ do
|
||||
Entity _pidAuthor personAuthor <- lift $ getAuthor shrUser
|
||||
obi <- do
|
||||
|
@ -1190,13 +1186,13 @@ undoC shrUser summary audience undo@(Undo luObject) = do
|
|||
deleteFollowRemote obiidOriginal
|
||||
deleteFollowRemoteRequest obiidOriginal
|
||||
let obidAuthor = personOutbox personAuthor
|
||||
(obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor
|
||||
(obiidUndo, doc, luUndo) <- insertUndoToOutbox obidAuthor blinded
|
||||
let ibidAuthor = personInbox personAuthor
|
||||
fsidAuthor = personFollowers personAuthor
|
||||
knownRemotes <- deliverLocal shrUser ibidAuthor fsidAuthor obiidUndo localRecips
|
||||
remotesHttp <- deliverRemoteDB' dont obiidUndo remoteRecips knownRemotes
|
||||
remotesHttp <- deliverRemoteDB'' fwdHosts obiidUndo remoteRecips knownRemotes
|
||||
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
|
||||
where
|
||||
getAuthor shr = do
|
||||
|
@ -1211,14 +1207,14 @@ undoC shrUser summary audience undo@(Undo luObject) = do
|
|||
deleteFollowRemoteRequest obiid = do
|
||||
mfrrid <- getKeyBy $ UniqueFollowRemoteRequestActivity obiid
|
||||
traverse_ delete mfrrid
|
||||
insertUndoToOutbox obid = do
|
||||
insertUndoToOutbox obid blinded = do
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
let activity mluAct = Doc hLocal Activity
|
||||
{ activityId = mluAct
|
||||
, activityActor = encodeRouteLocal $ SharerR shrUser
|
||||
, activitySummary = summary
|
||||
, activityAudience = audience
|
||||
, activityAudience = blinded
|
||||
, activitySpecific = UndoActivity undo
|
||||
}
|
||||
now <- liftIO getCurrentTime
|
||||
|
|
|
@ -30,6 +30,7 @@ module Vervis.ActivityPub.Recipient
|
|||
, renderLocalActor
|
||||
, renderLocalPersonCollection
|
||||
, makeRecipientSet
|
||||
, ParsedAudience (..)
|
||||
, parseAudience
|
||||
, actorRecips
|
||||
, localRecipSieve
|
||||
|
@ -478,16 +479,35 @@ parseRecipients recips = do
|
|||
Nothing -> Left route
|
||||
Just recip -> Right recip
|
||||
|
||||
data ParsedAudience u = ParsedAudience
|
||||
{ paudLocalRecips :: LocalRecipientSet
|
||||
, paudRemoteActors :: [(Authority u, NonEmpty LocalURI)]
|
||||
, paudBlinded :: Audience u
|
||||
, paudFwdHosts :: [Authority u]
|
||||
}
|
||||
|
||||
parseAudience
|
||||
:: (MonadSite m, SiteEnv m ~ App)
|
||||
=> Audience URIMode
|
||||
-> ExceptT Text m (Maybe (LocalRecipientSet, [(Host, NonEmpty LocalURI)]))
|
||||
-> ExceptT Text m (Maybe (ParsedAudience URIMode))
|
||||
parseAudience audience = do
|
||||
let recips = concatRecipients audience
|
||||
for (nonEmpty recips) $ \ recipsNE -> do
|
||||
(localsSet, remotes) <- parseRecipients recipsNE
|
||||
return
|
||||
(localsSet, groupByHost $ remotes \\ audienceNonActors audience)
|
||||
let remotesGrouped =
|
||||
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
|
||||
groupByHost :: [FedURI] -> [(Host, NonEmpty LocalURI)]
|
||||
groupByHost = groupAllExtract objUriAuthority objUriLocal
|
||||
|
|
|
@ -93,6 +93,7 @@ import Database.Persist.Local
|
|||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.ActivityPub.Recipient
|
||||
import Vervis.ActorKey
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Federation.Discussion
|
||||
|
@ -262,32 +263,39 @@ handleSharerInbox shrRecip _now (ActivityAuthLocal (ActivityAuthLocalRepo ridAut
|
|||
"Activity already exists in inbox of /s/" <> recip
|
||||
Just _ ->
|
||||
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
|
||||
AcceptActivity accept ->
|
||||
(,Nothing) <$> sharerAcceptF shrRecip now author body accept
|
||||
(,Nothing) <$> sharerAcceptF shrRecip now author body mfwd luActivity accept
|
||||
CreateActivity (Create obj mtarget) ->
|
||||
case obj of
|
||||
CreateNote note ->
|
||||
(,Nothing) <$> sharerCreateNoteF now shrRecip author body note
|
||||
(,Nothing) <$> sharerCreateNoteF now shrRecip author body mfwd luActivity note
|
||||
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)
|
||||
FollowActivity follow ->
|
||||
(,Nothing) <$> sharerFollowF shrRecip now author body follow
|
||||
(,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow
|
||||
OfferActivity (Offer obj target) ->
|
||||
case obj of
|
||||
OfferTicket ticket ->
|
||||
(,Nothing) <$> sharerOfferTicketF now shrRecip author body ticket target
|
||||
(,Nothing) <$> sharerOfferTicketF now shrRecip author body mfwd luActivity ticket target
|
||||
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)
|
||||
PushActivity push ->
|
||||
(,Nothing) <$> sharerPushF shrRecip now author body push
|
||||
(,Nothing) <$> sharerPushF shrRecip now author body mfwd luActivity push
|
||||
RejectActivity reject ->
|
||||
(,Nothing) <$> sharerRejectF shrRecip now author body reject
|
||||
(,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
|
||||
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)
|
||||
|
||||
handleProjectInbox
|
||||
|
@ -302,25 +310,32 @@ handleProjectInbox shrRecip prjRecip now auth body = do
|
|||
case auth of
|
||||
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
|
||||
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
|
||||
CreateActivity (Create obj mtarget) ->
|
||||
case obj of
|
||||
CreateNote note ->
|
||||
(,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
|
||||
(,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body mfwd luActivity note
|
||||
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"
|
||||
FollowActivity follow ->
|
||||
(,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body follow
|
||||
(,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow
|
||||
OfferActivity (Offer obj target) ->
|
||||
case obj of
|
||||
OfferTicket ticket ->
|
||||
(,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
|
||||
(,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
|
||||
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)
|
||||
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)
|
||||
where
|
||||
errorLocalForwarded (ActivityAuthLocalPerson pid) =
|
||||
|
@ -345,21 +360,28 @@ handleRepoInbox shrRecip rpRecip now auth body = do
|
|||
case auth of
|
||||
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
|
||||
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
|
||||
CreateActivity (Create obj mtarget) ->
|
||||
case obj of
|
||||
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"
|
||||
FollowActivity follow ->
|
||||
(,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body follow
|
||||
(,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
|
||||
OfferActivity (Offer obj target) ->
|
||||
case obj of
|
||||
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)
|
||||
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)
|
||||
where
|
||||
errorLocalForwarded (ActivityAuthLocalPerson pid) =
|
||||
|
|
|
@ -212,16 +212,12 @@ sharerCreateNoteF
|
|||
-> ShrIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Note URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerCreateNoteF now shrRecip author body note = do
|
||||
luCreate <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
|
||||
sharerCreateNoteF now shrRecip author body mfwd luCreate note = do
|
||||
(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
|
||||
Right uContext -> runDBExcept $ 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"
|
||||
Just mid -> lift $ do
|
||||
updateOrphans author luNote did mid
|
||||
case msig of
|
||||
case mfwd of
|
||||
Nothing ->
|
||||
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
|
||||
Just sig -> Right <$> do
|
||||
Just (localRecips, sig) -> Right <$> do
|
||||
talkhid <- encodeKeyHashid talid
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
|
@ -349,16 +345,12 @@ projectCreateNoteF
|
|||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Note URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
projectCreateNoteF now shrRecip prjRecip author body note = do
|
||||
luCreate <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
|
||||
projectCreateNoteF now shrRecip prjRecip author body mfwd luCreate note = do
|
||||
(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
|
||||
Right _ -> return "Not using; context isn't local"
|
||||
Left (NoteContextSharerTicket shr talid False) -> do
|
||||
|
@ -374,14 +366,14 @@ projectCreateNoteF now shrRecip prjRecip author body note = do
|
|||
case mractid of
|
||||
Nothing -> return $ Left "Activity already in my inbox"
|
||||
Just ractid ->
|
||||
case msig of
|
||||
case mfwd 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
|
||||
Just (localRecips, sig) -> lift $ Right <$> do
|
||||
let sieve =
|
||||
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"
|
||||
Just mid -> lift $ do
|
||||
updateOrphans author luNote did mid
|
||||
case msig of
|
||||
case mfwd of
|
||||
Nothing ->
|
||||
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
|
||||
Just sig -> Right <$> do
|
||||
Just (localRecips, sig) -> Right <$> do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
|
@ -450,16 +442,12 @@ repoCreateNoteF
|
|||
-> RpIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Note URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
repoCreateNoteF now shrRecip rpRecip author body note = do
|
||||
luCreate <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
|
||||
repoCreateNoteF now shrRecip rpRecip author body mfwd luCreate note = do
|
||||
(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
|
||||
Right _ -> return "Not using; context isn't local"
|
||||
Left (NoteContextSharerTicket _ _ False) ->
|
||||
|
@ -477,14 +465,14 @@ repoCreateNoteF now shrRecip rpRecip author body note = do
|
|||
case mractid of
|
||||
Nothing -> return $ Left "Activity already in my inbox"
|
||||
Just ractid ->
|
||||
case msig of
|
||||
case mfwd of
|
||||
Nothing ->
|
||||
return $ Left
|
||||
"Context is a sharer-patch, \
|
||||
\but no inbox forwarding \
|
||||
\header for me, so doing \
|
||||
\nothing, just storing in inbox"
|
||||
Just sig -> lift $ Right <$> do
|
||||
Just (localRecips, sig) -> lift $ Right <$> do
|
||||
let sieve =
|
||||
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"
|
||||
Just mid -> lift $ do
|
||||
updateOrphans author luNote did mid
|
||||
case msig of
|
||||
case mfwd of
|
||||
Nothing ->
|
||||
return $ Left "Storing in inbox, caching comment, no inbox forwarding header"
|
||||
Just sig -> Right <$> do
|
||||
Just (localRecips, sig) -> Right <$> do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
|
|
|
@ -38,6 +38,7 @@ import Control.Monad.Trans.Maybe
|
|||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List (nub, union)
|
||||
|
@ -91,15 +92,11 @@ sharerAcceptF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Accept URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerAcceptF shr now author body (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
|
||||
sharerAcceptF shr now author body mfwd luAccept (Accept (ObjURI hOffer luOffer) mresult) = do
|
||||
mres <- lift $ runDB $ do
|
||||
Entity pidRecip recip <- do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
|
@ -109,9 +106,9 @@ sharerAcceptF shr now author body (Accept (ObjURI hOffer luOffer) mresult) = do
|
|||
mv <- runMaybeT $ asum
|
||||
[ insertFollow 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
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
|
@ -239,11 +236,11 @@ sharerRejectF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Reject URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerRejectF shr now author body (Reject (ObjURI hOffer luOffer)) = do
|
||||
luReject <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Reject without 'id'"
|
||||
sharerRejectF shr now author body mfwd luReject (Reject (ObjURI hOffer luOffer)) = do
|
||||
lift $ runDB $ do
|
||||
Entity pidRecip recip <- do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
|
@ -291,11 +288,13 @@ followF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
followF
|
||||
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
|
||||
local <- hostIsLocal hObj
|
||||
return $
|
||||
|
@ -305,10 +304,6 @@ followF
|
|||
case mobj of
|
||||
Nothing -> return "Follow object unrelated to me, ignoring activity"
|
||||
Just obj -> do
|
||||
luFollow <-
|
||||
fromMaybeE
|
||||
(activityId $ actbActivity body)
|
||||
"Follow without 'id'"
|
||||
emsg <- lift $ runDB $ do
|
||||
mrecip <- getRecip obj
|
||||
case mrecip of
|
||||
|
@ -333,7 +328,7 @@ followF
|
|||
iidAuthor = remoteAuthorInstance author
|
||||
hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
hostSection = ((iidAuthor, hAuthor), raInfo :| [])
|
||||
(obiid, doc,) <$> deliverRemoteDB' dont obiid [] [hostSection]
|
||||
(obiid, doc,) <$> deliverRemoteDB'' [] obiid [] [hostSection]
|
||||
else do
|
||||
delete obiid
|
||||
return $ Left "You're already a follower of me"
|
||||
|
@ -341,11 +336,9 @@ followF
|
|||
Left msg -> return msg
|
||||
Right (obiid, doc, remotesHttp) -> do
|
||||
forkWorker "followF: Accept delivery" $
|
||||
deliverRemoteHttp dont obiid doc remotesHttp
|
||||
deliverRemoteHttp' [] obiid doc remotesHttp
|
||||
return "Follow request accepted"
|
||||
where
|
||||
dont = Authority "dont-do.any-forwarding" Nothing
|
||||
|
||||
insertToInbox luFollow ibidRecip = do
|
||||
let iidAuthor = remoteAuthorInstance author
|
||||
roid <-
|
||||
|
@ -413,6 +406,8 @@ sharerFollowF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerFollowF shr =
|
||||
|
@ -460,6 +455,8 @@ projectFollowF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
projectFollowF shr prj =
|
||||
|
@ -500,6 +497,8 @@ repoFollowF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Follow URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
repoFollowF shr rp =
|
||||
|
@ -543,13 +542,13 @@ undoF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
undoF
|
||||
recipRoute getRecip recipInbox recipFollowers trySubObjects
|
||||
now author body (Undo luObj) = do
|
||||
luUndo <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Undo without 'id'"
|
||||
now author body mfwd luUndo (Undo luObj) = do
|
||||
lift $ runDB $ do
|
||||
Entity idRecip recip <- getRecip
|
||||
ractid <- insertActivity luUndo
|
||||
|
@ -607,6 +606,8 @@ sharerUndoF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerUndoF shr =
|
||||
|
@ -642,6 +643,8 @@ projectUndoF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
projectUndoF shr prj =
|
||||
|
@ -680,6 +683,8 @@ repoUndoF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
repoUndoF shr rp =
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
{- 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.
|
||||
-
|
||||
|
@ -26,6 +26,7 @@ import Control.Monad.Trans.Except
|
|||
--import Control.Monad.Trans.Maybe
|
||||
--import Data.Aeson
|
||||
--import Data.Bifunctor
|
||||
import Data.ByteString (ByteString)
|
||||
--import Data.Foldable
|
||||
--import Data.Function
|
||||
--import Data.List (nub, union)
|
||||
|
@ -60,7 +61,7 @@ import Control.Monad.Trans.Except.Local
|
|||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
--import Vervis.ActivityPub
|
||||
import Vervis.ActivityPub.Recipient
|
||||
import Vervis.FedURI
|
||||
import Vervis.Federation.Auth
|
||||
import Vervis.Foundation
|
||||
|
@ -72,10 +73,11 @@ sharerPushF
|
|||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Push URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerPushF shr now author body push = do
|
||||
luPush <- fromMaybeE (activityId $ actbActivity body) "Push without 'id'"
|
||||
sharerPushF shr now author body mfwd luPush push = do
|
||||
lift $ runDB $ do
|
||||
Entity pidRecip recip <- do
|
||||
sid <- getKeyBy404 $ UniqueSharer shr
|
||||
|
|
|
@ -36,6 +36,7 @@ import Control.Monad.Trans.Reader
|
|||
import Data.Aeson
|
||||
import Data.Bifunctor
|
||||
import Data.Bitraversable
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Foldable
|
||||
import Data.Function
|
||||
import Data.List (nub, union)
|
||||
|
@ -105,12 +106,13 @@ sharerOfferTicketF
|
|||
-> ShrIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> 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
|
||||
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
||||
{-deps <- -}
|
||||
checkOffer ticket hProject shrProject prjProject
|
||||
local <- hostIsLocal hProject
|
||||
|
@ -203,11 +205,13 @@ projectOfferTicketF
|
|||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler Text
|
||||
projectOfferTicketF
|
||||
now shrRecip prjRecip author body ticket uTarget = do
|
||||
now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do
|
||||
targetIsUs <- lift $ runExceptT checkTarget
|
||||
case targetIsUs of
|
||||
Left t -> do
|
||||
|
@ -217,14 +221,9 @@ projectOfferTicketF
|
|||
]
|
||||
return t
|
||||
Right () -> do
|
||||
luOffer <-
|
||||
fromMaybeE
|
||||
(activityId $ actbActivity body)
|
||||
"Offer without 'id'"
|
||||
hLocal <- getsYesod siteInstanceHost
|
||||
{-deps <- -}
|
||||
checkOffer ticket hLocal shrRecip prjRecip
|
||||
msig <- checkForward $ LocalActorProject shrRecip prjRecip
|
||||
let colls =
|
||||
findRelevantCollections shrRecip prjRecip hLocal $
|
||||
activityAudience $ actbActivity body
|
||||
|
@ -236,7 +235,7 @@ projectOfferTicketF
|
|||
ra <- getJust $ remoteAuthorId author
|
||||
insertTicket ra luOffer jid ibid {-tids-}
|
||||
for mticket $ \ (ractid, obiidAccept, docAccept) -> do
|
||||
msr <- for msig $ \ sig -> do
|
||||
msr <- for mfwd $ \ (_, sig) -> do
|
||||
remoteRecips <- deliverFwdLocal ractid colls sid fsid
|
||||
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
|
||||
return (msr, obiidAccept, docAccept)
|
||||
|
@ -504,12 +503,12 @@ sharerCreateTicketF
|
|||
-> ShrIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler Text
|
||||
sharerCreateTicketF now shrRecip author body ticket muTarget = do
|
||||
luCreate <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
|
||||
sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do
|
||||
(targetAndContext, _, _) <- checkCreateTicket author ticket muTarget
|
||||
runDBExcept $ do
|
||||
ibidRecip <- lift $ do
|
||||
|
@ -548,17 +547,16 @@ projectCreateTicketF
|
|||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Ticket URIMode
|
||||
-> Maybe FedURI
|
||||
-> ExceptT Text Handler Text
|
||||
projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
|
||||
luCreate <-
|
||||
fromMaybeE (activityId $ actbActivity body) "Create without 'id'"
|
||||
projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do
|
||||
(targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget
|
||||
case targetAndContext of
|
||||
Left (_, shrContext, prjContext)
|
||||
| shrRecip == shrContext && prjRecip == prjContext -> do
|
||||
msig <- checkForward $ LocalActorProject shrRecip prjRecip
|
||||
msgOrRecips <- lift $ runDB $ do
|
||||
(sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
|
||||
mractidCreate <- insertCreate luCreate ibidProject
|
||||
|
@ -577,7 +575,7 @@ projectCreateTicketF now shrRecip prjRecip author body ticket muTarget = do
|
|||
Right () -> do
|
||||
hLocal <- getsYesod siteInstanceHost
|
||||
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
|
||||
(sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
|
||||
remoteRecipsHttpAccept <- do
|
||||
|
@ -755,16 +753,13 @@ sharerOfferDepF
|
|||
-> ShrIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.TicketDependency URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
sharerOfferDepF now shrRecip author body dep uTarget = do
|
||||
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
||||
sharerOfferDepF now shrRecip author body mfwd luOffer dep uTarget = do
|
||||
(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
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
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
|
||||
for mractid $ \ (ractid, ibiid) -> do
|
||||
insertDepOffer ibiid parent child
|
||||
mremotesHttpFwd <- lift $ for msig $ \ sig -> do
|
||||
mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
relevantFollowers <- askRelevantFollowers
|
||||
let sieve =
|
||||
makeRecipientSet [] $ catMaybes
|
||||
|
@ -1178,16 +1173,13 @@ projectOfferDepF
|
|||
-> PrjIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.TicketDependency URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
projectOfferDepF now shrRecip prjRecip author body dep uTarget = do
|
||||
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
||||
projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do
|
||||
(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
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
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
|
||||
for mractid $ \ (ractid, ibiid) -> do
|
||||
insertDepOffer ibiid parent child
|
||||
mremotesHttpFwd <- lift $ for msig $ \ sig -> do
|
||||
mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
relevantFollowers <- askRelevantFollowers
|
||||
let rf = relevantFollowers shrRecip prjRecip
|
||||
sieve =
|
||||
|
@ -1342,16 +1334,13 @@ repoOfferDepF
|
|||
-> RpIdent
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.TicketDependency URIMode
|
||||
-> FedURI
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
repoOfferDepF now shrRecip rpRecip author body dep uTarget = do
|
||||
luOffer <- fromMaybeE (activityId $ actbActivity body) "Offer without 'id'"
|
||||
repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do
|
||||
(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
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
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
|
||||
for mractid $ \ (ractid, ibiid) -> do
|
||||
insertDepOffer ibiid parent child
|
||||
mremotesHttpFwd <- lift $ for msig $ \ sig -> do
|
||||
mremotesHttpFwd <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
relevantFollowers <- askRelevantFollowers
|
||||
let rf = relevantFollowers shrRecip rpRecip
|
||||
sieve =
|
||||
|
|
Loading…
Reference in a new issue