Merge remote-tracking branch 'origin/master' into core-updates

1 files changed, 86 insertions, 11 deletions

diff --git a/guix/lint.scm b/guix/lint.scm
index e1a77e8ac7..be6bb4eb01 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2017, 2018, 2020 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,6 +36,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)
@@ -50,6 +53,7 @@
   #:use-module ((guix swh) #:hide (origin?))
   #:autoload   (guix git-download) (git-reference?
                                     git-reference-url git-reference-commit)
+  #:use-module (guix import stackage)
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 format)
@@ -73,6 +77,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
@@ -87,6 +92,7 @@
             check-formatting
             check-archival
             check-profile-collisions
+            check-haskell-stackage
 
             lint-warning
             lint-warning?
@@ -663,17 +669,11 @@ from ~a")
 (define (check-patch-file-names package)
   "Emit a warning if the patches requires by PACKAGE are badly named or if the
 patch could not be found."
-  (guard (c ((message-condition? c)     ;raised by 'search-patch'
-             (list
-              ;; Use %make-warning, as condition-mesasge is already
-              ;; translated.
-              (%make-warning package (condition-message c)
-                             #:field 'patch-file-names)))
-            ((formatted-message? c)
+  (guard (c ((formatted-message? c)               ;raised by 'search-patch'
              (list (%make-warning package
-                                  (apply format #f
-                                         (G_ (formatted-message-string c))
-                                         (formatted-message-arguments c))))))
+                                  (formatted-message-string c)
+                                  (formatted-message-arguments c)
+                                  #:field 'source))))
     (define patches
       (match (package-source package)
         ((? origin? origin) (origin-patches origin))
@@ -718,6 +718,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
@@ -1240,6 +1288,25 @@ Heritage")
               '()
               (apply throw key args))))))))
 
+(define (check-haskell-stackage package)
+  "Check whether PACKAGE is a Haskell package ahead of the current
+Stackage LTS version."
+  (match (with-networking-fail-safe
+          (format #f (G_ "while retrieving upstream info for '~a'")
+                  (package-name package))
+          #f
+          (package-latest-release package (list %stackage-updater)))
+    ((? upstream-source? source)
+     (if (version>? (package-version package)
+                    (upstream-source-version source))
+         (list
+          (make-warning package
+                        (G_ "ahead of Stackage LTS version ~a")
+                        (list (upstream-source-version source))
+                        #:field 'version))
+         '()))
+    (#f '())))
+
 
 ;;;
 ;;; Source code formatting.
@@ -1424,6 +1491,10 @@ or a list thereof")
     (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")
      (check       check-formatting))))
@@ -1462,7 +1533,11 @@ or a list thereof")
    (lint-checker
      (name        'archival)
      (description "Ensure source code archival on Software Heritage")
-     (check       check-archival))))
+     (check       check-archival))
+   (lint-checker
+     (name        'haskell-stackage)
+     (description "Ensure Haskell packages use Stackage LTS versions")
+     (check       check-haskell-stackage))))
 
 (define %all-checkers
   (append %local-checkers