diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 4971bed..9f02b32 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -372,6 +372,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do case obj of CreateNote note -> (,Nothing) <$> repoCreateNoteF now shrRecip rpRecip remoteAuthor body mfwd luActivity note + CreateTicket ticket -> + (,Nothing) <$> repoCreateTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket mtarget _ -> error "Unsupported create object type for repos" FollowActivity follow -> (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 5d07d67..79d0994 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -20,6 +20,7 @@ module Vervis.Federation.Ticket , sharerCreateTicketF , projectCreateTicketF + , repoCreateTicketF , sharerOfferDepF , projectOfferDepF @@ -776,6 +777,124 @@ sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do unless (isJust mr) $ throwE "Local context: No such repo" checkTargetAndContextDB (Right _) = return () +insertRemoteTicket + :: (MonadIO m, PersistRecordBackend txl SqlBackend) + => (TicketContextLocalId -> txl) + -> RemoteAuthor + -> LocalURI + -> UTCTime + -> TextHtml + -> TextHtml + -> TextPandocMarkdown + -> RemoteActivityId + -> OutboxItemId + -> ReaderT SqlBackend m (Either Bool ()) +insertRemoteTicket mktxl author luTicket published summary content source ractidCreate obiidAccept = do + tid <- insert Ticket + { ticketNumber = Nothing + , ticketCreated = published + , ticketTitle = unTextHtml summary + , ticketSource = unTextPandocMarkdown source + , ticketDescription = unTextHtml content + , ticketAssignee = Nothing + , ticketStatus = TSNew + , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 + , ticketCloser = Nothing + } + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } + txlid <- insert $ mktxl tclid + mtarid <- insertUnique TicketAuthorRemote + { ticketAuthorRemoteTicket = tclid + , ticketAuthorRemoteAuthor = remoteAuthorId author + , ticketAuthorRemoteOpen = ractidCreate + } + case mtarid of + Nothing -> do + delete txlid + delete tclid + delete tid + return $ Left False + Just tarid -> do + roid <- either entityKey id <$> insertBy' RemoteObject + { remoteObjectInstance = remoteAuthorInstance author + , remoteObjectIdent = luTicket + } + did <- insert Discussion + (rdid, rdnew) <- idAndNew <$> insertBy' RemoteDiscussion + { remoteDiscussionIdent = roid + , remoteDiscussionDiscuss = did + } + unless rdnew $ delete did + mrtid <- insertUnique RemoteTicket + { remoteTicketTicket = tarid + , remoteTicketIdent = roid + , remoteTicketDiscuss = rdid + } + case mrtid of + Nothing -> do + delete tarid + delete txlid + delete tclid + delete tid + return $ Left True + Just _rtid -> return $ Right () + +insertAcceptOnCreate collections outboxItemRoute actorRoute author luCreate tlocal obiidAccept = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + + hLocal <- asksSite siteInstanceHost + + obikhidAccept <- encodeKeyHashid obiidAccept + + ra <- getJust $ remoteAuthorId author + + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audAuthorAndTicket = + AudRemote hAuthor [luAuthor] $ catMaybes + [ remoteActorFollowers ra + , Just $ AP.ticketParticipants tlocal + ] + audProject = AudLocal [] collections + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAuthorAndTicket, audProject] + + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ outboxItemRoute obikhidAccept + , activityActor = encodeRouteLocal actorRoute + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hAuthor luCreate + , acceptResult = Nothing + } + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + +insertAcceptOnCreate_J shr prj = + insertAcceptOnCreate + [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + (ProjectOutboxItemR shr prj) + (ProjectR shr prj) + +insertAcceptOnCreate_R shr rp = + insertAcceptOnCreate + [ LocalPersonCollectionRepoTeam shr rp + , LocalPersonCollectionRepoFollowers shr rp + ] + (RepoOutboxItemR shr rp) + (RepoR shr rp) + projectCreateTicketF :: UTCTime -> ShrIdent @@ -797,7 +916,8 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa mractid <- insertToInbox now author body (projectInbox j) luCreate False for mractid $ \ ractid -> do obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now - result <- insertTicket jid author (AP.ticketId tlocal) published title desc src ractid obiidAccept + let makeTPL tclid = TicketProjectLocal tclid jid + result <- insertRemoteTicket makeTPL author (AP.ticketId tlocal) published title desc src ractid obiidAccept unless (isRight result) $ delete obiidAccept for result $ \ () -> do mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do @@ -814,7 +934,7 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa sieve False False localRecips (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - insertAccept shrRecip prjRecip author luCreate tlocal obiidAccept + insertAcceptOnCreate_J shrRecip prjRecip author luCreate tlocal obiidAccept knownRemoteRecipsAccept <- deliverLocal' False @@ -847,102 +967,80 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa targetRelevance (Left (_, WTTProject shr prj)) | shr == shrRecip && prj == prjRecip = Just () targetRelevance _ = Nothing - insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do - tid <- insert Ticket - { ticketNumber = Nothing - , ticketCreated = published - , ticketTitle = unTextHtml summary - , ticketSource = unTextPandocMarkdown source - , ticketDescription = unTextHtml content - , ticketAssignee = Nothing - , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing - } - tclid <- insert TicketContextLocal - { ticketContextLocalTicket = tid - , ticketContextLocalAccept = obiidAccept - } - tplid <- insert TicketProjectLocal - { ticketProjectLocalContext = tclid - , ticketProjectLocalProject = jid - } - mtarid <- insertUnique TicketAuthorRemote - { ticketAuthorRemoteTicket = tclid - , ticketAuthorRemoteAuthor = remoteAuthorId author - , ticketAuthorRemoteOpen = ractidCreate - } - case mtarid of - Nothing -> do - delete tplid - delete tclid - delete tid - return $ Left False - Just tarid -> do - roid <- either entityKey id <$> insertBy' RemoteObject - { remoteObjectInstance = remoteAuthorInstance author - , remoteObjectIdent = luTicket - } - did <- insert Discussion - (rdid, rdnew) <- idAndNew <$> insertBy' RemoteDiscussion - { remoteDiscussionIdent = roid - , remoteDiscussionDiscuss = did - } - unless rdnew $ delete did - mrtid <- insertUnique RemoteTicket - { remoteTicketTicket = tarid - , remoteTicketIdent = roid - , remoteTicketDiscuss = rdid - } - case mrtid of - Nothing -> do - delete tarid - delete tplid - delete tclid - delete tid - return $ Left True - Just _rtid -> return $ Right () - insertAccept shr prj author luCreate tlocal obiidAccept = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - - obikhidAccept <- encodeKeyHashid obiidAccept - - ra <- getJust $ remoteAuthorId author - - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audAuthorAndTicket = - AudRemote hAuthor [luAuthor] $ catMaybes - [ remoteActorFollowers ra - , Just $ AP.ticketParticipants tlocal - ] - audProject = - AudLocal [] - [ LocalPersonCollectionProjectTeam shr prj - , LocalPersonCollectionProjectFollowers shr prj - ] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAuthorAndTicket, audProject] - - recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - ProjectOutboxItemR shr prj obikhidAccept - , activityActor = encodeRouteLocal $ ProjectR shr prj - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hAuthor luCreate - , acceptResult = Nothing - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) +repoCreateTicketF + :: UTCTime + -> ShrIdent + -> RpIdent + -> RemoteAuthor + -> ActivityBody + -> Maybe (LocalRecipientSet, ByteString) + -> LocalURI + -> AP.Ticket URIMode + -> Maybe FedURI + -> ExceptT Text Handler Text +repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do + ParsedCreateTicket targetAndContext tlocal published title desc src <- + checkCreateTicket author ticket muTarget + mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, vcs, _diff) -> runDBExcept $ do + Entity rid r <- lift $ do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getBy404 $ UniqueRepo rpRecip sid + unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch" + mractid <- lift $ insertToInbox now author body (repoInbox r) luCreate False + lift $ for mractid $ \ ractid -> do + obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now + let mkTRL tclid = TicketRepoLocal tclid rid mb + result <- insertRemoteTicket mkTRL author (AP.ticketId tlocal) published title desc src ractid obiidAccept + unless (isRight result) $ delete obiidAccept + for result $ \ () -> do + mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionRepoTeam shrRecip rpRecip + , LocalPersonCollectionRepoFollowers shrRecip rpRecip + ] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAcceptOnCreate_R shrRecip rpRecip author luCreate tlocal obiidAccept + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorRepo shrRecip rpRecip) + (repoInbox r) + obiidAccept + localRecipsAccept + (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + case mmhttp of + Nothing -> return "Create/MR against different repo, not using" + Just mhttp -> + case mhttp of + Nothing -> return "Activity already in my inbox, doing nothing" + Just e -> + case e of + Left False -> return "Already have a MR opened by this activity, ignoring" + Left True -> return "Already have this MR, ignoring" + Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "repoCreateTicketF inbox-forwarding" $ + deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes + forkWorker "repoCreateTicketF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + return $ + case mremotesHttpFwd of + Nothing -> "Accepted and listed MR, no inbox-forwarding to do" + Just _ -> "Accepted and listed MR and ran inbox-forwarding of the Create" + where + targetRelevance (Left (_, WTTRepo shr rp mb vcs diff)) + | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff) + targetRelevance _ = Nothing sharerOfferDepF :: UTCTime