S2S: loomOfferTicketF, open MR sent by remote author

src/Vervis/API.hs

@@ -62,7 +62,6 @@ import Network.HTTP.Client
 import System.Directory
 import System.Exit
 import System.FilePath
-import System.IO.Temp
 import System.Process.Typed
 import Text.Blaze.Html.Renderer.Text
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
@@ -103,6 +102,7 @@ import Vervis.Data.Collab
 import Vervis.Data.Ticket
 import Vervis.Delivery
 import Vervis.FedURI
+import Vervis.Fetch
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -118,6 +118,7 @@ import Vervis.Settings
 import Vervis.Query
 import Vervis.Ticket
 import Vervis.WorkItem
+import Vervis.Web.Repo
 
 verifyResourceAddressed
     :: (MonadSite m, YesodHashids (SiteEnv m))
@@ -2242,13 +2243,6 @@ followC (Entity pidSender personSender) summary audience follow@(AP.Follow uObje
         ibiid <- insert $ InboxItem True now
         insert_ $ InboxItemLocal ibidAuthor obiidAccept ibiid
 
-data Result
-    = ResultSomeException SomeException
-    | ResultIdMismatch
-    | ResultGetError APGetError
-    | ResultNotActor
-    deriving Show
-
 inviteC
     :: Entity Person
     -> Actor
@@ -2774,66 +2768,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
 
     where
 
-    fetchRepoE h lu = do
-        manager <- asksSite getHttpManager
-        let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
-        ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
-            fetchAPID' manager apRepoId h lu
-
-    insertRemoteActor h lu (AP.Actor local detail) = do
-        iid <- either entityKey id <$> insertBy' (Instance h)
-        roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
-        let ra = RemoteActor
-                { remoteActorIdent      = roid
-                , remoteActorName       =
-                    AP.actorName detail <|> AP.actorUsername detail
-                , remoteActorInbox      = AP.actorInbox local
-                , remoteActorFollowers  = AP.actorFollowers local
-                , remoteActorErrorSince = Nothing
-                }
-        either entityKey id <$> insertBy' ra
-
-    httpGetRemoteTip
-        :: FedURI
-        -> ExceptT Result Handler
-            ( VersionControlSystem
-            , RemoteActorId
-            , FedURI
-            , Maybe (LocalURI, Text)
-            )
-    httpGetRemoteTip (ObjURI host localURI) = do
-        repoOrBranch <- fetchTipE host localURI
-        case repoOrBranch of
-            Left repo -> do
-                remoteActorID <-
-                    lift $ runSiteDB $
-                        insertRemoteActor host localURI $ AP.repoActor repo
-                let uClone = ObjURI host $ NE.head $ AP.repoClone repo
-                return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
-            Right (AP.Branch name _ luRepo) -> do
-                repo <- fetchRepoE host luRepo
-                remoteActorID <-
-                    lift $ runSiteDB $
-                        insertRemoteActor host luRepo $ AP.repoActor repo
-                let uClone = ObjURI host $ NE.head $ AP.repoClone repo
-                return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
-        where
-        fetchTipE h lu = do
-            manager <- asksSite getHttpManager
-            ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
-                fetchTip manager h lu
-
-    httpGetRemoteRepo
-        :: FedURI
-        -> ExceptT Result Handler (VersionControlSystem, RemoteActorId, FedURI)
-    httpGetRemoteRepo (ObjURI host localURI) = do
-        repo <- fetchRepoE host localURI
-        remoteActorID <-
-            lift $ runSiteDB $
-                insertRemoteActor host localURI $ AP.repoActor repo
-        let uClone = ObjURI host $ NE.head $ AP.repoClone repo
-        return (AP.repoVcs repo, remoteActorID, uClone)
-
     insertOfferToOutbox senderHash blinded offerID = do
         encodeRouteLocal <- getEncodeRouteLocal
         hLocal <- asksSite siteInstanceHost
@@ -2943,79 +2877,6 @@ offerTicketC (Entity senderPersonID senderPerson) senderActor summary audience t
         update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return doc
 
-    runProcessE name spec = do
-        exitCode <- runProcess spec
-        case exitCode of
-            ExitFailure n ->
-                throwE $
-                    T.concat
-                        [ "`", name, "` failed with exit code "
-                        , T.pack (show n)
-                        ]
-            ExitSuccess -> return ()
-
-    readProcessE name spec = do
-        (exitCode, out) <- readProcessStdout spec
-        case exitCode of
-            ExitFailure n ->
-                throwE $
-                    T.concat
-                        [ "`", name, "` failed with exit code "
-                        , T.pack (show n)
-                        ]
-            ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out
-
-    generateGitPatches :: FilePath -> String -> String -> String -> FilePath -> ExceptT Text IO (NonEmpty Text)
-    generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do
-        runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--origin", "target", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir]
-        runProcessE "git remote add" $ proc "git" ["-C", tempDir, "remote", "--verbose", "add", "-t", originBranch, "real-origin", originRepoURI]
-        runProcessE "git fetch" $ proc "git" ["-C", tempDir, "fetch", "real-origin", originBranch]
-        runProcessE "git merge-base --is-ancestor" $ proc "git" ["-C", tempDir, "merge-base", "--is-ancestor", targetBranch, "real-origin/" ++ originBranch]
-        patchFileNames <- do
-            names <- T.lines <$> readProcessE "git format-patch" (proc "git" ["-C", tempDir, "format-patch", targetBranch ++ "..real-origin/" ++ originBranch])
-            fromMaybeE (NE.nonEmpty names) "No new patches found in origin branch"
-        for patchFileNames $ \ name -> do
-            b <- lift $ B.readFile $ tempDir </> T.unpack name
-            case TE.decodeUtf8' b of
-                Left e -> throwE $ T.concat
-                    [ "UTF-8 decoding error while reading Git patch file "
-                    , name, ": " , T.pack $ displayException e
-                    ]
-                Right t -> return t
-
-    generatePatches
-        :: ( TicketLoomId
-           , RepoId
-           , Bool
-           , Either
-                (Text, (Either RepoId FedURI, Text))
-                (Either RepoId FedURI)
-           )
-        -> ExceptT Text Handler ()
-    generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do
-        patches <-
-            case tipInfo of
-                Right _ -> error "Auto-pulling from Darcs remote origin not supported yet"
-                Left (targetBranch, (originRepo, originBranch)) -> do
-                    targetPath <- do
-                        repoHash <- encodeKeyHashid targetRepoID
-                        repoDir <- askRepoDir repoHash
-                        liftIO $ makeAbsolute repoDir
-                    originURI <-
-                        case originRepo of
-                            Left repoID -> do
-                                repoHash <- encodeKeyHashid repoID
-                                repoDir <- askRepoDir repoHash
-                                liftIO $ makeAbsolute repoDir
-                            Right uClone -> pure $ T.unpack $ renderObjURI uClone
-                    ExceptT $ liftIO $ runExceptT $
-                        withSystemTempDirectory "vervis-generatePatches" $
-                            generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch)
-        now <- liftIO getCurrentTime
-        lift $ runDB $ do
-            bundleID <- insert $ Bundle clothID True
-            insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
-
 {-
 verifyHosterRecip _           _    (Right _) = return ()
 verifyHosterRecip localRecips name (Left wi) =

src/Vervis/Federation/Ticket.hs

@@ -16,7 +16,7 @@
 module Vervis.Federation.Ticket
     ( --personOfferTicketF
       deckOfferTicketF
-    --, repoOfferTicketF
+    , loomOfferTicketF
 
     --, repoAddBundleF
 
@@ -40,6 +40,8 @@ import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
 import Data.Aeson
+import Data.Align
+import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.ByteString (ByteString)
@@ -50,6 +52,7 @@ import Data.List (nub, union)
 import Data.List.NonEmpty (NonEmpty (..))
 import Data.Maybe
 import Data.Text (Text)
+import Data.These
 import Data.Time.Calendar
 import Data.Time.Clock
 import Data.Traversable
@@ -94,9 +97,10 @@ import Vervis.Cloth
 import Vervis.Data.Ticket
 import Vervis.Darcs
 import Vervis.Delivery
-import Vervis.FedURI
 import Vervis.Federation.Auth
 import Vervis.Federation.Util
+import Vervis.FedURI
+import Vervis.Fetch
 import Vervis.Foundation
 import Vervis.Git
 import Vervis.Model
@@ -106,6 +110,7 @@ import Vervis.Path
 import Vervis.Query
 import Vervis.Recipient
 import Vervis.Ticket
+import Vervis.Web.Repo
 import Vervis.WorkItem
 
 {-
@@ -494,6 +499,365 @@ deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
         update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
         return (doc, recipientSet, remoteActors, fwdHosts)
 
+loomOfferTicketF
+    :: UTCTime
+    -> KeyHashid Loom
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Maybe (RecipientRoutes, ByteString)
+    -> LocalURI
+    -> AP.Ticket URIMode
+    -> FedURI
+    -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
+loomOfferTicketF now recipLoomHash author body mfwd luOffer ticket uTarget = do
+
+    -- Check input
+    recipLoomID <- decodeKeyHashid404 recipLoomHash
+    (title, desc, source, originTipOrBundle, targetRepoID, maybeTargetBranch) <- do
+        let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
+        WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
+        unless (wioAuthor == Right (remoteAuthorURI author)) $
+            throwE "Offering a Ticket attributed to someone else"
+        Merge maybeOriginTip maybeBundle targetTip <- case wioRest of
+            TAM_Task _ ->
+                throwE
+                    "Offer target is some local deck, so I have no use for \
+                    \this Offer. Was I supposed to receive it?"
+            TAM_Merge loomID merge ->
+                if loomID == recipLoomID
+                    then return merge
+                    else throwE
+                            "Offer target is some other local loom, so I have \
+                            \no use for this Offer. Was I supposed to receive \
+                            \it?"
+            TAM_Remote _ _ ->
+                throwE
+                    "Offer target is some remote tracker, so I have no use \
+                    \for this Offer. Was I supposed to receive it?"
+        originTipOrBundle <-
+            fromMaybeE
+                (align maybeOriginTip maybeBundle)
+                "MR provides neither origin nor patches"
+        (targetRepoID, maybeTargetBranch) <-
+            case targetTip of
+                TipLocalRepo repoID -> pure (repoID, Nothing)
+                TipLocalBranch repoID branch -> pure (repoID, Just branch)
+                _ -> throwE "MR target is a remote repo (this tracker serves only local repos)"
+        return (wioTitle, wioDesc, wioSource, originTipOrBundle, targetRepoID, maybeTargetBranch)
+
+    -- Soon we're going to proceed asynchronously to be able to HTTP GET the
+    -- origin repo AP object, because:
+    --
+    --      * No support for providing a signed repo object directly in the
+    --        Offer activity
+    --      * It may be nice to make sure a remote origin repo's VCS type
+    --        matches the target repo's VCS, even if patches are provided too
+    --          + However there's no support for caching VCS type when
+    --            remembering remote repo in our DB, so we'd have to check this
+    --            every time
+    --      * If origin is remote and no patches are provided, we'll need to
+    --        know the clone URL to generate the patches ourselves
+    --          + However the code here, for some simplicity, doesn't have a
+    --            way to skip that and do the whole handler synchronously in
+    --            case patches are provided or the origin is a local repo
+    --          + And no support for caching the clone URI in DB when
+    --            remembering the remote repo, so we'd need to do this every
+    --            time
+    --
+    -- So first let's do some checks using the DB, on the loom, on the target
+    -- repo (which is always local), and on the origin repo if it's local
+    (recipLoomRepoID, Entity recipLoomActorID recipLoomActor, alreadyInInbox) <- lift $ runDB $ do
+
+        -- Find recipient loom in DB, returning 404 if doesn't exist because
+        -- we're in the loom's inbox post handler
+        (recipLoomRepoID, recipLoomActor@(Entity _ actor)) <- do
+            loom <- get404 recipLoomID
+            let actorID = loomActor loom
+            (loomRepo loom,) . Entity actorID <$> getJust actorID
+
+        -- Has the loom already received this activity to its inbox? If yes, we
+        -- won't process it again
+        maybeAlreadyInInbox <- runMaybeT $ do
+            instanceID <- MaybeT $ getKeyBy $ UniqueInstance $ objUriAuthority $ remoteAuthorURI author
+            remoteObjectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID luOffer
+            remoteActivityID <- MaybeT $ getKeyBy $ UniqueRemoteActivity remoteObjectID
+            MaybeT $ getBy $ UniqueInboxItemRemote (actorInbox actor) remoteActivityID
+
+        return (recipLoomRepoID, recipLoomActor, isJust maybeAlreadyInInbox)
+
+    if alreadyInInbox
+        then return ("I already have this activity in my inbox, ignoring", Nothing)
+        else do
+            (targetRepoVCS, originOrBundle) <- runDBExcept $ do
+
+                -- Grab loom's repo from DB and verify that it consents to be served by
+                -- the loom, otherwise this loom doesn't accept tickets
+                unless (targetRepoID == recipLoomRepoID) $
+                    throwE "MR target repo isn't the one served by the Offer target loom"
+                targetRepo <- lift $ getJust targetRepoID
+                unless (repoLoom targetRepo == Just recipLoomID) $
+                    throwE "Offer target loom doesn't have repo's consent to serve it"
+
+                -- Verify VCS type match between patch bundle and target repo
+                for_ (justThere originTipOrBundle) $ \ (Material typ diffs) -> do
+                    unless (repoVcs targetRepo == patchMediaTypeVCS typ) $
+                        throwE "Patch type and local target repo VCS mismatch"
+                    case (typ, diffs) of
+                        (PatchMediaTypeDarcs, _ :| _ : _) ->
+                            throwE "More than one Darcs dpatch file provided"
+                        _ -> pure ()
+
+                -- If origin repo is local, find it in our DB and verify its VCS type
+                -- matches the target repo
+                originOrBundle <- flip (bifor originTipOrBundle) pure $ \ originTip -> do
+                    let origin =
+                            case originTip of
+                                TipLocalRepo repoID -> Left (repoID, Nothing)
+                                TipLocalBranch repoID branch -> Left (repoID, Just branch)
+                                TipRemote uOrigin -> Right (uOrigin, Nothing)
+                                TipRemoteBranch uRepo branch -> Right (uRepo, Just branch)
+                    bitraverse_
+                        (\ (repoID, maybeBranch) -> do
+                            repo <- getE repoID "MR origin local repo not found in DB"
+                            unless (repoVcs repo == repoVcs targetRepo) $
+                                throwE "Local origin repo VCS differs from target repo VCS"
+                        )
+                        pure
+                        origin
+                    return origin
+
+                return (repoVcs targetRepo, originOrBundle)
+
+            return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do
+
+                -- If origin repo is remote, HTTP GET its AP representation and
+                -- remember it in our DB
+                originOrBundle' <-
+                    bitraverse
+                        (bitraverse
+                            pure
+                            (\ (uOrigin, maybeOriginBranch) -> do
+                                (vcs, remoteOrigin) <-
+                                    case maybeOriginBranch of
+                                        Nothing -> do
+                                            (vcs, raid, uClone, mb) <- withExceptT (T.pack . show) $ httpGetRemoteTip uOrigin
+                                            return (vcs, (raid, uClone, first Just <$> mb))
+                                        Just branch -> do
+                                            (vcs, raid, uClone) <- withExceptT (T.pack . show) $ httpGetRemoteRepo uOrigin
+                                            return (vcs, (raid, uClone, Just (Nothing, branch)))
+                                unless (vcs == targetRepoVCS) $
+                                    throwE "Remote origin repo VCS differs from target repo VCS"
+                                return remoteOrigin
+                            )
+                        )
+                        pure
+                        originOrBundle
+
+                -- Verify that branches are specified for Git and aren't specified for
+                -- Darcs
+                -- Also, produce a data structure separating by VCS rather than by
+                -- local/remote origin, which we'll need for generating patches
+                tipInfo <- case targetRepoVCS of
+                    VCSGit -> do
+                        targetBranch <- fromMaybeE maybeTargetBranch "Local target repo is Git but no target branch specified"
+                        maybeOrigin <- for (justHere originOrBundle') $ \case
+                            Left (originRepoID, maybeOriginBranch) -> do
+                                originBranch <- fromMaybeE maybeOriginBranch "Local origin repo is Git but no origin branch specified"
+                                return (Left originRepoID, originBranch)
+                            Right (_remoteActorID, uClone, maybeOriginBranch) -> do
+                                (_maybeURI, originBranch) <- fromMaybeE maybeOriginBranch "Remote origin repo is Git but no origin branch specified"
+                                return (Right uClone, originBranch)
+                        return $ Left (targetBranch, maybeOrigin)
+                    VCSDarcs -> do
+                        verifyNothingE maybeTargetBranch "Local target repo is Darcs but target branch specified"
+                        maybeOriginRepo <- for (justHere originOrBundle') $ \case
+                            Left (originRepoID, maybeOriginBranch) -> do
+                                verifyNothingE maybeOriginBranch "Local origin repo is Darcs but origin branch specified"
+                                return $ Left originRepoID
+                            Right (_remoteActorID, uClone, maybeOriginBranch) -> do
+                                verifyNothingE maybeOriginBranch "Remote origin repo is Darcs but origin branch specified"
+                                return $ Right uClone
+                        return $ Right $ maybeOriginRepo
+
+                maybeHttp <- lift $ runSiteDB $ do
+
+                    -- Insert the Offer to loom's inbox
+                    mractid <- insertToInbox now author body (actorInbox recipLoomActor) luOffer False
+                    for mractid $ \ offerID -> do
+
+                        -- Forward the Offer activity to relevant local stages, and
+                        -- schedule delivery for unavailable remote members of them
+                        maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
+                            let sieve =
+                                    makeRecipientSet
+                                        []
+                                        [LocalStageLoomFollowers recipLoomHash]
+                            remoteRecips <-
+                                insertRemoteActivityToLocalInboxes False offerID $
+                                    localRecipSieve' sieve False False localRecips
+                            remoteRecipsHttp <-
+                                deliverRemoteDB_L
+                                    (actbBL body) offerID recipLoomID sig remoteRecips
+                            return $
+                                deliverRemoteHTTP_L
+                                    now recipLoomHash (actbBL body) sig remoteRecipsHttp
+
+                        -- Insert the new ticket to our DB
+                        acceptID <- insertEmptyOutboxItem (actorOutbox recipLoomActor) now
+                        ticketID <- insertTicket now title desc source offerID acceptID
+                        clothID <- insertMerge recipLoomID ticketID maybeTargetBranch originOrBundle'
+                        let maybePull =
+                                let maybeTipInfo =
+                                        case tipInfo of
+                                            Left (b, mo) -> Left . (b,) <$> mo
+                                            Right mo -> Right <$> mo
+                                    hasBundle = isJust $ justThere originOrBundle'
+                                in  (clothID, targetRepoID, hasBundle,) <$> maybeTipInfo
+
+                        -- Prepare an Accept activity and insert to loom's outbox
+                        (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
+                            insertAcceptToOutbox clothID acceptID
+
+                        -- Deliver the Accept to local recipients, and schedule delivery
+                        -- for unavailable remote recipients
+                        knownRemoteRecipsAccept <-
+                            deliverLocal'
+                                False (LocalActorLoom recipLoomHash) recipLoomActorID
+                                acceptID localRecipsAccept
+                        remoteRecipsHttpAccept <-
+                            deliverRemoteDB''
+                                fwdHostsAccept acceptID remoteRecipsAccept
+                                knownRemoteRecipsAccept
+
+                        -- Return instructions for HTTP inbox-forwarding of the Offer
+                        -- activity, and for HTTP delivery of the Accept activity to
+                        -- remote recipients, and for generating patches from
+                        -- the origin repo
+                        return
+                            ( maybeHttpFwdOffer
+                            , deliverRemoteHttp'
+                                fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
+                            , maybePull
+                            )
+
+                -- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
+                -- delivery of the Accept activity, and generate patches if we opened
+                -- a local MR that mentions just an origin
+                case maybeHttp of
+                    Nothing ->
+                        return
+                            "When I started serving this activity, I didn't have it in my inbox, \
+                            \but now suddenly it seems I already do, so ignoring"
+                    Just (maybeHttpFwdOffer, deliverHttpAccept, maybePull) -> do
+                        forkWorker "loomOfferTicketF Accept HTTP delivery" deliverHttpAccept
+                        traverse generatePatches maybePull
+                        case maybeHttpFwdOffer of
+                            Nothing -> return "Opened a merge request, no inbox-forwarding to do"
+                            Just forwardHttpOffer -> do
+                                forkWorker "loomOfferTicketF inbox-forwarding" forwardHttpOffer
+                                return "Opened a merge request and ran inbox-forwarding of the Offer"
+
+    where
+
+    insertTicket now title desc source offerID acceptID = do
+        did <- insert Discussion
+        fsid <- insert FollowerSet
+        tid <- insert Ticket
+            { ticketNumber      = Nothing
+            , ticketCreated     = now
+            , ticketTitle       = title
+            , ticketSource      = source
+            , ticketDescription = desc
+            , ticketStatus      = TSNew
+            , ticketDiscuss     = did
+            , ticketFollowers   = fsid
+            , ticketAccept      = acceptID
+            }
+        insert_ TicketAuthorRemote
+            { ticketAuthorRemoteTicket = tid
+            , ticketAuthorRemoteAuthor = remoteAuthorId author
+            , ticketAuthorRemoteOpen   = offerID
+            }
+        return tid
+
+    insertMerge
+        :: LoomId
+        -> TicketId
+        -> Maybe Text
+        -> These
+            (Either
+                (RepoId, Maybe Text)
+                (RemoteActorId, FedURI, Maybe (Maybe LocalURI, Text))
+            )
+            Material
+        -> WorkerDB TicketLoomId
+    insertMerge loomID ticketID maybeTargetBranch originOrBundle = do
+        clothID <- insert $ TicketLoom ticketID loomID maybeTargetBranch
+        for_ (justHere originOrBundle) $ \case
+            Left (repoID, maybeOriginBranch) ->
+                insert_ $ MergeOriginLocal clothID repoID maybeOriginBranch
+            Right (remoteActorID, _uClone, maybeOriginBranch) -> do
+                originID <- insert $ MergeOriginRemote clothID remoteActorID
+                for_ maybeOriginBranch $ \ (mlu, b) ->
+                    insert_ $ MergeOriginRemoteBranch originID mlu b
+        for_ (justThere originOrBundle) $ \ (Material typ diffs) -> do
+            bundleID <- insert $ Bundle clothID False
+            insertMany_ $ NE.toList $ NE.reverse $
+                NE.map (Patch bundleID now typ) diffs
+        return clothID
+
+    insertAcceptToOutbox
+        :: TicketLoomId
+        -> OutboxItemId
+        -> WorkerDB
+            ( AP.Doc AP.Activity URIMode
+            , RecipientRoutes
+            , [(Host, NonEmpty LocalURI)]
+            , [Host]
+            )
+    insertAcceptToOutbox clothID acceptID = do
+        encodeRouteLocal <- getEncodeRouteLocal
+        encodeRouteHome <- getEncodeRouteHome
+        hLocal <- asksSite siteInstanceHost
+
+        clothHash <- encodeKeyHashid clothID
+        acceptHash <- encodeKeyHashid acceptID
+
+        ra <- getJust $ remoteAuthorId author
+
+        let ObjURI hAuthor luAuthor = remoteAuthorURI author
+
+            audSender =
+                AudRemote hAuthor
+                    [luAuthor]
+                    (maybeToList $ remoteActorFollowers ra)
+            audTracker = AudLocal [] [LocalStageLoomFollowers recipLoomHash]
+
+            (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                collectAudience [audSender, audTracker]
+
+            recips = map encodeRouteHome audLocal ++ audRemote
+            doc = AP.Doc hLocal AP.Activity
+                { AP.activityId         =
+                    Just $ encodeRouteLocal $
+                        LoomOutboxItemR recipLoomHash acceptHash
+                , AP.activityActor      =
+                    encodeRouteLocal $ LoomR recipLoomHash
+                , AP.activityCapability = Nothing
+                , AP.activitySummary    = Nothing
+                , AP.activityAudience   = AP.Audience recips [] [] [] [] []
+                , AP.activityFulfills   = []
+                , AP.activitySpecific   = AP.AcceptActivity AP.Accept
+                    { acceptObject = ObjURI hAuthor luOffer
+                    , acceptResult =
+                        Just $ encodeRouteLocal $
+                            ClothR recipLoomHash clothHash
+                    }
+                }
+
+        update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        return (doc, recipientSet, remoteActors, fwdHosts)
+
 repoOfferTicketF
     :: UTCTime
     -> KeyHashid Repo

src/Vervis/Fetch.hs

@@ -0,0 +1,181 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2022 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ Copying is an act of love. Please copy, reuse and share.
+ -
+ - The author(s) have dedicated all copyright and related and neighboring
+ - rights to this software to the public domain worldwide. This software is
+ - distributed without any warranty.
+ -
+ - You should have received a copy of the CC0 Public Domain Dedication along
+ - with this software. If not, see
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+module Vervis.Fetch
+    ( Result (..)
+    , httpGetRemoteTip
+    , httpGetRemoteRepo
+    )
+where
+
+import Control.Applicative
+import Control.Exception.Base
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Except
+import Control.Monad.Trans.Maybe
+import Control.Monad.Trans.Reader
+import Data.Align
+import Data.Barbie
+import Data.Bifunctor
+import Data.Bifoldable
+import Data.Bitraversable
+import Data.Foldable
+import Data.Functor
+import Data.Functor.Identity
+import Data.List.NonEmpty (NonEmpty (..))
+import Data.Maybe
+import Data.Text (Text)
+import Data.These
+import Data.Time.Clock
+import Data.Traversable
+import Database.Persist hiding (deleteBy)
+import Database.Persist.Sql hiding (deleteBy)
+import Network.HTTP.Client
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Temp
+import System.Process.Typed
+import Text.Blaze.Html.Renderer.Text
+import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
+import Yesod.Persist.Core
+
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+import qualified Data.Text.Lazy as TL
+
+import Database.Persist.JSON
+import Development.PatchMediaType
+import Network.FedURI
+import Web.ActivityPub hiding (Patch, Ticket, Follow, Repo (..), ActorLocal (..), ActorDetail (..), Actor (..))
+import Web.Text
+import Yesod.ActivityPub
+import Yesod.FedURI
+import Yesod.Hashids
+import Yesod.MonadSite
+
+import qualified Web.ActivityPub as AP
+
+import Control.Monad.Trans.Except.Local
+import Data.Either.Local
+import Database.Persist.Local
+
+import qualified Data.Git.Local as G (createRepo)
+import qualified Data.Text.UTF8.Local as TU
+import qualified Darcs.Local.Repository as D (createRepo)
+
+import Vervis.Access
+import Vervis.ActivityPub
+import Vervis.Cloth
+import Vervis.Data.Actor
+import Vervis.Data.Collab
+import Vervis.Data.Ticket
+import Vervis.Delivery
+import Vervis.FedURI
+import Vervis.Foundation
+import Vervis.Model
+import Vervis.Model.Ident
+import Vervis.Model.Role
+import Vervis.Model.Workflow
+import Vervis.Model.Ticket
+import Vervis.Path
+import Vervis.Persist.Actor
+import Vervis.Persist.Collab
+import Vervis.Recipient
+import Vervis.RemoteActorStore
+import Vervis.Settings
+import Vervis.Query
+import Vervis.Ticket
+import Vervis.WorkItem
+
+data Result
+    = ResultSomeException SomeException
+    | ResultIdMismatch
+    | ResultGetError APGetError
+    | ResultNotActor
+    deriving Show
+
+fetchRepoE :: (MonadSite m, SiteEnv m ~ App) => Host -> LocalURI -> ExceptT Result m (AP.Repo URIMode)
+fetchRepoE h lu = do
+    manager <- asksSite getHttpManager
+    let apRepoId = AP.actorId . AP.actorLocal . AP.repoActor
+    ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
+        fetchAPID' manager apRepoId h lu
+
+insertRemoteActor
+    :: MonadIO m
+    => Host
+    -> LocalURI
+    -> AP.Actor URIMode
+    -> ReaderT SqlBackend m RemoteActorId
+insertRemoteActor h lu (AP.Actor local detail) = do
+    iid <- either entityKey id <$> insertBy' (Instance h)
+    roid <- either entityKey id <$> insertBy' (RemoteObject iid lu)
+    let ra = RemoteActor
+            { remoteActorIdent      = roid
+            , remoteActorName       =
+                AP.actorName detail <|> AP.actorUsername detail
+            , remoteActorInbox      = AP.actorInbox local
+            , remoteActorFollowers  = AP.actorFollowers local
+            , remoteActorErrorSince = Nothing
+            }
+    either entityKey id <$> insertBy' ra
+
+httpGetRemoteTip
+    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
+    => FedURI
+    -> ExceptT Result m
+        ( VersionControlSystem
+        , RemoteActorId
+        , FedURI
+        , Maybe (LocalURI, Text)
+        )
+httpGetRemoteTip (ObjURI host localURI) = do
+    repoOrBranch <- fetchTipE host localURI
+    case repoOrBranch of
+        Left repo -> do
+            remoteActorID <-
+                lift $ runSiteDB $
+                    insertRemoteActor host localURI $ AP.repoActor repo
+            let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+            return (AP.repoVcs repo, remoteActorID, uClone, Nothing)
+        Right (AP.Branch name _ luRepo) -> do
+            repo <- fetchRepoE host luRepo
+            remoteActorID <-
+                lift $ runSiteDB $
+                    insertRemoteActor host luRepo $ AP.repoActor repo
+            let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+            return (AP.repoVcs repo, remoteActorID, uClone, Just (localURI, name))
+    where
+    fetchTipE h lu = do
+        manager <- asksSite getHttpManager
+        ExceptT $ first (maybe ResultIdMismatch ResultGetError) <$>
+            fetchTip manager h lu
+
+httpGetRemoteRepo
+    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
+    => FedURI
+    -> ExceptT Result m (VersionControlSystem, RemoteActorId, FedURI)
+httpGetRemoteRepo (ObjURI host localURI) = do
+    repo <- fetchRepoE host localURI
+    remoteActorID <-
+        lift $ runSiteDB $
+            insertRemoteActor host localURI $ AP.repoActor repo
+    let uClone = ObjURI host $ NE.head $ AP.repoClone repo
+    return (AP.repoVcs repo, remoteActorID, uClone)

src/Vervis/Git.hs

@@ -21,11 +21,13 @@ module Vervis.Git
     , readPatch
     --, lastCommitTime
     , writePostReceiveHooks
+    , generateGitPatches
     --, applyGitPatches
     )
 where
 
 import Control.Arrow ((***))
+import Control.Exception.Base
 import Control.Monad (join)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Class (lift)
@@ -55,12 +57,13 @@ import Data.Traversable (for)
 import Data.Word (Word32)
 import Database.Persist
 import System.Exit
+import System.FilePath
 import System.Hourglass (timeCurrent)
 import System.Process.Typed
 import Text.Email.Validate (emailAddress)
 import Time.Types (Elapsed (..), Seconds (..))
 
-import qualified Data.ByteString as B (intercalate)
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.DList as D (DList, empty, snoc, toList)
 import qualified Data.Git as G
@@ -77,6 +80,7 @@ import Yesod.ActivityPub
 import Yesod.Hashids
 import Yesod.MonadSite
 
+import Control.Monad.Trans.Except.Local
 import Data.ByteString.Char8.Local (takeLine)
 import Data.DList.Local
 import Data.EventTime.Local
@@ -355,6 +359,59 @@ writePostReceiveHooks = do
         path <- askRepoDir repoHash
         liftIO $ writeHookFile path hook authority (keyHashidText repoHash)
 
+-- | Given a temporary directory to use freely for this operation, generate
+-- patches from the difference between the origin branch and the target branch
+-- (origin branch must be an ancestor of target branch)
+--
+-- Target repo must be local, origin repo may be remote on the network
+generateGitPatches
+    :: FilePath -- ^ Absolute path to target repo
+    -> String   -- ^ Target branch
+    -> String   -- ^ Absolute path or HTTP URI of origin repo
+    -> String   -- ^ Origin branch
+    -> FilePath -- ^ Temporary directory to use for the operation
+    -> ExceptT Text IO (NonEmpty Text)
+generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDir = do
+    runProcessE "git clone" $ proc "git" ["clone", "--bare", "--verbose", "--origin", "target", "--single-branch", "--branch", targetBranch, "--", targetRepoPath, tempDir]
+    runProcessE "git remote add" $ proc "git" ["-C", tempDir, "remote", "--verbose", "add", "-t", originBranch, "real-origin", originRepoURI]
+    runProcessE "git fetch" $ proc "git" ["-C", tempDir, "fetch", "real-origin", originBranch]
+    runProcessE "git merge-base --is-ancestor" $ proc "git" ["-C", tempDir, "merge-base", "--is-ancestor", targetBranch, "real-origin/" ++ originBranch]
+    patchFileNames <- do
+        names <- T.lines <$> readProcessE "git format-patch" (proc "git" ["-C", tempDir, "format-patch", targetBranch ++ "..real-origin/" ++ originBranch])
+        fromMaybeE (NE.nonEmpty names) "No new patches found in origin branch"
+    for patchFileNames $ \ name -> do
+        b <- lift $ B.readFile $ tempDir </> T.unpack name
+        case TE.decodeUtf8' b of
+            Left e -> throwE $ T.concat
+                [ "UTF-8 decoding error while reading Git patch file "
+                , name, ": " , T.pack $ displayException e
+                ]
+            Right t -> return t
+
+    where
+
+    runProcessE name spec = do
+        exitCode <- runProcess spec
+        case exitCode of
+            ExitFailure n ->
+                throwE $
+                    T.concat
+                        [ "`", name, "` failed with exit code "
+                        , T.pack (show n)
+                        ]
+            ExitSuccess -> return ()
+
+    readProcessE name spec = do
+        (exitCode, out) <- readProcessStdout spec
+        case exitCode of
+            ExitFailure n ->
+                throwE $
+                    T.concat
+                        [ "`", name, "` failed with exit code "
+                        , T.pack (show n)
+                        ]
+            ExitSuccess -> return $ TU.decodeStrict $ BL.toStrict out
+
 {-
 applyGitPatches shr rp branch patches = do
     path <- askRepoDir shr rp

src/Vervis/Handler/Loom.hs

@@ -73,6 +73,7 @@ import Vervis.Access
 import Vervis.API
 import Vervis.Federation.Auth
 import Vervis.Federation.Collab
+import Vervis.Federation.Ticket
 import Vervis.FedURI
 import Vervis.Form.Project
 import Vervis.Form.Ticket
@@ -143,6 +144,11 @@ postLoomInboxR recipLoomHash =
                 loomAcceptF now recipLoomHash author body mfwd luActivity accept
             AP.InviteActivity invite ->
                 topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite
+            AP.OfferActivity (AP.Offer obj target) ->
+                case obj of
+                    AP.OfferTicket ticket ->
+                        loomOfferTicketF now recipLoomHash author body mfwd luActivity ticket target
+                    _ -> return ("Unsupported offer object type for looms", Nothing)
             _ -> return ("Unsupported activity type for looms", Nothing)
 
 getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent

src/Vervis/Web/Repo.hs

@@ -15,22 +15,31 @@
 
 module Vervis.Web.Repo
     ( serveCommit
+    , generatePatches
     )
 where
 
+import Control.Monad
+import Control.Monad.Trans.Except
 import Data.Text (Text)
 import Data.Text.Encoding
+import Data.Time.Clock
 import Data.Traversable
 import Database.Persist
+import System.Directory
+import System.IO.Temp
 import Yesod.Core hiding (logError, logWarn, logInfo, logDebug)
 import Yesod.Persist.Core
 
+import qualified Data.List.NonEmpty as NE
 import qualified Data.Text as T
 
-import Web.ActivityPub hiding (Author (..), Ticket, Repo, ActorLocal (..))
+import Development.PatchMediaType
+import Network.FedURI
 import Yesod.ActivityPub
 import Yesod.FedURI
 import Yesod.Hashids
+import Yesod.MonadSite
 
 import qualified Web.ActivityPub as AP
 
@@ -38,8 +47,11 @@ import Data.Patch.Local hiding (Patch)
 
 import qualified Data.Patch.Local as P
 
+import Vervis.FedURI
 import Vervis.Foundation
+import Vervis.Git
 import Vervis.Model
+import Vervis.Path
 import Vervis.Settings
 import Vervis.Time
 import Vervis.Widget.Person
@@ -62,20 +74,20 @@ serveCommit repoHash ref patch parents = do
         mcommitter = patchCommitted patch
         makeAuthor' = makeAuthor hashPerson encodeRouteHome
         patchAP = AP.Commit
-            { commitId          = encodeRouteLocal $ RepoCommitR repoHash ref
+            { AP.commitId          = encodeRouteLocal $ RepoCommitR repoHash ref
-            , commitRepository  = encodeRouteLocal $ RepoR repoHash
+            , AP.commitRepository  = encodeRouteLocal $ RepoR repoHash
-            , commitAuthor      = makeAuthor' mpersonWritten author
+            , AP.commitAuthor      = makeAuthor' mpersonWritten author
-            , commitCommitter   =
+            , AP.commitCommitter   =
                 makeAuthor' mpersonCommitted . fst <$> mcommitter
-            , commitTitle       = patchTitle patch
+            , AP.commitTitle       = patchTitle patch
-            , commitHash        = Hash $ encodeUtf8 ref
+            , AP.commitHash        = AP.Hash $ encodeUtf8 ref
-            , commitDescription =
+            , AP.commitDescription =
                 let desc = patchDescription patch
                 in  if T.null desc
                         then Nothing
                         else Just desc
-            , commitWritten     = written
+            , AP.commitWritten     = written
-            , commitCommitted   = snd <$> patchCommitted patch
+            , AP.commitCommitted   = snd <$> patchCommitted patch
             }
     provideHtmlAndAP patchAP $
         let number = zip ([1..] :: [Int])
@@ -92,3 +104,37 @@ serveCommit repoHash ref patch parents = do
         }
     makeAuthor hashPerson encodeRouteHome (Just (Entity personID _, _)) _ =
         Right $ encodeRouteHome $ PersonR $ hashPerson personID
+
+generatePatches
+    :: (MonadUnliftIO m, MonadSite m, SiteEnv m ~ App)
+    => ( TicketLoomId
+       , RepoId
+       , Bool
+       , Either
+            (Text, (Either RepoId FedURI, Text))
+            (Either RepoId FedURI)
+       )
+    -> ExceptT Text m ()
+generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $ do
+    patches <-
+        case tipInfo of
+            Right _ -> error "Auto-pulling from Darcs remote origin not supported yet"
+            Left (targetBranch, (originRepo, originBranch)) -> do
+                targetPath <- do
+                    repoHash <- encodeKeyHashid targetRepoID
+                    repoDir <- askRepoDir repoHash
+                    liftIO $ makeAbsolute repoDir
+                originURI <-
+                    case originRepo of
+                        Left repoID -> do
+                            repoHash <- encodeKeyHashid repoID
+                            repoDir <- askRepoDir repoHash
+                            liftIO $ makeAbsolute repoDir
+                        Right uClone -> pure $ T.unpack $ renderObjURI uClone
+                ExceptT $ liftIO $ runExceptT $
+                    withSystemTempDirectory "vervis-generatePatches" $
+                        generateGitPatches targetPath (T.unpack targetBranch) originURI (T.unpack originBranch)
+    now <- liftIO getCurrentTime
+    lift $ runSiteDB $ do
+        bundleID <- insert $ Bundle clothID True
+        insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches

vervis.cabal

@@ -154,6 +154,7 @@ library
                        Vervis.Federation.Ticket
                        Vervis.Federation.Util
                        Vervis.FedURI
+                       Vervis.Fetch
                        -- Vervis.Field.Key
                        Vervis.Field.Person
                        --Vervis.Field.Project