Client, UI: "Apply" button for local MRs & PublishMergeR form for remote MRs

src/Vervis/Client.hs

@@ -30,6 +30,7 @@ module Vervis.Client
     --, unresolve
       offerPatches
     , offerMerge
+    , applyPatches
     , createDeck
     , createLoom
     , createRepo
@@ -74,6 +75,7 @@ import Data.Either.Local
 import Database.Persist.Local
 
 import Vervis.ActivityPub
+import Vervis.Cloth
 import Vervis.Data.Ticket
 import Vervis.FedURI
 import Vervis.Foundation
@@ -722,6 +724,106 @@ offerMerge senderHash title desc uTracker uTargetRepo maybeTargetBranch uOriginR
 
     return (Nothing, AP.Audience recips [] [] [] [] [], ticket)
 
+applyPatches
+    :: KeyHashid Person
+    -> FedURI
+    -> ExceptT Text Handler (Maybe HTML, Audience URIMode, Apply URIMode)
+applyPatches senderHash uObject = do
+
+    bundle <- parseProposalBundle "Apply object" uObject
+    mrInfo <-
+        bifor bundle
+            (\ (loomID, clothID, _) -> do
+                maybeCloth <- lift $ runDB $ getCloth loomID clothID
+                (Entity _ loom, Entity _ cloth, _, _, _, _) <-
+                    fromMaybeE maybeCloth "Local bundle not found in DB"
+                return (loomID, clothID, loomRepo loom, ticketLoomBranch cloth)
+            )
+            (\ uBundle -> do
+                manager <- asksSite appHttpManager
+                Doc h b <- AP.fetchAP_T manager $ Left uBundle
+                let mlocal =
+                        case b of
+                            BundleHosted ml _ -> (h,) <$> ml
+                            BundleOffer ml _ -> ml
+                (hBundle, blocal) <- 
+                    fromMaybeE mlocal "Remote bundle doesn't have 'context'"
+                unless (hBundle == h) $
+                    throwE "Bundle @id mismatch!"
+
+                Doc _ ticket <-
+                    AP.fetchAP_T manager $
+                        Left $ ObjURI hBundle $ AP.bundleContext blocal
+                (hMR, mr) <- fromMaybeE (AP.ticketAttachment ticket) "Ticket doesn't have attachment"
+                (hT, tlocal) <- fromMaybeE (AP.ticketLocal ticket) "Ticket doesn't have followers"
+                unless (hT == hBundle) $
+                    throwE "Ticket @id mismatch!"
+                uContext@(ObjURI hC _) <- fromMaybeE (AP.ticketContext ticket) "Ticket doesn't have context"
+                unless (hC == hT) $
+                    throwE "Ticket and tracker on different instances"
+
+                Doc hC' (AP.Actor aloc adet) <- AP.fetchAP_T manager $ Left uContext
+                unless (hC' == hC) $
+                    throwE "Tracker @id mismatch!"
+                unless (AP.actorType adet == AP.ActorTypePatchTracker) $
+                    throwE "Ticket context isn't a PatchTracker"
+                return
+                    ( uContext
+                    , AP.actorFollowers aloc
+                    , AP.ticketParticipants tlocal
+                    , bimap (ObjURI hMR) (hMR,) $ AP.mrTarget mr
+                    )
+            )
+
+    encodeRouteLocal <- getEncodeRouteLocal
+    encodeRouteHome <- getEncodeRouteHome
+    hashRepo <- getEncodeKeyHashid
+    hashLoom <- getEncodeKeyHashid
+    hashCloth <- getEncodeKeyHashid
+    hLocal <- asksSite siteInstanceHost
+
+    let target =
+            case mrInfo of
+                Left (_, _, repoID, maybeBranch) ->
+                    let luRepo = encodeRouteLocal $ RepoR $ hashRepo repoID
+                    in  case maybeBranch of
+                            Nothing -> Left $ ObjURI hLocal luRepo
+                            Just b ->
+                                Right
+                                    ( hLocal
+                                    , AP.Branch
+                                        { AP.branchName = b
+                                        , AP.branchRef  = "/refs/heads/" <> b
+                                        , AP.branchRepo = luRepo
+                                        }
+                                    )
+                Right (_, _, _, remoteTarget) -> remoteTarget
+
+        audAuthor =
+            AudLocal
+                []
+                [LocalStagePersonFollowers senderHash]
+        audCloth =
+            case mrInfo of
+                Left (loomID, clothID, _, _) ->
+                    let loomHash = hashLoom loomID
+                        clothHash = hashCloth clothID
+                    in  AudLocal
+                            [LocalActorLoom loomHash]
+                            [ LocalStageLoomFollowers loomHash
+                            , LocalStageClothFollowers loomHash clothHash
+                            ]
+                Right (ObjURI h luTracker, mluFollowers, luTicketFollowers, _) ->
+                    AudRemote h
+                        [luTracker]
+                        (catMaybes [mluFollowers, Just luTicketFollowers])
+
+        (_, _, _, audLocal, audRemote) = collectAudience [audAuthor, audCloth]
+
+        recips = map encodeRouteHome audLocal ++ audRemote
+
+    return (Nothing, Audience recips [] [] [] [] [], Apply uObject target)
+
 createDeck
     :: (MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App)
     => KeyHashid Person

src/Vervis/Darcs.hs

@@ -21,6 +21,7 @@ module Vervis.Darcs
     --, lastChange
     , readPatch
     , writePostApplyHooks
+    , canApplyDarcsPatch
     , applyDarcsPatch
     )
 where
