diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs
index 94035fc..02aa545 100644
--- a/src/Vervis/Federation.hs
+++ b/src/Vervis/Federation.hs
@@ -297,7 +297,7 @@ handleProjectInbox
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do
+handleProjectInbox shrRecip prjRecip now auth body = do
remoteAuthor <-
case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
@@ -306,20 +306,22 @@ handleProjectInbox shrRecip prjRecip now auth body = (,Nothing) <$> do
CreateActivity (Create obj mtarget) ->
case obj of
CreateNote note ->
- projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
+ (,Nothing) <$> projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
CreateTicket ticket ->
- projectCreateTicketF now shrRecip prjRecip remoteAuthor body ticket mtarget
+ (,Nothing) <$> projectCreateTicketF now shrRecip prjRecip remoteAuthor body ticket mtarget
_ -> error "Unsupported create object type for projects"
FollowActivity follow ->
- projectFollowF shrRecip prjRecip now remoteAuthor body follow
+ (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body follow
OfferActivity (Offer obj target) ->
case obj of
OfferTicket ticket ->
- projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
- _ -> return "Unsupported offer object type for projects"
+ (,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body ticket target
+ OfferDep dep ->
+ projectOfferDepF now shrRecip prjRecip remoteAuthor body dep target
+ _ -> return ("Unsupported offer object type for projects", Nothing)
UndoActivity undo ->
- projectUndoF shrRecip prjRecip now remoteAuthor body undo
- _ -> return "Unsupported activity type for projects"
+ (,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body undo
+ _ -> return ("Unsupported activity type for projects", Nothing)
where
errorLocalForwarded (ActivityAuthLocalPerson pid) =
"Project inbox got local forwarded activity by pid#" <>
@@ -338,7 +340,7 @@ handleRepoInbox
-> ActivityAuthentication
-> ActivityBody
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
-handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do
+handleRepoInbox shrRecip rpRecip now auth body = do
remoteAuthor <-
case auth of
ActivityAuthLocal local -> throwE $ errorLocalForwarded local
@@ -347,13 +349,18 @@ handleRepoInbox shrRecip rpRecip now auth body = (,Nothing) <$> do
CreateActivity (Create obj mtarget) ->
case obj of
CreateNote note ->
- repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
+ (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body note
_ -> error "Unsupported create object type for repos"
FollowActivity follow ->
- repoFollowF shrRecip rpRecip now remoteAuthor body follow
+ (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body follow
+ OfferActivity (Offer obj target) ->
+ case obj of
+ OfferDep dep ->
+ repoOfferDepF now shrRecip rpRecip remoteAuthor body dep target
+ _ -> return ("Unsupported offer object type for repos", Nothing)
UndoActivity undo->
- repoUndoF shrRecip rpRecip now remoteAuthor body undo
- _ -> return "Unsupported activity type for repos"
+ (,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body undo
+ _ -> return ("Unsupported activity type for repos", Nothing)
where
errorLocalForwarded (ActivityAuthLocalPerson pid) =
"Repo inbox got local forwarded activity by pid#" <>
diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs
index f5f2cd4..2355a5c 100644
--- a/src/Vervis/Federation/Ticket.hs
+++ b/src/Vervis/Federation/Ticket.hs
@@ -21,6 +21,8 @@ module Vervis.Federation.Ticket
, projectCreateTicketF
, sharerOfferDepF
+ , projectOfferDepF
+ , repoOfferDepF
)
where
@@ -30,6 +32,7 @@ import Control.Monad.Logger.CallStack
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
import Data.Aeson
import Data.Bifunctor
import Data.Bitraversable
@@ -43,6 +46,7 @@ import Data.Time.Calendar
import Data.Time.Clock
import Data.Traversable
import Database.Persist
+import Database.Persist.Sql
import Text.Blaze.Html (preEscapedToHtml)
import Text.Blaze.Html.Renderer.Text
import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
@@ -815,35 +819,8 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
throwE "Project 'id' differs from the URI we fetched"
return
(uTracker, objUriAuthority uProject, objFollowers obj, objTeam obj)
- (childId, childCtx, childAuthor) <-
- case child of
- Left wi -> runSiteDBExcept $ do
- (ltid, ctx, author) <- getWorkItem "Child" wi
- return (Left (wi, ltid), second mkuri ctx, second mkuri author)
- Right u -> do
- Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
- (hTicket, tl) <- fromMaybeE (AP.ticketLocal t) "Child ticket no 'id'"
- unless (ObjURI hAuthor (AP.ticketId tl) == u) $
- throwE "Ticket 'id' differs from the URI we fetched"
- uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'"
- ctx <- parseTicketContext uCtx
- author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t)
- return (Right (u, AP.ticketParticipants tl), ctx, author)
- childCtx' <- bifor childCtx pure $ \ u -> do
- obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u
- unless (objId obj == u) $
- throwE "Project 'id' differs from the URI we fetched"
- u' <-
- case (objContext obj, objInbox obj) of
- (Just c, Nothing) -> do
- hl <- hostIsLocal $ objUriAuthority c
- when hl $ throwE "Child remote context has a local context"
- pure c
- (Nothing, Just _) -> pure u
- _ -> throwE "Umm context-inbox thing"
- return
- (u', objUriAuthority u, objFollowers obj, objTeam obj)
- return (talid, patch, parentLtid, parentCtx', childId, childCtx', childAuthor)
+ childDetail <- getWorkItemDetail "Child" child
+ return (talid, patch, parentLtid, parentCtx', childDetail)
mhttp <- runSiteDBExcept $ do
mractid <- lift $ insertToInbox' now author body (personInbox personRecip) luOffer True
for mractid $ \ (ractid, ibiid) -> do
@@ -861,9 +838,9 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
localRecipSieve'
sieve False False localRecips
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent personRecip) sig remoteRecips
- mremotesHttpAccept <- lift $ for relevantParent $ \ ticketData@(_, _, parentLtid, _, childId, _, _) -> do
+ mremotesHttpAccept <- lift $ for relevantParent $ \ ticketData@(_, _, parentLtid, _, childDetail) -> do
obiidAccept <- insertEmptyOutboxItem (personOutbox personRecip) now
- tdid <- insertDep ractid parentLtid childId obiidAccept
+ tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept luOffer obiidAccept tdid ticketData
knownRemoteRecipsAccept <-
@@ -894,19 +871,153 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
ticketRelevance shr (Left (WorkItemSharerTicket shr' talid patch))
| shr == shr' = Just (talid, patch)
ticketRelevance _ _ = Nothing
- {-
- getWorkItem
- :: MonadIO m
- => Text
- -> WorkItem
- -> ExceptT Text (ReaderT SqlBaclend m)
- ( LocalTicketId
- , Either
- (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
- (Instance, RemoteObject)
- , Either ShrIdent (Instance, RemoteObject)
- )
- -}
+ insertDepOffer _ (Left _) _ = return ()
+ insertDepOffer ibiidOffer (Right _) child =
+ for_ (ticketRelevance shrRecip child) $ \ (talid, patch) -> do
+ ltid <-
+ if patch
+ then do
+ (_, Entity ltid _, _, _, _) <- do
+ mticket <- lift $ getSharerPatch shrRecip talid
+ fromMaybeE mticket $ "Child" <> ": No such sharer-patch"
+ return ltid
+ else do
+ (_, Entity ltid _, _, _) <- do
+ mticket <- lift $ getSharerTicket shrRecip talid
+ fromMaybeE mticket $ "Child" <> ": No such sharer-ticket"
+ return ltid
+ lift $ insert_ TicketDependencyOffer
+ { ticketDependencyOfferOffer = ibiidOffer
+ , ticketDependencyOfferChild = ltid
+ }
+ askRelevantFollowers = do
+ hashTALID <- getEncodeKeyHashid
+ return $ \ shr wi -> followers hashTALID <$> ticketRelevance shr wi
+ where
+ followers hashTALID (talid, patch) =
+ let coll =
+ if patch
+ then LocalPersonCollectionSharerPatchFollowers
+ else LocalPersonCollectionSharerTicketFollowers
+ in coll shrRecip (hashTALID talid)
+ insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, WorkItemDetail childId childCtx childAuthor) = do
+ encodeRouteLocal <- getEncodeRouteLocal
+ encodeRouteHome <- getEncodeRouteHome
+ followers <- askFollowers
+ workItemFollowers <- askWorkItemFollowers
+ hLocal <- asksSite siteInstanceHost
+ obikhidAccept <- encodeKeyHashid obiidAccept
+ tdkhid <- encodeKeyHashid tdid
+ ra <- getJust $ remoteAuthorId author
+ let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+ audAuthor =
+ AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+ audParentContext = contextAudience parentCtx
+ audChildContext = contextAudience childCtx
+ audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch]
+ audChildAuthor =
+ case childAuthor of
+ Left shr -> AudLocal [LocalActorSharer shr] []
+ Right (ObjURI h lu) -> AudRemote h [lu] []
+ audChildFollowers =
+ case childId of
+ Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
+ Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
+
+ (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+ collectAudience $
+ audAuthor :
+ audParent :
+ audChildAuthor :
+ audChildFollowers :
+ audParentContext ++ audChildContext
+
+ recips = map encodeRouteHome audLocal ++ audRemote
+ doc = Doc hLocal Activity
+ { activityId =
+ Just $ encodeRouteLocal $
+ SharerOutboxItemR shrRecip obikhidAccept
+ , activityActor = encodeRouteLocal $ SharerR shrRecip
+ , activitySummary = Nothing
+ , activityAudience = Audience recips [] [] [] [] []
+ , activitySpecific = AcceptActivity Accept
+ { acceptObject = ObjURI hAuthor luOffer
+ , acceptResult =
+ Just $ encodeRouteLocal $ TicketDepR tdkhid
+ }
+ }
+ update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+ return (doc, recipientSet, remoteActors, fwdHosts)
+ where
+ askFollowers = do
+ hashTALID <- getEncodeKeyHashid
+ return $ \ talid patch ->
+ let coll =
+ if patch
+ then LocalPersonCollectionSharerPatchFollowers
+ else LocalPersonCollectionSharerTicketFollowers
+ in coll shrRecip (hashTALID talid)
+
+data WorkItemDetail = WorkItemDetail
+ { widIdent :: Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
+ , widContext :: Either (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent)) (FedURI, Host, Maybe LocalURI, Maybe LocalURI)
+ , widAuthor :: Either ShrIdent FedURI
+ }
+
+getAuthor
+ :: MonadIO m
+ => Either
+ (Entity TicketAuthorLocal, Entity TicketUnderProject)
+ (Entity TicketAuthorRemote)
+ -> ReaderT SqlBackend m (Either ShrIdent (Instance, RemoteObject))
+getAuthor =
+ bitraverse
+ (\ (Entity _ tal, _) -> do
+ p <- getJust $ ticketAuthorLocalAuthor tal
+ sharerIdent <$> getJust (personIdent p)
+ )
+ (\ (Entity _ tar) -> do
+ ra <- getJust $ ticketAuthorRemoteAuthor tar
+ ro <- getJust $ remoteActorIdent ra
+ i <- getJust $ remoteObjectInstance ro
+ return (i, ro)
+ )
+
+getWorkItemDetail
+ :: Text -> Either WorkItem FedURI -> ExceptT Text Worker WorkItemDetail
+getWorkItemDetail name v = do
+ manager <- asksSite appHttpManager
+ (childId, childCtx, childAuthor) <-
+ case v of
+ Left wi -> runSiteDBExcept $ do
+ (ltid, ctx, author) <- getWorkItem name wi
+ return (Left (wi, ltid), second mkuri ctx, second mkuri author)
+ Right u -> do
+ Doc hAuthor t <- withExceptT T.pack $ AP.fetchAP manager $ Left u
+ (hTicket, tl) <- fromMaybeE (AP.ticketLocal t) $ name <> ": no 'id'"
+ unless (ObjURI hAuthor (AP.ticketId tl) == u) $
+ throwE "Ticket 'id' differs from the URI we fetched"
+ uCtx <- fromMaybeE (AP.ticketContext t) "Ticket without 'context'"
+ ctx <- parseTicketContext uCtx
+ author <- parseTicketAuthor $ ObjURI hTicket (AP.ticketAttributedTo t)
+ return (Right (u, AP.ticketParticipants tl), ctx, author)
+ childCtx' <- bifor childCtx pure $ \ u -> do
+ obj <- withExceptT T.pack $ AP.fetchAP manager $ Left u
+ unless (objId obj == u) $
+ throwE "Project 'id' differs from the URI we fetched"
+ u' <-
+ case (objContext obj, objInbox obj) of
+ (Just c, Nothing) -> do
+ hl <- hostIsLocal $ objUriAuthority c
+ when hl $ throwE $ name <> ": remote context has a local context"
+ pure c
+ (Nothing, Just _) -> pure u
+ _ -> throwE "Umm context-inbox thing"
+ return
+ (u', objUriAuthority u, objFollowers obj, objTeam obj)
+ return $ WorkItemDetail childId childCtx' childAuthor
+ where
getWorkItem name (WorkItemSharerTicket shr talid False) = do
(_, Entity ltid _, _, context) <- do
mticket <- lift $ getSharerTicket shr talid
@@ -961,41 +1072,14 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
mticket <- lift $ getProjectTicket shr prj ltid
(Entity _ s, Entity _ j, _, _, _, _, author) <-
fromMaybeE mticket $ name <> ": No such project-ticket"
- author' <-
- lift $
- bitraverse
- (\ (Entity _ tal, _) -> do
- p <- getJust $ ticketAuthorLocalAuthor tal
- sharerIdent <$> getJust (personIdent p)
- )
- (\ (Entity _ tar) -> do
- ra <- getJust $ ticketAuthorRemoteAuthor tar
- ro <- getJust $ remoteActorIdent ra
- i <- getJust $ remoteObjectInstance ro
- return (i, ro)
- )
- author
+ author' <- lift $ getAuthor author
return (ltid, Left $ Left (sharerIdent s, projectIdent j), author')
getWorkItem name (WorkItemRepoPatch shr rp ltid) = do
mticket <- lift $ getRepoPatch shr rp ltid
(Entity _ s, Entity _ r, _, _, _, _, author, _) <-
fromMaybeE mticket $ name <> ": No such repo-patch"
- author' <-
- lift $
- bitraverse
- (\ (Entity _ tal, _) -> do
- p <- getJust $ ticketAuthorLocalAuthor tal
- sharerIdent <$> getJust (personIdent p)
- )
- (\ (Entity _ tar) -> do
- ra <- getJust $ ticketAuthorRemoteAuthor tar
- ro <- getJust $ remoteActorIdent ra
- i <- getJust $ remoteObjectInstance ro
- return (i, ro)
- )
- author
+ author' <- lift $ getAuthor author
return (ltid, Left $ Right (sharerIdent s, repoIdent r), author')
- mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
parseTicketContext u@(ObjURI h lu) = do
hl <- hostIsLocal h
if hl
@@ -1015,60 +1099,178 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
SharerR shr -> return shr
_ -> throwE "Not a ticket author route"
else return $ Right u
+
+mkuri (i, ro) = ObjURI (instanceHost i) (remoteObjectIdent ro)
+
+insertDep
+ :: MonadIO m
+ => UTCTime
+ -> RemoteAuthor
+ -> RemoteActivityId
+ -> LocalTicketId
+ -> Either (WorkItem, LocalTicketId) (FedURI, LocalURI)
+ -> OutboxItemId
+ -> ReaderT SqlBackend m LocalTicketDependencyId
+insertDep now author ractidOffer ltidParent child obiidAccept = do
+ tdid <- insert LocalTicketDependency
+ { localTicketDependencyParent = ltidParent
+ , localTicketDependencyCreated = now
+ , localTicketDependencyAccept = obiidAccept
+ }
+ case child of
+ Left (_wi, ltid) -> insert_ TicketDependencyChildLocal
+ { ticketDependencyChildLocalDep = tdid
+ , ticketDependencyChildLocalChild = ltid
+ }
+ Right (ObjURI h lu, _luFollowers) -> do
+ iid <- either entityKey id <$> insertBy' (Instance h)
+ roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
+ insert_ TicketDependencyChildRemote
+ { ticketDependencyChildRemoteDep = tdid
+ , ticketDependencyChildRemoteChild = roid
+ }
+ insert_ TicketDependencyAuthorRemote
+ { ticketDependencyAuthorRemoteDep = tdid
+ , ticketDependencyAuthorRemoteAuthor = remoteAuthorId author
+ , ticketDependencyAuthorRemoteOpen = ractidOffer
+ }
+ return tdid
+
+askWorkItemFollowers
+ :: (MonadSite m, YesodHashids (SiteEnv m))
+ => m (WorkItem -> LocalPersonCollection)
+askWorkItemFollowers = do
+ hashTALID <- getEncodeKeyHashid
+ hashLTID <- getEncodeKeyHashid
+ let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
+ workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
+ workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
+ workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
+ return workItemFollowers
+
+contextAudience
+ :: Either
+ (Either (ShrIdent, PrjIdent) (ShrIdent, RpIdent))
+ (FedURI, Host, Maybe LocalURI, Maybe LocalURI)
+ -> [Aud URIMode]
+contextAudience ctx =
+ case ctx of
+ Left (Left (shr, prj)) ->
+ pure $ AudLocal
+ [LocalActorProject shr prj]
+ [ LocalPersonCollectionProjectTeam shr prj
+ , LocalPersonCollectionProjectFollowers shr prj
+ ]
+ Left (Right (shr, rp)) ->
+ pure $ AudLocal
+ [LocalActorRepo shr rp]
+ [ LocalPersonCollectionRepoTeam shr rp
+ , LocalPersonCollectionRepoFollowers shr rp
+ ]
+ Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) ->
+ [ AudRemote hTracker [luTracker] []
+ , AudRemote hProject [] (catMaybes [luFollowers, luTeam])
+ ]
+
+projectOfferDepF
+ :: UTCTime
+ -> ShrIdent
+ -> PrjIdent
+ -> RemoteAuthor
+ -> ActivityBody
+ -> 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'"
+ (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
+ return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
+ relevantParent <-
+ for (ticketRelevance shrRecip prjRecip parent) $ \ parentLtid -> do
+ parentAuthor <- runSiteDBExcept $ do
+ (_, _, _, _, _, _, author) <- do
+ mticket <- lift $ getProjectTicket shrRecip prjRecip parentLtid
+ fromMaybeE mticket $ "Parent" <> ": No such project-ticket"
+ lift $ getAuthor author
+ childDetail <- getWorkItemDetail "Child" child
+ return (parentLtid, parentAuthor, childDetail)
+ mhttp <- runSiteDBExcept $ 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
+ relevantFollowers <- askRelevantFollowers
+ let rf = relevantFollowers shrRecip prjRecip
+ sieve =
+ makeRecipientSet [] $ catMaybes
+ [ rf parent
+ , rf child
+ ]
+ remoteRecips <-
+ insertRemoteActivityToLocalInboxes
+ False ractid $
+ localRecipSieve'
+ sieve False False localRecips
+ (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
+ mremotesHttpAccept <- lift $ for relevantParent $ \ (parentLtid, parentAuthor, childDetail) -> do
+ obiidAccept <- insertEmptyOutboxItem (projectOutbox projectRecip) now
+ tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
+ (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+ insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail
+ knownRemoteRecipsAccept <-
+ deliverLocal'
+ False
+ (LocalActorProject shrRecip prjRecip)
+ (projectInbox projectRecip)
+ obiidAccept
+ localRecipsAccept
+ (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+ return (mremotesHttpFwd, mremotesHttpAccept)
+ case mhttp of
+ Nothing -> return "I already have this activity in my inbox, doing nothing"
+ Just (mremotesHttpFwd, mremotesHttpAccept) -> do
+ for_ mremotesHttpFwd $ \ (sig, remotes) ->
+ forkWorker "projectOfferDepF inbox-forwarding" $
+ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
+ for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
+ forkWorker "projectOfferDepF Accept HTTP delivery" $
+ deliverRemoteHttp' fwdHosts obiid doc remotes
+ return $
+ case (mremotesHttpAccept, mremotesHttpFwd) of
+ (Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do"
+ (Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding"
+ (Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
+ (Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
+ where
+ ticketRelevance shr prj (Left (WorkItemProjectTicket shr' prj' ltid))
+ | shr == shr' && prj == prj' = Just ltid
+ ticketRelevance _ _ _ = Nothing
insertDepOffer _ (Left _) _ = return ()
insertDepOffer ibiidOffer (Right _) child =
- for_ (ticketRelevance shrRecip child) $ \ (talid, patch) -> do
- ltid <-
- if patch
- then do
- (_, Entity ltid _, _, _, _) <- do
- mticket <- lift $ getSharerPatch shrRecip talid
- fromMaybeE mticket $ "Child" <> ": No such sharer-patch"
- return ltid
- else do
- (_, Entity ltid _, _, _) <- do
- mticket <- lift $ getSharerTicket shrRecip talid
- fromMaybeE mticket $ "Child" <> ": No such sharer-ticket"
- return ltid
+ for_ (ticketRelevance shrRecip prjRecip child) $ \ ltid -> do
+ _ <- do
+ mticket <- lift $ getProjectTicket shrRecip prjRecip ltid
+ fromMaybeE mticket $ "Child" <> ": No such project-ticket"
lift $ insert_ TicketDependencyOffer
{ ticketDependencyOfferOffer = ibiidOffer
, ticketDependencyOfferChild = ltid
}
askRelevantFollowers = do
- hashTALID <- getEncodeKeyHashid
- return $ \ shr wi -> followers hashTALID <$> ticketRelevance shr wi
+ hashLTID <- getEncodeKeyHashid
+ return $
+ \ shr prj wi -> followers hashLTID <$> ticketRelevance shr prj wi
where
- followers hashTALID (talid, patch) =
- let coll =
- if patch
- then LocalPersonCollectionSharerPatchFollowers
- else LocalPersonCollectionSharerTicketFollowers
- in coll shrRecip (hashTALID talid)
- insertDep ractidOffer ltidParent child obiidAccept = do
- tdid <- insert LocalTicketDependency
- { localTicketDependencyParent = ltidParent
- , localTicketDependencyCreated = now
- , localTicketDependencyAccept = obiidAccept
- }
- case child of
- Left (_wi, ltid) -> insert_ TicketDependencyChildLocal
- { ticketDependencyChildLocalDep = tdid
- , ticketDependencyChildLocalChild = ltid
- }
- Right (ObjURI h lu, _luFollowers) -> do
- iid <- either entityKey id <$> insertBy' (Instance h)
- roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
- insert_ TicketDependencyChildRemote
- { ticketDependencyChildRemoteDep = tdid
- , ticketDependencyChildRemoteChild = roid
- }
- insert_ TicketDependencyAuthorRemote
- { ticketDependencyAuthorRemoteDep = tdid
- , ticketDependencyAuthorRemoteAuthor = remoteAuthorId author
- , ticketDependencyAuthorRemoteOpen = ractidOffer
- }
- return tdid
- insertAccept luOffer obiidAccept tdid (talid, patch, _, parentCtx, childId, childCtx, childAuthor) = do
+ followers hashLTID ltid =
+ LocalPersonCollectionProjectTicketFollowers
+ shrRecip prjRecip (hashLTID ltid)
+ insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
followers <- askFollowers
@@ -1081,9 +1283,19 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
- audParentContext = contextAudience parentCtx
+ audParentContext =
+ AudLocal
+ []
+ [ LocalPersonCollectionProjectTeam shrRecip prjRecip
+ , LocalPersonCollectionProjectFollowers shrRecip prjRecip
+ ]
audChildContext = contextAudience childCtx
- audParent = AudLocal [LocalActorSharer shrRecip] [followers talid patch]
+ audParentFollowers = AudLocal [] [followers ltid]
+ audParentAuthor =
+ case parentAuthor of
+ Left shr -> AudLocal [LocalActorSharer shr] []
+ Right (i, ro) ->
+ AudRemote (instanceHost i) [remoteObjectIdent ro] []
audChildAuthor =
case childAuthor of
Left shr -> AudLocal [LocalActorSharer shr] []
@@ -1096,17 +1308,16 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience $
audAuthor :
- audParent :
- audChildAuthor :
- audChildFollowers :
- audParentContext ++ audChildContext
+ audParentAuthor : audParentFollowers :
+ audChildAuthor : audChildFollowers :
+ audParentContext : audChildContext
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
Just $ encodeRouteLocal $
SharerOutboxItemR shrRecip obikhidAccept
- , activityActor = encodeRouteLocal $ SharerR shrRecip
+ , activityActor = encodeRouteLocal $ ProjectR shrRecip prjRecip
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
@@ -1118,37 +1329,173 @@ sharerOfferDepF now shrRecip author body dep uTarget = do
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
where
- contextAudience ctx =
- case ctx of
- Left (Left (shr, prj)) ->
- pure $ AudLocal
- [LocalActorProject shr prj]
- [ LocalPersonCollectionProjectTeam shr prj
- , LocalPersonCollectionProjectFollowers shr prj
- ]
- Left (Right (shr, rp)) ->
- pure $ AudLocal
- [LocalActorRepo shr rp]
- [ LocalPersonCollectionRepoTeam shr rp
- , LocalPersonCollectionRepoFollowers shr rp
- ]
- Right (ObjURI hTracker luTracker, hProject, luFollowers, luTeam) ->
- [ AudRemote hTracker [luTracker] []
- , AudRemote hProject [] (catMaybes [luFollowers, luTeam])
- ]
askFollowers = do
- hashTALID <- getEncodeKeyHashid
- return $ \ talid patch ->
- let coll =
- if patch
- then LocalPersonCollectionSharerPatchFollowers
- else LocalPersonCollectionSharerTicketFollowers
- in coll shrRecip (hashTALID talid)
- askWorkItemFollowers = do
- hashTALID <- getEncodeKeyHashid
hashLTID <- getEncodeKeyHashid
- let workItemFollowers (WorkItemSharerTicket shr talid False) = LocalPersonCollectionSharerTicketFollowers shr $ hashTALID talid
- workItemFollowers (WorkItemSharerTicket shr talid True) = LocalPersonCollectionSharerPatchFollowers shr $ hashTALID talid
- workItemFollowers (WorkItemProjectTicket shr prj ltid) = LocalPersonCollectionProjectTicketFollowers shr prj $ hashLTID ltid
- workItemFollowers (WorkItemRepoPatch shr rp ltid) = LocalPersonCollectionRepoPatchFollowers shr rp $ hashLTID ltid
- return workItemFollowers
+ return $
+ \ ltid ->
+ LocalPersonCollectionProjectTicketFollowers
+ shrRecip prjRecip (hashLTID ltid)
+
+repoOfferDepF
+ :: UTCTime
+ -> ShrIdent
+ -> RpIdent
+ -> RemoteAuthor
+ -> ActivityBody
+ -> 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'"
+ (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
+ return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
+ relevantParent <-
+ for (ticketRelevance shrRecip rpRecip parent) $ \ parentLtid -> do
+ parentAuthor <- runSiteDBExcept $ do
+ (_, _, _, _, _, _, author, _) <- do
+ mticket <- lift $ getRepoPatch shrRecip rpRecip parentLtid
+ fromMaybeE mticket $ "Parent" <> ": No such repo-patch"
+ lift $ getAuthor author
+ childDetail <- getWorkItemDetail "Child" child
+ return (parentLtid, parentAuthor, childDetail)
+ mhttp <- runSiteDBExcept $ 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
+ relevantFollowers <- askRelevantFollowers
+ let rf = relevantFollowers shrRecip rpRecip
+ sieve =
+ makeRecipientSet [] $ catMaybes
+ [ rf parent
+ , rf child
+ ]
+ remoteRecips <-
+ insertRemoteActivityToLocalInboxes
+ False ractid $
+ localRecipSieve'
+ sieve False False localRecips
+ (sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips
+ mremotesHttpAccept <- lift $ for relevantParent $ \ (parentLtid, parentAuthor, childDetail) -> do
+ obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) now
+ tdid <- insertDep now author ractid parentLtid (widIdent childDetail) obiidAccept
+ (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+ insertAccept luOffer obiidAccept tdid parentLtid parentAuthor childDetail
+ knownRemoteRecipsAccept <-
+ deliverLocal'
+ False
+ (LocalActorRepo shrRecip rpRecip)
+ (repoInbox repoRecip)
+ obiidAccept
+ localRecipsAccept
+ (obiidAccept,docAccept,fwdHostsAccept,) <$> deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+ return (mremotesHttpFwd, mremotesHttpAccept)
+ case mhttp of
+ Nothing -> return "I already have this activity in my inbox, doing nothing"
+ Just (mremotesHttpFwd, mremotesHttpAccept) -> do
+ for_ mremotesHttpFwd $ \ (sig, remotes) ->
+ forkWorker "repoOfferDepF inbox-forwarding" $
+ deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
+ for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
+ forkWorker "repoOfferDepF Accept HTTP delivery" $
+ deliverRemoteHttp' fwdHosts obiid doc remotes
+ return $
+ case (mremotesHttpAccept, mremotesHttpFwd) of
+ (Nothing, Nothing) -> "Parent not mine, just stored in inbox and no inbox-forwarding to do"
+ (Nothing, Just _) -> "Parent not mine, just stored in inbox and ran inbox-forwarding"
+ (Just _, Nothing) -> "Accepted new ticket dep, no inbox-forwarding to do"
+ (Just _, Just _) -> "Accepted new ticket dep and ran inbox-forwarding of the Offer"
+ where
+ ticketRelevance shr rp (Left (WorkItemRepoPatch shr' rp' ltid))
+ | shr == shr' && rp == rp' = Just ltid
+ ticketRelevance _ _ _ = Nothing
+ insertDepOffer _ (Left _) _ = return ()
+ insertDepOffer ibiidOffer (Right _) child =
+ for_ (ticketRelevance shrRecip rpRecip child) $ \ ltid -> do
+ _ <- do
+ mticket <- lift $ getRepoPatch shrRecip rpRecip ltid
+ fromMaybeE mticket $ "Child" <> ": No such repo-patch"
+ lift $ insert_ TicketDependencyOffer
+ { ticketDependencyOfferOffer = ibiidOffer
+ , ticketDependencyOfferChild = ltid
+ }
+ askRelevantFollowers = do
+ hashLTID <- getEncodeKeyHashid
+ return $
+ \ shr rp wi -> followers hashLTID <$> ticketRelevance shr rp wi
+ where
+ followers hashLTID ltid =
+ LocalPersonCollectionRepoPatchFollowers
+ shrRecip rpRecip (hashLTID ltid)
+ insertAccept luOffer obiidAccept tdid ltid parentAuthor (WorkItemDetail childId childCtx childAuthor) = do
+ encodeRouteLocal <- getEncodeRouteLocal
+ encodeRouteHome <- getEncodeRouteHome
+ followers <- askFollowers
+ workItemFollowers <- askWorkItemFollowers
+ hLocal <- asksSite siteInstanceHost
+ obikhidAccept <- encodeKeyHashid obiidAccept
+ tdkhid <- encodeKeyHashid tdid
+ ra <- getJust $ remoteAuthorId author
+ let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+ audAuthor =
+ AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+ audParentContext =
+ AudLocal
+ []
+ [ LocalPersonCollectionRepoTeam shrRecip rpRecip
+ , LocalPersonCollectionRepoFollowers shrRecip rpRecip
+ ]
+ audChildContext = contextAudience childCtx
+ audParentFollowers = AudLocal [] [followers ltid]
+ audParentAuthor =
+ case parentAuthor of
+ Left shr -> AudLocal [LocalActorSharer shr] []
+ Right (i, ro) ->
+ AudRemote (instanceHost i) [remoteObjectIdent ro] []
+ audChildAuthor =
+ case childAuthor of
+ Left shr -> AudLocal [LocalActorSharer shr] []
+ Right (ObjURI h lu) -> AudRemote h [lu] []
+ audChildFollowers =
+ case childId of
+ Left (wi, _ltid) -> AudLocal [] [workItemFollowers wi]
+ Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers]
+
+ (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+ collectAudience $
+ audAuthor :
+ audParentAuthor : audParentFollowers :
+ audChildAuthor : audChildFollowers :
+ audParentContext : audChildContext
+
+ recips = map encodeRouteHome audLocal ++ audRemote
+ doc = Doc hLocal Activity
+ { activityId =
+ Just $ encodeRouteLocal $
+ SharerOutboxItemR shrRecip obikhidAccept
+ , activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip
+ , activitySummary = Nothing
+ , activityAudience = Audience recips [] [] [] [] []
+ , activitySpecific = AcceptActivity Accept
+ { acceptObject = ObjURI hAuthor luOffer
+ , acceptResult =
+ Just $ encodeRouteLocal $ TicketDepR tdkhid
+ }
+ }
+ update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+ return (doc, recipientSet, remoteActors, fwdHosts)
+ where
+ askFollowers = do
+ hashLTID <- getEncodeKeyHashid
+ return $
+ \ ltid ->
+ LocalPersonCollectionRepoPatchFollowers
+ shrRecip rpRecip (hashLTID ltid)