[bug#46182] [PATCH] lint: Add 'check-git-protocol' checker.

[zimoun]

Hi Leo,

Giving a look to the bug tracker for the next release, I see this
bug. :-)


On Fri, 29 Jan 2021 at 20:04, Leo Famulari <leo@famulari.name> wrote:
> We could also make it warn about use of the HTTP protocol (as opposed to
> HTTPS). Your thoughts?
>
> * guix/lint.scm (check-git-protocol): New procedure.
> (%local-checkers): Add 'git-protocol' checker.
> * doc/guix.texi (Invoking guix lint): Document it.

The doc/ does not apply anymore.


Instead of these ’eqv?’

> +(define (check-git-protocol package)
> +  "Emit a warning if PACKAGE's source URI protocol is 'git://'."
> +  (define (check-source-uri-scheme uri)
> +    (if (eqv? (uri-scheme uri) 'git)

[...]

> +  (let ((origin (package-source package)))
> +    (if (and (origin? origin)
> +             (eqv? (origin-method origin) git-fetch))
> +        (check-source-uri-scheme
> +          (string->uri (git-reference-url (origin-uri origin))))
> +        '())))

I propose ’match’ which is more coherent with the Guix style.  Well,
from my understanding. :-)

Patch attached.  Well, it could be nice to add a test in
tests/guix-lint.sh for that.  WDYT?


Cheers,
simon

diff --git a/guix/lint.scm b/guix/lint.scm
index 311bc94cc3..980f77c736 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -51,7 +51,7 @@
   #:use-module (guix gnu-maintenance)
   #:use-module (guix cve)
   #:use-module ((guix swh) #:hide (origin?))
-  #:autoload   (guix git-download) (git-reference?
+  #:autoload   (guix git-download) (git-reference? git-fetch
                                     git-reference-url git-reference-commit)
   #:use-module (guix import stackage)
   #:use-module (ice-9 match)
@@ -84,6 +84,7 @@
             check-source
             check-source-file-name
             check-source-unstable-tarball
+            check-git-protocol
             check-mirror-url
             check-github-url
             check-license
@@ -918,6 +919,26 @@ descriptions maintained upstream."
                     (origin-uris origin))
         '())))
 
+(define (check-git-protocol package)
+  "Emit a warning if PACKAGE's source URI protocol is 'git://'."
+  (define (check-source-uri-scheme uri)
+    (match (uri-scheme uri)
+      ('git
+       (list
+         (make-warning package
+                       (G_ "the source URI should not use the git:// protocol")
+                       #:field 'source)))
+      (_ '())))
+
+  (match (package-source package)
+    ((? origin? origin)
+     (match (origin-method origin)
+       (git-fetch
+        (check-source-uri-scheme
+         (string->uri (git-reference-url (origin-uri origin)))))
+       (_ '())))
+    (_ '())))
+
 (define (check-mirror-url package)
   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
   (define (check-mirror-uri uri)                  ;XXX: could be optimized
@@ -1476,6 +1497,10 @@ or a list thereof")
      (name        'source-unstable-tarball)
      (description "Check for autogenerated tarballs")
      (check       check-source-unstable-tarball))
+   (lint-checker
+     (name        'git-protocol)
+     (description "Check for use of the git:// protocol")
+     (check       check-git-protocol))
    (lint-checker
      (name            'derivation)
      (description     "Report failure to compile a package to a derivation")