@@ -399,6 +400,11 @@ writePostApplyHooks = do
         liftIO $
             writeDefaultsFile path hook authority (keyHashidText repoHash)
 
+canApplyDarcsPatch repoPath patch = do
+    let input = BL.fromStrict $ TE.encodeUtf8 patch
+    exitCode <- runProcess $ setStdin (byteStringInput input) $ proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--dry-run", "--repodir='" ++ repoPath ++ "'"]
+    return $ exitCode == ExitSuccess
+
 applyDarcsPatch repoPath patch = do
     let input = BL.fromStrict $ TE.encodeUtf8 patch
     runProcessE "darcs apply" $ setStdin (byteStringInput input) $ proc "darcs" ["apply", "--all", "--no-allow-conflicts", "--repodir='" ++ repoPath ++ "'"]

src/Vervis/Git.hs

@@ -22,6 +22,7 @@ module Vervis.Git
     --, lastCommitTime
     , writePostReceiveHooks
     , generateGitPatches
+    , canApplyGitPatches
     , applyGitPatches
     )
 where
@@ -54,6 +55,7 @@ import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 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
@@ -386,12 +388,20 @@ generateGitPatches targetRepoPath targetBranch originRepoURI originBranch tempDi
                 ]
             Right t -> return t
 
+canApplyGitPatches repoPath branch patches tempDir = do
+    runProcessE "git clone" $ proc "git" ["clone", "--verbose", "--single-branch", "--branch", branch, "--", repoPath, tempDir]
+    runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.name", "vervis"]
+    runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.email", "vervis@vervis.vervis"]
+    let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches
+    exitCode <- lift $ runProcess $ setStdin (byteStringInput input) $ proc "git" ["-C", tempDir, "am"]
+    return $ exitCode == ExitSuccess
+
 -- Since 'git am' doesn't work on a bare repo, clone target repo into the given
 -- temporary directory, apply there, and finally push
 applyGitPatches repoPath branch patches tempDir = do
     runProcessE "git clone" $ proc "git" ["clone", "--verbose", "--single-branch", "--branch", branch, "--", repoPath, tempDir]
-    let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches
-    runProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", tempDir, "am"]
     runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.name", "vervis"]
     runProcessE "git config" $ proc "git" ["-C", tempDir, "config", "user.email", "vervis@vervis.vervis"]
+    let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches
+    runProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", tempDir, "am"]
     runProcessE "git push" $ proc "git" ["-C", tempDir, "push"]

src/Vervis/Handler/Client.hs

@@ -29,6 +29,9 @@ module Vervis.Handler.Client
 
     , getPublishOfferMergeR
     , postPublishOfferMergeR
+
+    , getPublishMergeR
+    , postPublishMergeR
     )
 where
 
@@ -1142,3 +1145,41 @@ postPublishOfferMergeR = do
                 then setMessage "Merge Request created"
                 else setMessage "Offer published"
             redirect dest
