From a0325da0288a69bf0e934328b7879b179dc42a9f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 22 Jun 2020 11:29:30 +0000 Subject: [PATCH] S2S: Implement projectOfferDepF and repoOfferDepF --- src/Vervis/Federation.hs | 33 +- src/Vervis/Federation/Ticket.hs | 663 ++++++++++++++++++++++++-------- 2 files changed, 525 insertions(+), 171 deletions(-) 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)