From fff776a7c1c06692a04bb618db6e88a5687c05ed Mon Sep 17 00:00:00 2001
From: Francesco Ariis <fa-ml@ariis.it>
Date: Sat, 17 Aug 2024 15:58:34 +0200
Subject: [PATCH] Implement git:// protocol check

---
 Cabal/src/Distribution/PackageDescription/Check.hs   | 12 ++++++++++++
 .../Distribution/PackageDescription/Check/Warning.hs |  7 +++++++
 2 files changed, 19 insertions(+)

diff --git a/Cabal/src/Distribution/PackageDescription/Check.hs b/Cabal/src/Distribution/PackageDescription/Check.hs
index 5787dec3b77..8bab6ec961a 100644
--- a/Cabal/src/Distribution/PackageDescription/Check.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check.hs
@@ -684,6 +684,7 @@ checkSourceRepos rs = do
         checkP
           (isNothing repoLocation_)
           (PackageDistInexcusable MissingLocation)
+        checkGitProtocol repoLocation_
         checkP
           ( repoType_ == Just (KnownRepoType CVS)
               && isNothing repoModule_
@@ -722,6 +723,17 @@ checkMissingVcsInfo rs =
     repoTypeDirname Monotone = ["_MTN"]
     repoTypeDirname Pijul = [".pijul"]
 
+-- git:// lacks TLS or other encryption, see
+-- https://git-scm.com/book/en/v2/Git-on-the-Server-The-Protocols#_the_cons_4
+checkGitProtocol
+  :: Monad m
+  => Maybe String -- Repository location
+  -> CheckM m ()
+checkGitProtocol mloc =
+  checkP
+    (fmap (isPrefixOf "git://") mloc == Just True)
+    (PackageBuildWarning GitProtocol)
+
 -- ------------------------------------------------------------
 -- Package and distribution checks
 -- ------------------------------------------------------------
diff --git a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
index 859b3f12c50..4a587a8772f 100644
--- a/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
+++ b/Cabal/src/Distribution/PackageDescription/Check/Warning.hs
@@ -193,6 +193,7 @@ data CheckExplanation
   | UnrecognisedSourceRepo String
   | MissingType
   | MissingLocation
+  | GitProtocol
   | MissingModule
   | MissingTag
   | SubdirRelPath
@@ -355,6 +356,7 @@ data CheckExplanationID
   | CIUnrecognisedSourceRepo
   | CIMissingType
   | CIMissingLocation
+  | CIGitProtocol
   | CIMissingModule
   | CIMissingTag
   | CISubdirRelPath
@@ -496,6 +498,7 @@ checkExplanationId (NoLicenseFile{}) = CINoLicenseFile
 checkExplanationId (UnrecognisedSourceRepo{}) = CIUnrecognisedSourceRepo
 checkExplanationId (MissingType{}) = CIMissingType
 checkExplanationId (MissingLocation{}) = CIMissingLocation
+checkExplanationId (GitProtocol{}) = CIGitProtocol
 checkExplanationId (MissingModule{}) = CIMissingModule
 checkExplanationId (MissingTag{}) = CIMissingTag
 checkExplanationId (SubdirRelPath{}) = CISubdirRelPath
@@ -642,6 +645,7 @@ ppCheckExplanationId CINoLicenseFile = "no-license-file"
 ppCheckExplanationId CIUnrecognisedSourceRepo = "unrecognised-repo-type"
 ppCheckExplanationId CIMissingType = "repo-no-type"
 ppCheckExplanationId CIMissingLocation = "repo-no-location"
+ppCheckExplanationId CIGitProtocol = "git-protocol"
 ppCheckExplanationId CIMissingModule = "repo-no-module"
 ppCheckExplanationId CIMissingTag = "repo-no-tag"
 ppCheckExplanationId CISubdirRelPath = "repo-relative-dir"
@@ -964,6 +968,9 @@ ppExplanation MissingType =
   "The source-repository 'type' is a required field."
 ppExplanation MissingLocation =
   "The source-repository 'location' is a required field."
+ppExplanation GitProtocol =
+  "Cloning over git:// might lead to an arbitrary code execution "
+    ++ "vulnerability. Use https:// or ssh:// instead."
 ppExplanation MissingModule =
   "For a CVS source-repository, the 'module' is a required field."
 ppExplanation MissingTag =