+
+mergeForm :: Form (FedURI, FedURI)
+mergeForm = renderDivs $ (,)
+    <$> areq fedUriField "Patch bundle to apply"                   Nothing
+    <*> areq fedUriField "Grant activity to use for authorization" Nothing
+
+getPublishMergeR :: Handler Html
+getPublishMergeR = do
+    ((_, widget), enctype) <- runFormPost mergeForm
+    defaultLayout
+        [whamlet|
+            <h1>Merge a merge request
+            <form method=POST action=@{PublishMergeR} enctype=#{enctype}>
+              ^{widget}
+              <input type=submit>
+        |]
+
+postPublishMergeR :: Handler ()
+postPublishMergeR = do
+    federation <- getsYesod $ appFederation . appSettings
+    unless federation badMethod
+
+    (uBundle, uCap) <- runFormPostRedirect PublishMergeR mergeForm
+
+    (ep@(Entity pid _), a) <- getSender
+    senderHash <- encodeKeyHashid pid
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, apply) <- applyPatches senderHash uBundle
+        applyC ep a (Just uCap) maybeSummary audience apply
+
+    case result of
+        Left err -> do
+            setMessage $ toHtml err
+            redirect PublishMergeR
+        Right _ -> do
+            setMessage "Apply activity sent"
+            redirect HomeR

src/Vervis/Handler/Cloth.hs

@@ -26,6 +26,7 @@ module Vervis.Handler.Cloth
 
     , getClothDepR
 
+    , postClothApplyR
     , postClothFollowR
     , postClothUnfollowR
     , postClothReplyR
@@ -62,16 +63,19 @@ module Vervis.Handler.Cloth
 where
 
 import Control.Monad
+import Control.Monad.Trans.Except
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.Bool
 import Data.Function
 import Data.Functor
 import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import Data.Maybe
 import Data.Text (Text)
 import Data.These
 import Data.Traversable
 import Database.Persist
+import Network.HTTP.Types.Method
 import Text.Blaze.Html (Html, preEscapedToHtml)
 import Yesod.Auth
 import Yesod.Core
@@ -93,6 +97,7 @@ import Yesod.RenderSource
 
 import qualified Web.ActivityPub as AP
 
+import Control.Monad.Trans.Except.Local
 import Data.Paginate.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
@@ -115,9 +120,13 @@ import Vervis.Style
 import Vervis.Ticket
 import Vervis.Time (showDate)
 import Vervis.Web.Actor
+import Vervis.Web.Repo
+import Vervis.Widget
 import Vervis.Widget.Discussion
 import Vervis.Widget.Person
 
+import qualified Vervis.Client as C
+
 getClothR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler TypedContent
 getClothR loomHash clothHash = do
     (repoID, mbranch, ticket, author, resolve, proposal) <- runDB $ do
@@ -270,7 +279,7 @@ getClothR loomHash clothHash = do
             (Entity _ loom, Entity _ cloth, Entity ticketID ticket, author, _maybe_ResolveAndEitherTrlOrTrr, proposal) <-
                 getCloth404 loomHash clothHash
             (ticket,,,,,,,)
-                <$> getLocalRepo (loomRepo loom) (ticketLoomBranch cloth)
+                <$> getLocalRepo' (loomRepo loom) (ticketLoomBranch cloth)
                 <*> bitraverse
                         (\ (Entity _ (TicketAuthorLocal _ personID _)) -> do
                             p <- getJust personID
@@ -298,12 +307,18 @@ getClothR loomHash clothHash = do
                         (justThere proposal)
                 <*> traverse
                         (\ (bundleID :| _) -> do
-                            ids <- selectKeysList [PatchBundle ==. bundleID] [Desc PatchId]
+                            ps <- selectList [PatchBundle ==. bundleID] [Desc PatchId]
-                            case nonEmpty ids of
+                            case nonEmpty ps of
                                 Nothing -> error "Bundle without any Patches in DB"
                                 Just ne -> return (bundleID, ne)
                         )
                         (justHere proposal)
+        mbundle' <- for mbundle $ \ (bundleID, patches) -> do
+            let patchIDs = NE.map entityKey patches
+                diffs = NE.map (patchContent . entityVal) $ NE.reverse patches
+                (repoID, _, _, maybeBranch) = targetRepo
+            errorOrCanApply <- runExceptT $ canApplyPatches repoID maybeBranch diffs
+            return (bundleID, patchIDs, errorOrCanApply)
         hashMessageKey <- handlerToWidget getEncodeKeyHashid
         let desc :: Widget
             desc = toWidget $ markupHTML $ ticketDescription ticket
@@ -325,10 +340,19 @@ getClothR loomHash clothHash = do
                     (ClothFollowR loomHash clothHash)
                     (ClothUnfollowR loomHash clothHash)
                     (ticketFollowers ticket)
+            applyButton label =
+                buttonW POST label $ ClothApplyR loomHash clothHash
         hashBundle <- handlerToWidget getEncodeKeyHashid
         hashPatch <- handlerToWidget getEncodeKeyHashid
         $(widgetFile "cloth/one")
         where
+        getLocalRepo' repoID mbranch = do
+            repo <- getJust repoID
+            actor <- getJust $ repoActor repo
+            repoHash <- encodeKeyHashid repoID
+            unless (isJust mbranch == (repoVcs repo == VCSGit)) $
+                error "VCS and cloth-branch mismatch"
+            return (repoID, repoHash, actorName actor, mbranch)
         getLocalRepo repoID mbranch = do
             repo <- getJust repoID
             actor <- getJust $ repoActor repo
@@ -591,6 +615,50 @@ getClothDepR _ _ _ = do
             tdc
     -}
 
