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

src/Development/PatchMediaType.hs

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

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)

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

src/Vervis/Git.hs

@@ -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 as T
-import qualified Data.Text.Encoding as TE (decodeUtf8With)
+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