diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 9d48d22..6acfe57 100644 --- a/src/Vervis/Client.hs +++ b/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 diff --git a/src/Vervis/Darcs.hs b/src/Vervis/Darcs.hs index b7a783e..8b78366 100644 --- a/src/Vervis/Darcs.hs +++ b/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 ++ "'"] diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index e8f5ae0..f7a9ba0 100644 --- a/src/Vervis/Git.hs +++ b/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"] diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index ef7ccf0..5b6e4a0 100644 --- a/src/Vervis/Handler/Client.hs +++ b/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| +

Merge a merge request +
+ ^{widget} + + |] + +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 diff --git a/src/Vervis/Handler/Cloth.hs b/src/Vervis/Handler/Cloth.hs index 58b254c..187fc0a 100644 --- a/src/Vervis/Handler/Cloth.hs +++ b/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] - case nonEmpty ids of + ps <- selectList [PatchBundle ==. bundleID] [Desc PatchId] + 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" diff --git a/src/Vervis/Web/Repo.hs b/src/Vervis/Web/Repo.hs index 07528fb..6fa70e6 100644 --- a/src/Vervis/Web/Repo.hs +++ b/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 () diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 9cd1620..2c78a45 100644 --- a/src/Web/ActivityPub.hs +++ b/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 diff --git a/templates/cloth/one.cassius b/templates/cloth/one.cassius index 17c40e0..1fcc723 100644 --- a/templates/cloth/one.cassius +++ b/templates/cloth/one.cassius @@ -1,6 +1,6 @@ /* This file is part of Vervis. * - * Written in 2016 by fr33domlover . + * Written in 2016, 2022 by fr33domlover . * * ♡ 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} diff --git a/templates/cloth/one.hamlet b/templates/cloth/one.hamlet index e9a6329..bfb088e 100644 --- a/templates/cloth/one.hamlet +++ b/templates/cloth/one.hamlet @@ -44,7 +44,7 @@ $maybe originRepo <- moriginRepo $nothing #{branch} -$with (repoHash, name, maybeBranch) <- targetRepo +$with (_repoID, repoHash, name, maybeBranch) <- targetRepo
Target: @@ -54,7 +54,7 @@ $with (repoHash, name, maybeBranch) <- targetRepo #{branch} -$maybe (bundleID, patchIDs) <- mbundle +$maybe (bundleID, patchIDs, errorOrCanApply) <- mbundle'
Bundle @@ -65,6 +65,21 @@ $maybe (bundleID, patchIDs) <- mbundle
  • #{keyHashidText $ hashPatch patchID} +
    + Status: + $case errorOrCanApply + $of Left e + + [Error! #{e}] + ^{applyButton "Try applying anyway"} + $of Right False + + [Apply check failed! Possibly conflicts exist] + ^{applyButton "Try applying anyway"} + $of Right True + + [Can apply!] + ^{applyButton "Apply"}
    diff --git a/templates/personal-overview.hamlet b/templates/personal-overview.hamlet index 301e614..9038f15 100644 --- a/templates/personal-overview.hamlet +++ b/templates/personal-overview.hamlet @@ -30,3 +30,6 @@ $# .
  • Open a merge request +
  • + + Merge a merge request diff --git a/th/routes b/th/routes index 7b03efb..87993b3 100644 --- a/th/routes +++ b/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