+postClothApplyR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
+postClothApplyR loomHash clothHash = do
+    ep@(Entity personID person) <- requireAuth
+
+    (grantIDs, proposal, actor) <- runDB $ do
+        (Entity loomID _, _, _, _, _, proposal) <- getCloth404 loomHash clothHash
+
+        grantIDs <-
+            E.select $ E.from $ \ (topic `E.InnerJoin` recip `E.InnerJoin` enable) -> do
+                E.on $ topic E.^. CollabTopicLoomCollab E.==. enable E.^. CollabEnableCollab
+                E.on $ topic E.^. CollabTopicLoomCollab E.==. recip E.^. CollabRecipLocalCollab
+                E.where_ $
+                    topic E.^. CollabTopicLoomLoom E.==. E.val loomID E.&&.
+                    recip E.^. CollabRecipLocalPerson E.==. E.val personID
+                return $ enable E.^. CollabEnableGrant
+
+        actor <- getJust $ personActor person
+
+        return (map E.unValue grantIDs, proposal, actor)
+
+    result <- runExceptT $ do
+
+        bundleID :| _ <-
+            fromMaybeE (justHere proposal) "No patch bundle to apply"
+        grantID <-
+            case grantIDs of
+                [] -> throwE "You don't have access to this patch tracker"
+                [g] -> return g
+                _ -> error "Multiple grants for same person on same loom"
+        bundleRoute <- BundleR loomHash clothHash <$> encodeKeyHashid bundleID
+        encodeRouteHome <- getEncodeRouteHome
+        personHash <- encodeKeyHashid personID
+        (maybeSummary, audience, apply) <-
+            C.applyPatches personHash $ encodeRouteHome bundleRoute
+        uCap <-
+            encodeRouteHome . LoomOutboxItemR loomHash <$>
+                encodeKeyHashid grantID
+        applyC ep actor (Just uCap) maybeSummary audience apply
+
+    case result of
+        Left e -> setMessage $ toHtml e
+        Right _ -> setMessage "Patches applied successfully!"
+    redirect $ ClothR loomHash clothHash
+
 postClothFollowR :: KeyHashid Loom -> KeyHashid TicketLoom -> Handler ()
 postClothFollowR _ = error "Temporarily disabled"
 

src/Vervis/Web/Repo.hs

@@ -16,6 +16,7 @@
 module Vervis.Web.Repo
     ( serveCommit
     , generatePatches
+    , canApplyPatches
     , applyPatches
     )
 where
@@ -142,6 +143,27 @@ generatePatches (clothID, targetRepoID, hasBundle, tipInfo) = unless hasBundle $
         bundleID <- insert $ Bundle clothID True
         insertMany_ $ NE.toList $ NE.map (Patch bundleID now PatchMediaTypeGit) $ NE.reverse patches
 
+canApplyPatches
+    :: (MonadSite m, SiteEnv m ~ App)
+    => RepoId -> Maybe Text -> NonEmpty Text -> ExceptT Text m Bool
+canApplyPatches repoID maybeBranch diffs = do
+    repoPath <- do
+        repoHash <- encodeKeyHashid repoID
+        repoDir <- askRepoDir repoHash
+        liftIO $ makeAbsolute repoDir
+    case maybeBranch of
+        Just branch -> do
+            ExceptT $ liftIO $ runExceptT $
+                withSystemTempDirectory "vervis-canApplyPatches" $
+                    canApplyGitPatches repoPath (T.unpack branch) diffs
+        Nothing -> do
+            patch <-
+                case diffs of
+                    t :| [] -> return t
+                    _ :| (_ : _) ->
+                        throwE "Darcs repo given multiple patch bundles"
+            canApplyDarcsPatch repoPath patch
+
 applyPatches
     :: (MonadSite m, SiteEnv m ~ App)
     => RepoId -> Maybe Text -> NonEmpty Text -> ExceptT Text m ()

