Merge branch 'master' into staging

16 files changed, 185 insertions, 31 deletions

diff --git a/guix/build/cargo-build-system.scm b/guix/build/cargo-build-system.scm
index 73493af551..c7beffc6e4 100644
--- a/guix/build/cargo-build-system.scm
+++ b/guix/build/cargo-build-system.scm
@@ -123,6 +123,13 @@ directory = '" port)
   (setenv "CC" (string-append (assoc-ref inputs "gcc") "/bin/gcc"))
   (setenv "LIBGIT2_SYS_USE_PKG_CONFIG" "1")
   (setenv "LIBSSH2_SYS_USE_PKG_CONFIG" "1")
+  (when (assoc-ref inputs "openssl")
+    (setenv "OPENSSL_DIR" (assoc-ref inputs "openssl")))
+  (when (assoc-ref inputs "gettext")
+    (setenv "GETTEXT_SYSTEM" (assoc-ref inputs "gettext")))
+  (when (assoc-ref inputs "clang")
+    (setenv "LIBCLANG_PATH"
+            (string-append (assoc-ref inputs "clang") "/lib")))
 
   ;; We don't use the Cargo.lock file to determine the package versions we use
   ;; during building, and in any case if one is not present it is created
diff --git a/guix/cpio.scm b/guix/cpio.scm
index e4692e2e9c..c9932f5bf9 100644
--- a/guix/cpio.scm
+++ b/guix/cpio.scm
@@ -27,6 +27,7 @@
             make-cpio-header
             file->cpio-header
             file->cpio-header*
+            special-file->cpio-header*
             write-cpio-header
             read-cpio-header
 
@@ -132,9 +133,10 @@
     (%make-cpio-header MAGIC
                        inode mode uid gid
                        nlink mtime
-                       (if (= C_ISDIR (logand mode C_FMT))
-                           0
-                           size)
+                       (if (or (= C_ISLNK (logand mode C_FMT))
+                               (= C_ISREG (logand mode C_FMT)))
+                           size
+                           0)
                        major minor rmajor rminor
                        (+ name-size 1)              ;include trailing zero
                        0)))                          ;checksum
