forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: repoApplyF: Implement the missing support for patching Git repos

Browse source
This commit is contained in:
fr33domlover 2022-06-26 14:00:28 +00:00
parent a6e4587281
commit 8186e64a26
4 changed files with 86 additions and 15 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

9
src/Development/PatchMediaType.hs
View file

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2019, 2020, 2022 by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -33,7 +33,7 @@ import qualified Data.Text as T
data VersionControlSystem = VCSDarcs | VCSGit deriving Eq
data PatchMediaType = PatchMediaTypeDarcs deriving Eq
data PatchMediaType = PatchMediaTypeDarcs | PatchMediaTypeGit deriving Eq
forgeFedPrefix :: Text
forgeFedPrefix = "https://forgefed.org/ns#"
@ -64,10 +64,15 @@ versionControlSystemURI vcs = forgeFedPrefix <> rest vcs
patchMediaTypeVCS :: PatchMediaType -> VersionControlSystem
patchMediaTypeVCS PatchMediaTypeDarcs = VCSDarcs
patchMediaTypeVCS PatchMediaTypeGit = VCSGit
-- I don't think there's any standard media type for git patches, just picked
-- something that resembles the darcs media type
parsePatchMediaType :: Text -> Maybe PatchMediaType
parsePatchMediaType "application/x-darcs-patch" = Just PatchMediaTypeDarcs
parsePatchMediaType "application/x-git-patch" = Just PatchMediaTypeGit
parsePatchMediaType _ = Nothing
renderPatchMediaType :: PatchMediaType -> Text
renderPatchMediaType PatchMediaTypeDarcs = "application/x-darcs-patch"
renderPatchMediaType PatchMediaTypeGit = "application/x-git-patch"

5
src/Vervis/API.hs
View file