src/Web/ActivityPub.hs

@@ -96,6 +96,7 @@ module Web.ActivityPub
     , httpPostAPBytes
     , Fetched (..)
     , fetchAP
+    , fetchAP_T
     , fetchAPID
     , fetchAPID'
     , fetchTip
@@ -1940,6 +1941,9 @@ fetchAP' m u = ExceptT $ second responseBody <$> httpGetAP m u
 fetchAP :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT String m a
 fetchAP m u = withExceptT displayException $ fetchAP' m u
 
+fetchAP_T :: (MonadIO m, UriMode u, FromJSON a) => Manager -> Either (ObjURI u) (SubURI u) -> ExceptT Text m a
+fetchAP_T m u = withExceptT T.pack $ fetchAP m u
+
 {-
 fetchAPH :: (MonadIO m, ActivityPub a) => Manager -> Text -> LocalURI -> ExceptT String m a
 fetchAPH m h lu = do

templates/cloth/one.cassius

@@ -1,6 +1,6 @@
 /* This file is part of Vervis.
  *
- * Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
+ * Written in 2016, 2022 by fr33domlover <fr33domlover@riseup.net>.
  *
  * ♡ Copying is an act of love. Please copy, reuse and share.
  *
@@ -17,3 +17,12 @@
 
 .#{cIrrelevant}
     color: #{light gray}
+
+.apply-error
+    color: #{light red}
+
+.apply-no
+    color: #{light yellow}
+
+.apply-yes
+    color: #{light green}

templates/cloth/one.hamlet

@@ -44,7 +44,7 @@ $maybe originRepo <- moriginRepo
           $nothing
             #{branch}
 
-$with (repoHash, name, maybeBranch) <- targetRepo
+$with (_repoID, repoHash, name, maybeBranch) <- targetRepo
   <div>
     Target:
     <a href=@{RepoR repoHash}>
@@ -54,7 +54,7 @@ $with (repoHash, name, maybeBranch) <- targetRepo
       <a href=@{RepoBranchSourceR repoHash branch []}>
         #{branch}
 
-$maybe (bundleID, patchIDs) <- mbundle
+$maybe (bundleID, patchIDs, errorOrCanApply) <- mbundle'
   <div>
     Bundle
     <a href=@{BundleR loomHash clothHash (hashBundle bundleID)}>
@@ -65,6 +65,21 @@ $maybe (bundleID, patchIDs) <- mbundle
         <li>
           <a href=@{PatchR loomHash clothHash (hashBundle bundleID) (hashPatch patchID)}>
             #{keyHashidText $ hashPatch patchID}
+  <div>
+    Status:
+    $case errorOrCanApply
+      $of Left e
+        <span .apply-error>
+          [Error! #{e}]
+        ^{applyButton "Try applying anyway"}
+      $of Right False
+        <span .apply-no>
+          [Apply check failed! Possibly conflicts exist]
+        ^{applyButton "Try applying anyway"}
+      $of Right True
+        <span .apply-yes>
+          [Can apply!]
+        ^{applyButton "Apply"}
 
 <div>
   <span>

templates/personal-overview.hamlet

@@ -30,3 +30,6 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <li>
     <a href=@{PublishOfferMergeR}>
       Open a merge request
+  <li>
+    <a href=@{PublishMergeR}>
+      Merge a merge request

th/routes

@@ -131,6 +131,7 @@
 /inbox         InboxDebugR    GET
 
 /publish/offer-merge PublishOfferMergeR GET POST
+/publish/merge       PublishMergeR      GET POST
 
 ---- Person ------------------------------------------------------------------
 
@@ -270,6 +271,7 @@
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unclaim    ClothUnclaimR     POST
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/assign     ClothAssignR      GET POST
 -- /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unassign   ClothUnassignR    POST
+/looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/apply      ClothApplyR       POST
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/follow     ClothFollowR      POST
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/unfollow   ClothUnfollowR    POST
 /looms/#LoomKeyHashid/cloths/#TicketLoomKeyHashid/reply      ClothReplyR       POST