S2S: Repos now accept remotely hosted patches via Create/Ticket

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

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
+repoCreateTicketF
-
+    :: UTCTime
-        obikhidAccept <- encodeKeyHashid obiidAccept
+    -> ShrIdent
-
+    -> RpIdent
-        ra <- getJust $ remoteAuthorId author
+    -> RemoteAuthor
-
+    -> ActivityBody
-        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+    -> Maybe (LocalRecipientSet, ByteString)
-
+    -> LocalURI
-            audAuthorAndTicket =
+    -> AP.Ticket URIMode
-                AudRemote hAuthor [luAuthor] $ catMaybes
+    -> Maybe FedURI
-                    [ remoteActorFollowers ra
+    -> ExceptT Text Handler Text
-                    , Just $ AP.ticketParticipants tlocal
+repoCreateTicketF now shrRecip rpRecip author body mfwd luCreate ticket muTarget = do
-                    ]
+    ParsedCreateTicket targetAndContext tlocal published title desc src <-
-            audProject =
+        checkCreateTicket author ticket muTarget
-                AudLocal []
+    mmhttp <- for (targetRelevance targetAndContext) $ \ (mb, vcs, _diff) -> runDBExcept $ do
-                    [ LocalPersonCollectionProjectTeam shr prj
+        Entity rid r <- lift $ do
-                    , LocalPersonCollectionProjectFollowers shr prj
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-                    ]
+            getBy404 $ UniqueRepo rpRecip sid
-
+        unless (repoVcs r == vcs) $ throwE "Patch type and repo VCS mismatch"
-            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+        mractid <- lift $ insertToInbox now author body (repoInbox r) luCreate False
-                collectAudience [audAuthorAndTicket, audProject]
+        lift $ for mractid $ \ ractid -> do
-
+            obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
-            recips = map encodeRouteHome audLocal ++ audRemote
+            let mkTRL tclid = TicketRepoLocal tclid rid mb
-            doc = Doc hLocal Activity
+            result <- insertRemoteTicket mkTRL author (AP.ticketId tlocal) published title desc src ractid obiidAccept
-                { activityId       =
+            unless (isRight result) $ delete obiidAccept
-                    Just $ encodeRouteLocal $
+            for result $ \ () -> do
-                        ProjectOutboxItemR shr prj obikhidAccept
+                mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
-                , activityActor    = encodeRouteLocal $ ProjectR shr prj
+                    let sieve =
-                , activitySummary  = Nothing
+                            makeRecipientSet
-                , activityAudience = Audience recips [] [] [] [] []
+                                []
-                , activitySpecific = AcceptActivity Accept
+                                [ LocalPersonCollectionRepoTeam shrRecip rpRecip
-                    { acceptObject = ObjURI hAuthor luCreate
+                                , LocalPersonCollectionRepoFollowers shrRecip rpRecip
-                    , acceptResult = Nothing
+                                ]
-                    }
+                    remoteRecips <-
-                }
+                        insertRemoteActivityToLocalInboxes
-        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+                            False ractid $
-        return (doc, recipientSet, remoteActors, fwdHosts)
+                                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