[bug#44591] [PATCH 1/1] lint: Add 'patch-headers' checker.

[Ludovic Courtès]

* guix/lint.scm (check-patch-headers): New procedure.
(%local-checkers): Add 'patch-headers' checker.
* tests/lint.scm ("patch headers: no warnings")
("patch headers: missing comment", "patch headers: empty")
("patch headers: patch not found"): New tests.
---
 guix/lint.scm  | 55 +++++++++++++++++++++++++++++++++++++++++++++++++
 tests/lint.scm | 56 ++++++++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 111 insertions(+)

diff --git a/guix/lint.scm b/guix/lint.scm
index 91dbc806dc..0b38ca0d33 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -35,6 +35,8 @@
   #:use-module (guix http-client)
   #:use-module (guix packages)
   #:use-module (guix i18n)
+  #:use-module ((guix gexp)
+                #:select (local-file? local-file-absolute-file-name))
   #:use-module (guix licenses)
   #:use-module (guix records)
   #:use-module (guix grafts)
@@ -73,6 +75,7 @@
             check-inputs-should-be-native
             check-inputs-should-not-be-an-input-at-all
             check-patch-file-names
+            check-patch-headers
             check-synopsis-style
             check-derivation
             check-home-page
@@ -712,6 +715,54 @@ patch could not be found."
                      (_ #f))
                    patches)))))
 
+(define (check-patch-headers package)
+  "Check that PACKAGE's patches start with a comment.  Return a list of
+warnings."
+  (define (blank? str)
+    (string-every char-set:blank str))
+
+  (define (patch-header-warnings patch)
+    (call-with-input-file patch
+      (lambda (port)
+        ;; Read from PORT until a non-blank line is found or EOF is reached.
+        (let loop ()
+          (let ((line (read-line port)))
+            (cond ((eof-object? line)
+                   (list (make-warning package
+                                       (G_ "~a: empty patch")
+                                       (list (basename patch))
+                                       #:field 'source)))
+                  ((blank? line)
+                   (loop))
+                  ((or (string-prefix? "--- " line)
+                       (string-prefix? "+++ " line))
+                   (list (make-warning package
+                                       (G_ "~a: patch lacks comment and \
+upstream status")
+                                       (list (basename patch))
+                                       #:field 'source)))
+                  (else
+                   '())))))))
+
+  (guard (c ((formatted-message? c)               ;raised by 'search-patch'
+             (list (%make-warning package
+                                  (formatted-message-string c)
+                                  (formatted-message-arguments c)
+                                  #:field 'source))))
+   (let ((patches (if (origin? (package-source package))
+                      (origin-patches (package-source package))
+                      '())))
+     (append-map (lambda (patch)
+                   ;; Dismiss PATCH if it's an origin or similar.
+                   (cond ((string? patch)
+                          (patch-header-warnings patch))
+                         ((local-file? patch)
+                          (patch-header-warnings
+                           (local-file-absolute-file-name patch)))
+                         (else
+                          '())))
+                 patches))))
+
 (define (escape-quotes str)
   "Replace any quote character in STR by an escaped quote character."
   (list->string
@@ -1417,6 +1468,10 @@ or a list thereof")
     (name        'patch-file-names)
     (description "Validate file names and availability of patches")
     (check       check-patch-file-names))
+   (lint-checker
+    (name        'patch-headers)
+    (description "Validate patch headers")
+    (check       check-patch-headers))
    (lint-checker
      (name        'formatting)
      (description "Look for formatting issues in the source")
diff --git a/tests/lint.scm b/tests/lint.scm
index 95abd71378..bd052842f3 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -36,6 +36,8 @@
   #:use-module (guix lint)
   #:use-module (guix ui)
   #:use-module (guix swh)
+  #:use-module ((guix gexp) #:select (local-file))
+  #:use-module ((guix utils) #:select (call-with-temporary-directory))
   #:use-module (gnu packages)
   #:use-module (gnu packages glib)
   #:use-module (gnu packages pkg-config)
@@ -344,6 +346,60 @@
                   (list (search-patch "this-patch-does-not-exist!"))))))))
      (check-patch-file-names pkg))))
 
+(test-assert "patch headers: no warnings"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (call-with-output-file (string-append directory "/t.patch")
+       (lambda (port)
+         (display "This is a patch.\n\n--- a\n+++ b\n"
+                  port)))
+
+     (parameterize ((%patch-path (list directory)))
+       (let ((pkg (dummy-package "x"
+                    (source (dummy-origin
+                             (patches (search-patches "t.patch")))))))
+         (null? (check-patch-headers pkg)))))))
+
+(test-equal "patch headers: missing comment"
+  "t.patch: patch lacks comment and upstream status"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (call-with-output-file (string-append directory "/t.patch")
+       (lambda (port)
+         (display "\n--- a\n+++ b\n"
+                  port)))
+
+     (parameterize ((%patch-path (list directory)))
+       (let ((pkg (dummy-package "x"
+                    (source (dummy-origin
+                             (patches (search-patches "t.patch")))))))
+         (single-lint-warning-message (check-patch-headers pkg)))))))
+
+(test-equal "patch headers: empty"
+  "t.patch: empty patch"
+  (call-with-temporary-directory
+   (lambda (directory)
+     (call-with-output-file (string-append directory "/t.patch")
+       (const #t))
+
+     (parameterize ((%patch-path '()))
+       (let ((pkg (dummy-package "x"
+                    (source (dummy-origin
+                             (patches
+                              (list (local-file
+                                     (string-append directory
+                                                    "/t.patch")))))))))
+         (single-lint-warning-message (check-patch-headers pkg)))))))
+
+(test-equal "patch headers: patch not found"
+  "does-not-exist.patch: patch not found\n"
+  (parameterize ((%patch-path '()))
+    (let ((pkg (dummy-package "x"
+                 (source (dummy-origin
+                          (patches
+                           (search-patches "does-not-exist.patch")))))))
+      (single-lint-warning-message (check-patch-headers pkg)))))
+
 (test-equal "derivation: invalid arguments"
   "failed to create x86_64-linux derivation: (wrong-type-arg \"map\" \"Wrong 
type argument: ~S\" (invalid-module) ())"
   (match (let ((pkg (dummy-package "x"
-- 
2.29.2