S2S: Implement patch submission via repoOfferTicketF

src/Vervis/Federation.hs

@@ -377,6 +377,8 @@ handleRepoInbox shrRecip rpRecip now auth body = do
             (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow
         OfferActivity (Offer obj target) ->
             case obj of
+                OfferTicket ticket ->
+                    (,Nothing) <$> repoOfferTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket target
                 OfferDep dep ->
                     repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
                 _ -> return ("Unsupported offer object type for repos", Nothing)

src/Vervis/Federation/Ticket.hs

@@ -16,6 +16,7 @@
 module Vervis.Federation.Ticket
     ( sharerOfferTicketF
     , projectOfferTicketF
+    , repoOfferTicketF
 
     , sharerCreateTicketF
     , projectCreateTicketF
@@ -62,7 +63,7 @@ import qualified Data.Text.Lazy as TL
 
 import Database.Persist.JSON
 import Network.FedURI
-import Web.ActivityPub hiding (Ticket (..))
+import Web.ActivityPub hiding (Patch, Ticket (..))
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
@@ -185,7 +186,15 @@ checkOfferTicket author ticket uTarget = do
             case branch of
                 Left (shr', rp', mb) | shr == shr' && rp == rp' -> return mb
                 _ -> throwE "MR target repo/branch and Offer target repo mismatch"
-        return $ Left $ WTTRepo shr rp branch' (typ2vcs typ) content
+        let vcs = typ2vcs typ
+        case vcs of
+            VCSDarcs ->
+                unless (isNothing branch') $
+                    throwE "Darcs MR specifies a branch"
+            VCSGit ->
+                unless (isJust branch') $
+                    throwE "Git MR doesn't specify the branch"
+        return $ Left $ WTTRepo shr rp branch' vcs content
         where
         typ2vcs PatchTypeDarcs = VCSDarcs
     matchTargetAndMR (Right (ObjURI h lu)) Nothing = return $ Right (h, lu, Nothing)
@@ -235,6 +244,37 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do
             Nothing -> "Activity already exists in my inbox"
             Just _ -> "Activity inserted to my inbox"
 
+insertLocalTicket now author txl summary content source ractidOffer obiidAccept = do
+    did <- insert Discussion
+    fsid <- insert FollowerSet
+    tid <- insert Ticket
+        { ticketNumber      = Nothing
+        , ticketCreated     = now
+        , ticketTitle       = unTextHtml summary
+        , ticketSource      = unTextPandocMarkdown source
+        , ticketDescription = unTextHtml content
+        , ticketAssignee    = Nothing
+        , ticketStatus      = TSNew
+        , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
+        , ticketCloser      = Nothing
+        }
+    ltid <- insert LocalTicket
+        { localTicketTicket    = tid
+        , localTicketDiscuss   = did
+        , localTicketFollowers = fsid
+        }
+    tclid <- insert TicketContextLocal
+        { ticketContextLocalTicket = tid
+        , ticketContextLocalAccept = obiidAccept
+        }
+    insert_ $ txl tclid
+    insert_ TicketAuthorRemote
+        { ticketAuthorRemoteTicket = tclid
+        , ticketAuthorRemoteAuthor = remoteAuthorId author
+        , ticketAuthorRemoteOpen   = ractidOffer
+        }
+    return (tid, ltid)
+
 projectOfferTicketF
     :: UTCTime
     -> ShrIdent
@@ -269,7 +309,7 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
                 (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
             (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
                 obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
-                ltid <- insertTicket now author jid summary content source ractid obiidAccept
+                (_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept
                 (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
                     insertAccept shrRecip prjRecip author luOffer ltid obiidAccept
                 knownRemoteRecipsAccept <-
@@ -301,39 +341,6 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
     targetRelevance (Left (WTTProject shr prj))
         | shr == shrRecip && prj == prjRecip = Just ()
     targetRelevance _ = Nothing
-    insertTicket now author jid summary content source ractidOffer obiidAccept = do
-        did <- insert Discussion
-        fsid <- insert FollowerSet
-        tid <- insert Ticket
-            { ticketNumber      = Nothing
-            , ticketCreated     = now
-            , ticketTitle       = unTextHtml summary
-            , ticketSource      = unTextPandocMarkdown source
-            , ticketDescription = unTextHtml content
-            , ticketAssignee    = Nothing
-            , ticketStatus      = TSNew
-            , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
-            , ticketCloser      = Nothing
-            }
-        ltid <- insert LocalTicket
-            { localTicketTicket    = tid
-            , localTicketDiscuss   = did
-            , localTicketFollowers = fsid
-            }
-        tclid <- insert TicketContextLocal
-            { ticketContextLocalTicket = tid
-            , ticketContextLocalAccept = obiidAccept
-            }
-        insert_ TicketProjectLocal
-            { ticketProjectLocalContext = tclid
-            , ticketProjectLocalProject = jid
-            }
-        insert_ TicketAuthorRemote
-            { ticketAuthorRemoteTicket = tclid
-            , ticketAuthorRemoteAuthor = remoteAuthorId author
-            , ticketAuthorRemoteOpen   = ractidOffer
-            }
-        return ltid
     insertAccept shr prj author luOffer ltid obiidAccept = do
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
@@ -375,6 +382,116 @@ projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarge
         update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (doc, recipientSet, remoteActors, fwdHosts)
 
+repoOfferTicketF
+    :: UTCTime
+    -> ShrIdent
+    -> RpIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (LocalRecipientSet, ByteString)
+    -> LocalURI
+    -> AP.Ticket URIMode
+    -> FedURI
+    -> ExceptT Text Handler Text
+repoOfferTicketF now shrRecip rpRecip author body mfwd luOffer ticket uTarget = do
+    (target, summary, content, source) <- checkOfferTicket author ticket uTarget
+    mmhttp <- for (targetRelevance target) $ \ (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) luOffer False
+        lift $ for mractid $ \ ractid -> 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
+            (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
+                obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
+                let makeTRL tclid = TicketRepoLocal tclid rid mb
+                (tid, ltid) <- insertLocalTicket now author makeTRL summary content source ractid obiidAccept
+                insert_ $ Patch tid now diff
+                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                    insertAccept shrRecip rpRecip author luOffer ltid obiidAccept
+                knownRemoteRecipsAccept <-
+                    deliverLocal'
+                        False
+                        (LocalActorRepo shrRecip rpRecip)
+                        (repoInbox r)
+                        obiidAccept
+                        localRecipsAccept
+                (obiidAccept,docAccept,fwdHostsAccept,) <$>
+                    deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
+            return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
+    case mmhttp of
+        Nothing -> return "Offer target isn't me, not using"
+        Just mhttp ->
+            case mhttp of
+                Nothing -> return "Activity already in my inbox, doing nothing"
+                Just (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
+                    for_ mremotesHttpFwd $ \ (sig, remotes) ->
+                        forkWorker "repoOfferTicketF inbox-forwarding" $
+                            deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
+                    forkWorker "repoOfferTicketF Accept HTTP delivery" $
+                        deliverRemoteHttp' fwdHosts obiid doc remotes
+                    return $
+                        case mremotesHttpFwd of
+                            Nothing -> "Accepted new patch, no inbox-forwarding to do"
+                            Just _ -> "Accepted new patch and ran inbox-forwarding of the Offer"
+    where
+    targetRelevance (Left (WTTRepo shr rp mb vcs diff))
+        | shr == shrRecip && rp == rpRecip = Just (mb, vcs, diff)
+    targetRelevance _ = Nothing
+    insertAccept shr rp author luOffer ltid obiidAccept = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+
+        hLocal <- asksSite siteInstanceHost
+
+        obikhidAccept <- encodeKeyHashid obiidAccept
+        ltkhid <- encodeKeyHashid ltid
+
+        ra <- getJust $ remoteAuthorId author
+
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+            audAuthor =
+                AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
+            audProject =
+                AudLocal []
+                    [ LocalPersonCollectionRepoTeam shr rp
+                    , LocalPersonCollectionRepoFollowers shr rp
+                    ]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audAuthor, audProject]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = Doc hLocal Activity
+                { activityId       =
+                    Just $ encodeRouteLocal $
+                        RepoOutboxItemR shr rp obikhidAccept
+                , activityActor    = encodeRouteLocal $ RepoR shr rp
+                , activitySummary  = Nothing
+                , activityAudience = Audience recips [] [] [] [] []
+                , activitySpecific = AcceptActivity Accept
+                    { acceptObject = ObjURI hAuthor luOffer
+                    , acceptResult =
+                        Just $ encodeRouteLocal $ RepoPatchR shr rp ltkhid
+                    }
+                }
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
 checkCreateTicket
     :: RemoteAuthor
     -> AP.Ticket URIMode