@ -501,7 +501,10 @@ applyC (Entity pidUser personUser) sharerUser summary audience muCap (Apply uObj
patch <-
case patches of
_ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
(PatchMediaTypeDarcs, t) :| [] -> return t
(typ, t) :| [] ->
case typ of
PatchMediaTypeDarcs -> return t
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
applyDarcsPatch shrTarget rpTarget patch
return (shrTarget, rpTarget, repoTarget, mltid, ticketFollowers)

49
src/Vervis/Federation/Ticket.hs
View file

@ -102,6 +102,7 @@ import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Federation.Util
import Vervis.Foundation
import Vervis.Git
import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Role
@ -1561,13 +1562,27 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
-- Grab the bundle's patches from DB and apply them
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
case repoVcs repoRecip of
VCSGit -> error "Patching a Git repo unsupported yet"
VCSGit -> do
branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
patches' <-
case NE.nonEmpty patches of
Nothing -> error "No patches found in DB"
Just ps -> return ps
let essence (Patch _ _ typ t) = (typ, t)
patches'' = NE.map (essence . entityVal) patches'
unless (all ((== PatchMediaTypeGit) . fst) patches'') $
throwE "Trying to apply non-Git patch to a Git repo"
applyGitPatches shrRecip rpRecip branch $ NE.map snd patches''
VCSDarcs -> do
verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
patch <-
case patches of
[] -> error "Local repo-bundle without any patches found"
_ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
(Entity _ (Patch _ _ PatchMediaTypeDarcs t)) : [] -> return t
(Entity _ (Patch _ _ typ t)) : [] ->
case typ of
PatchMediaTypeDarcs -> return t
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
applyDarcsPatch shrRecip rpRecip patch
-- Insert Apply activity to repo's inbox
@ -1635,13 +1650,27 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
-- Grab the bundle's patches from DB and apply them
patches <- lift $ runSiteDB $ selectList [PatchBundle ==. bnid] [Asc PatchId]
case repoVcs repoRecip of
VCSGit -> error "Patching a Git repo unsupported yet"
VCSGit -> do
branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
patches' <-
case NE.nonEmpty patches of
Nothing -> error "No patches found in DB"
Just ps -> return ps
let essence (Patch _ _ typ t) = (typ, t)
patches'' = NE.map (essence . entityVal) patches'
unless (all ((== PatchMediaTypeGit) . fst) patches'') $
throwE "Trying to apply non-Git patch to a Git repo"
applyGitPatches shrRecip rpRecip branch $ NE.map snd patches''
VCSDarcs -> do
verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
patch <-
case patches of
[] -> error "Local repo-bundle without any patches found"
_ : (_ : _) -> throwE "Darcs repo given multiple patch bundles"
(Entity _ (Patch _ _ PatchMediaTypeDarcs t)) : [] -> return t
(Entity _ (Patch _ _ typ t)) : [] ->
case typ of
PatchMediaTypeDarcs -> return t
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
applyDarcsPatch shrRecip rpRecip patch
-- Insert Apply activity to repo's inbox
@ -1746,12 +1775,20 @@ repoApplyF now shrRecip rpRecip author body mfwd luApply uObject uTarget = do
throwE "Patch type and repo VCS mismatch"
return (typ, content)
case repoVcs repoRecip of
VCSGit -> error "Patching a Git repo unsupported yet"
VCSGit -> do
branch <- fromMaybeE mbranch "Apply target is a Git repo, branch not specified"
unless (all ((== PatchMediaTypeGit) . fst) patches) $
throwE "Trying to apply non-Git patch to a Git repo"
applyGitPatches shrRecip rpRecip branch $ NE.map snd patches
VCSDarcs -> do
verifyNothingE mbranch "Apply target is a branch of a Darcs repo"
patch <-
case patches of
_ :| (_ : _) -> throwE "Darcs repo given multiple patch bundles"
(PatchMediaTypeDarcs, t) :| [] -> return t
(typ, t) :| [] ->
case typ of
PatchMediaTypeDarcs -> return t
_ -> throwE "Trying to apply non-Darcs patch to a Darcs repo"
applyDarcsPatch shrRecip rpRecip patch
-- Insert Apply activity to repo's inbox

38
src/Vervis/Git.hs
View file

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018, 2019, 2020 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2016, 2018, 2019, 2020, 2022
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -20,6 +21,7 @@ module Vervis.Git
, readPatch
, lastCommitTime
, writePostReceiveHooks
, applyGitPatches
)
where
@ -51,18 +53,20 @@ import Data.Time.Clock (UTCTime (..))
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Traversable (for)
import Data.Word (Word32)
import System.Exit
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.Lazy as BL (ByteString, toStrict, length)
import qualified Data.ByteString.Lazy as BL
import qualified Data.DList as D (DList, empty, snoc, toList)
import qualified Data.Git as G
import qualified Data.List.NonEmpty as N (toList)
import qualified Data.List.NonEmpty as NE
import qualified Data.Set as S (member, mapMonotonic, toList)
import qualified Data.Text as T (pack, unpack, break, strip)
import qualified Data.Text.Encoding as TE (decodeUtf8With)
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import qualified Data.Text.Encoding.Error as TE (lenientDecode)
import qualified Data.Vector as V (fromList)
import qualified Database.Esqueleto as E
@ -79,6 +83,7 @@ import Data.List.Local
import Data.Patch.Local hiding (Patch)
import qualified Data.Patch.Local as P
import qualified Data.Text.UTF8.Local as TU
import Vervis.Changes
import Vervis.Foundation
@ -271,7 +276,7 @@ mkdiff old new =
mkhunk h =
let (n, l) = line h
in (n, l, mkhunk' h)
in map (mkhunk . groupEithers . N.toList) $
in map (mkhunk . groupEithers . NE.toList) $
groupJusts $
map eitherOldNew $
diff (zipWith Line [1..] old) (zipWith Line [1..] new)
@ -347,3 +352,24 @@ writePostReceiveHooks = do
for_ repos $ \ (E.Value shr, E.Value rp) -> do
path <- askRepoDir shr rp
liftIO $ writeHookFile path hook authority (shr2text shr) (rp2text rp)
applyGitPatches shr rp branch patches = do
path <- askRepoDir shr rp
let input = BL.concat $ NE.toList $ NE.map (BL.fromStrict . TE.encodeUtf8) patches
readProcessE "git checkout" $ proc "git" ["-C", path, "checkout", T.unpack branch]
readProcessE "git am" $ setStdin (byteStringInput input) $ proc "git" ["-C", "'" ++ path ++ "'", "am"]
where
readProcessE name spec = do
(exitCode, out, err) <- readProcess spec
case exitCode of
ExitFailure n ->
throwE $
T.concat
[ "`", name, "` failed with exit code "
, T.pack (show n)
, "\nstdout: ", out2text out
, "\nstderr: ", out2text err
]
ExitSuccess -> return ()
where
out2text = TU.decodeLenient . BL.toStrict