forge/Vervis
1
0
Fork 0
Code Pull requests Activity

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

Browse source
This commit is contained in:
fr33domlover 2022-09-24 21:15:40 +00:00
parent ba6f22b94b
commit f10655f2c1
11 changed files with 290 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

102
src/Vervis/Client.hs
View file

@ -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

6
src/Vervis/Darcs.hs
View file

@ -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 ++ "'"]

14
src/Vervis/Git.hs
View file

@ -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"]

41
src/Vervis/Handler/Client.hs
View file

@ -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

74
src/Vervis/Handler/Cloth.hs
View file

@ -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"

22
src/Vervis/Web/Repo.hs
View file

@ -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 ()

4
src/Web/ActivityPub.hs
View file

@ -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

11
templates/cloth/one.cassius
View file

@ -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}

19
templates/cloth/one.hamlet
View file

@ -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>

3
templates/personal-overview.hamlet
View file

@ -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

2
th/routes
View file

@ -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