@@ -146,6 +148,8 @@ denotes, similar to 'stat:type'."
     (cond ((= C_ISREG fmt) 'regular)
           ((= C_ISDIR fmt) 'directory)
           ((= C_ISLNK fmt) 'symlink)
+          ((= C_ISBLK fmt) 'block-special)
+          ((= C_ISCHR fmt) 'char-special)
           (else
            (error "unsupported file type" mode)))))
 
@@ -187,6 +191,25 @@ produced in a deterministic fashion."
                       #:size (stat:size st)
                       #:name-size (string-length file-name))))
 
+(define* (special-file->cpio-header* file
+                                     device-type
+                                     device-major
+                                     device-minor
+                                     permission-bits
+                                     #:optional (file-name file))
+  "Create a character or block device header.
+
+DEVICE-TYPE is either 'char-special or 'block-special.
+
+The number of hard links is assumed to be 1."
+  (make-cpio-header #:mode (logior (match device-type
+                                    ('block-special C_ISBLK)
+                                    ('char-special C_ISCHR))
+                                    permission-bits)
+                    #:nlink 1
+                    #:rdev (device-number device-major device-minor)
+                    #:name-size (string-length file-name)))
+
 (define %trailer
   "TRAILER!!!")
 
@@ -233,6 +256,10 @@ produces with the '-H newc' option."
            (put-string port target)))
         ((directory)
          #t)
+        ((block-special)
+         #t)
+        ((char-special)
+         #t)
         (else
          (error "file type not supported")))
 
diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm
index 35c67cad8d..6ca4f65cb0 100644
--- a/guix/import/hackage.scm
+++ b/guix/import/hackage.scm
@@ -40,7 +40,8 @@
   #:use-module (guix upstream)
   #:use-module (guix packages)
   #:use-module ((guix utils) #:select (call-with-temporary-output-file))
-  #:export (hackage->guix-package
+  #:export (%hackage-url
+            hackage->guix-package
             hackage-recursive-import
             %hackage-updater
 
@@ -92,20 +93,23 @@
 
 (define package-name-prefix "ghc-")
 
+(define %hackage-url
+  (make-parameter "https://hackage.haskell.org"))
+
 (define (hackage-source-url name version)
   "Given a Hackage package NAME and VERSION, return a url to the source
 tarball."
-  (string-append "https://hackage.haskell.org/package/" name
-                 "/" name "-" version ".tar.gz"))
+  (string-append (%hackage-url) "/package/"
+                 name "/" name "-" version ".tar.gz"))
 
 (define* (hackage-cabal-url name #:optional version)
   "Given a Hackage package NAME and VERSION, return a url to the corresponding
 .cabal file on Hackage.  If VERSION is #f or missing, the url for the latest
 version is returned."
   (if version
-      (string-append "https://hackage.haskell.org/package/"
+      (string-append (%hackage-url) "/package/"
                      name "-" version "/" name ".cabal")
-      (string-append "https://hackage.haskell.org/package/"
+      (string-append (%hackage-url) "/package/"
                      name "/" name ".cabal")))
 
 (define (hackage-name->package-name name)
diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index 93cf214127..77cc6350cb 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -30,7 +30,8 @@
   #:use-module (guix memoization)
   #:use-module (guix packages)
   #:use-module (guix upstream)
-  #:export (stackage->guix-package
+  #:export (%stackage-url
+            stackage->guix-package
             stackage-recursive-import
             %stackage-updater))
 
@@ -39,7 +40,8 @@
 ;;; Stackage info fetcher and access functions
 ;;;
 
-(define %stackage-url "https://www.stackage.org")
+(define %stackage-url
+  (make-parameter "https://www.stackage.org"))
 
 ;; Latest LTS version compatible with GHC 8.6.5.
 (define %default-lts-version "14.27")
@@ -55,7 +57,7 @@
   ;; "Retrieve the information about the LTS Stackage release VERSION."
   (memoize
    (lambda* (#:optional (version ""))
-     (let* ((url (string-append %stackage-url
+     (let* ((url (string-append (%stackage-url)
                                 "/lts-" (if (string-null? version)
                                             %default-lts-version
                                             version)))
diff --git a/guix/lint.scm b/guix/lint.scm
index 91dbc806dc..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?
@@ -712,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
@@ -1234,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.
@@ -1418,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))))
@@ -1456,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
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index cc020632af..a959cb827d 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -182,8 +182,6 @@ options handled by 'set-build-options-from-command-line', and listed in
   (display (G_ "
   -M, --max-jobs=N       allow at most N build jobs"))
   (display (G_ "
-      --help-transform   list package transformation options not shown here"))
-  (display (G_ "
       --debug=LEVEL      produce debugging output at LEVEL")))
 
 (define (set-build-options-from-command-line store opts)
@@ -319,14 +317,7 @@ use '--no-offload' instead~%")))
                     (if c
                         (apply values (alist-cons 'max-jobs c result) rest)
                         (leave (G_ "not a number: '~a' option argument: ~a~%")
-                               name arg)))))
-        (option '("help-transform") #f #f
-                (lambda _
-                  (format #t
-                          (G_ "Available package transformation options:~%"))
-                  (show-transformation-options-help)
-                  (newline)
-                  (exit 0)))))
+                               name arg)))))))
 
 
 ;;;
@@ -383,6 +374,8 @@ Build the given PACKAGE-OR-DERIVATION and return their output paths.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm
index 2328df98b8..e435bf0ce4 100644
--- a/guix/scripts/environment.scm
+++ b/guix/scripts/environment.scm
@@ -180,6 +180,8 @@ COMMAND or an interactive shell in that environment.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
diff --git a/guix/scripts/graph.scm b/guix/scripts/graph.scm
index 6874904deb..ddfc6ba497 100644
--- a/guix/scripts/graph.scm
+++ b/guix/scripts/graph.scm
@@ -35,7 +35,8 @@
   #:use-module ((guix diagnostics)
                 #:select (location-file formatted-message))
   #:use-module ((guix transformations)
-                #:select (options->transformation
+                #:select (show-transformation-options-help
+                          options->transformation
                           %transformation-options))
   #:use-module ((guix scripts build)
                 #:select (%standard-build-options))
@@ -546,6 +547,8 @@ Emit a representation of the dependency graph of PACKAGE...\n"))
   (display (G_ "
   -L, --load-path=DIR    prepend DIR to the package module search path"))
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
diff --git a/guix/scripts/install.scm b/guix/scripts/install.scm
index 82f5875dd1..63e625f266 100644
--- a/guix/scripts/install.scm
+++ b/guix/scripts/install.scm
@@ -39,6 +39,8 @@ This is an alias for 'guix package -i'.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm
index 18cd167537..c72dc3caad 100644
--- a/guix/scripts/lint.scm
+++ b/guix/scripts/lint.scm
@@ -10,6 +10,7 @@
 ;;; Copyright © 2017, 2018 Efraim Flashner <efraim@flashner.co.il>
 ;;; Copyright © 2018, 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;; Copyright © 2019, 2020 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2020 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -47,11 +48,15 @@
   ;; provided MESSAGE.
   (for-each
    (lambda (lint-warning)
-     (let ((package (lint-warning-package lint-warning))
-           (loc     (lint-warning-location lint-warning)))
-       (info loc (G_ "~a@~a: ~a~%")
-             (package-name package) (package-version package)
-             (lint-warning-message lint-warning))))
+     (let* ((package (lint-warning-package lint-warning))
+            (name    (package-name package))
+            (version (package-version package))
+            (loc     (lint-warning-location lint-warning))
+            (message (lint-warning-message lint-warning)))
+       (parameterize
+           ((guix-warning-port (current-output-port)))
+         (info loc (G_ "~a@~a: ~a~%")
+               name version message))))
    warnings))
 
 (define* (run-checkers package checkers #:key store)
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index 0b29997200..ba9a6dc1b2 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -1067,6 +1067,8 @@ last resort for relocation."
 Create a bundle of PACKAGE.\n"))
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -f, --format=FORMAT    build a pack in the given FORMAT"))
   (display (G_ "
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index eb2e67a0de..6faf2adb7a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -398,6 +398,8 @@ Install, remove, or upgrade packages in a single transaction.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
diff --git a/guix/scripts/publish.scm b/guix/scripts/publish.scm
index f1a9970a7f..2a2185e2b9 100644
--- a/guix/scripts/publish.scm
+++ b/guix/scripts/publish.scm
@@ -63,10 +63,14 @@
   #:use-module ((guix build utils)
                 #:select (dump-port mkdir-p find-files))
   #:use-module ((guix build syscalls) #:select (set-thread-name))
-  #:export (%public-key
+  #:export (%default-gzip-compression
+
+            %public-key
             %private-key
             signed-string
 
+            open-server-socket
+            run-publish-server
             guix-publish))
 
 (define (show-help)
diff --git a/guix/scripts/upgrade.scm b/guix/scripts/upgrade.scm
index 1ee8937acf..dcbcb2ab09 100644
--- a/guix/scripts/upgrade.scm
+++ b/guix/scripts/upgrade.scm
@@ -42,6 +42,8 @@ This is an alias for 'guix package -u'.\n"))
   (newline)
   (show-build-options-help)
   (newline)
+  (show-transformation-options-help)
+  (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
   (display (G_ "
diff --git a/guix/store.scm b/guix/store.scm
index d859ea33ed..11e2dae579 100644
--- a/guix/store.scm
+++ b/guix/store.scm
@@ -113,6 +113,7 @@
             build
             query-failed-paths
             clear-failed-paths
+            ensure-path
             add-temp-root
             add-indirect-root
             add-permanent-root
@@ -1397,6 +1398,11 @@ When a handler is installed with 'with-build-handler', it is called any time
                                          (message "unsupported build mode")
                                          (status  1))))))))))))
 
+(define-operation (ensure-path (store-path path))
+  "Make PATH a temporary root for the duration of the current session.
+Return #t."
+  boolean)
+
 (define-operation (add-temp-root (store-path path))
   "Make PATH a temporary root for the duration of the current session.
 Return #t."
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 30142dd059..d49041cf59 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -508,9 +508,17 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
           (option '("with-debug-info") #t #f
                   (parser 'with-debug-info))
           (option '("without-tests") #t #f
-                  (parser 'without-tests)))))
+                  (parser 'without-tests))
 
-(define (show-transformation-options-help)
+          (option '("help-transform") #f #f
+                  (lambda _
+                    (format #t
+                            (G_ "Available package transformation options:~%"))
+                    (show-transformation-options-help/detailed)
+                    (newline)
+                    (exit 0))))))
+
+(define (show-transformation-options-help/detailed)
   (display (G_ "
       --with-source=[PACKAGE=]SOURCE
                          use SOURCE when building the corresponding package"))
@@ -539,6 +547,10 @@ to the same package but with #:strip-binaries? #f in its 'arguments' field."
       --without-tests=PACKAGE
                          build PACKAGE without running its tests")))
 
+(define (show-transformation-options-help)
+  "Show basic help for package transformation options."
+  (display (G_ "
+      --help-transform   list package transformation options not shown here")))
 
 (define (options->transformation opts)
   "Return a procedure that, when passed an object to build (package,