diff --git a/src/Development/PatchMediaType.hs b/src/Development/PatchMediaType.hs index 1933f32..77ce3cb 100644 --- a/src/Development/PatchMediaType.hs +++ b/src/Development/PatchMediaType.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2019, 2020 by fr33domlover . + - Written in 2016, 2019, 2020, 2022 by fr33domlover . - - ♡ 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" diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index 0c0dbcc..f68117b 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -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) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 21a8b00..a0b1825 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -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 diff --git a/src/Vervis/Git.hs b/src/Vervis/Git.hs index 357b83d..33ea6f6 100644 --- a/src/Vervis/Git.hs +++ b/src/Vervis/Git.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020 by fr33domlover . + - Written in 2016, 2018, 2019, 2020, 2022 + - by fr33domlover . - - ♡ 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