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

6 files changed, 92 insertions, 44 deletions

diff --git a/guix/build/download.scm b/guix/build/download.scm
index c8ddadfdd4..fd8fe69901 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -674,10 +674,23 @@ and write the output to FILE."
      (match (fetch-specification uris)
        (#f (format #t "could not find its Disarchive specification~%")
            #f)
-       (spec (parameterize ((%disarchive-log-port (current-output-port)))
+       (spec (parameterize ((%disarchive-log-port (current-output-port))
+                            (%verify-swh-certificate? verify-certificate?))
                (false-if-exception*
                 (disarchive-assemble spec file #:resolver resolve))))))))
 
+(define (internet-archive-uri uri)
+  "Return a URI corresponding to an Internet Archive backup of URI, or #f if
+URI does not denote a Web URI."
+  (and (memq (uri-scheme uri) '(http https))
+       (let* ((now  (time-utc->date (current-time time-utc)))
+              (date (date->string now "~Y~m~d~H~M~S")))
+         ;; Note: the date in the URL can be anything and web.archive.org
+         ;; automatically redirects to the closest date.
+         (build-uri 'https #:host "web.archive.org"
+                    #:path (string-append "/web/" date "/"
+                                          (uri->string uri))))))
+
 (define* (url-fetch url file
                     #:key
                     (timeout 10) (verify-certificate? #t)
@@ -769,7 +782,12 @@ otherwise simply ignore them."
 
   (setvbuf (current-error-port) 'line)
 
-  (let try ((uri (append uri content-addressed-uris)))
+  (let try ((uri (append uri content-addressed-uris
+                   (match uri
+                     ((first . _)
+                      (or (and=> (internet-archive-uri first) list)
+                          '()))
+                     (() '())))))
     (match uri
       ((uri tail ...)
        (or (fetch uri file)
diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm
index 5f7ba71244..64ef40e25a 100644
--- a/guix/build/emacs-utils.scm
+++ b/guix/build/emacs-utils.scm
@@ -2,7 +2,7 @@
 ;;; Copyright © 2014, 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2018, 2020 Maxim Cournoyer <maxim.cournoyer@gmail.com>
-;;; Copyright © 2019 Leo Prikler <leo.prikler@student.tugraz.at>
+;;; Copyright © 2019 Liliana Marie Prikler <liliana.prikler@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm
index 28253ce2f0..ef6cb316ee 100644
--- a/guix/build/haskell-build-system.scm
+++ b/guix/build/haskell-build-system.scm
@@ -4,6 +4,7 @@
 ;;; Copyright © 2015 Paul van der Walt <paul@denknerd.org>
 ;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com>
+;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -63,13 +64,14 @@
                      ((file-exists? "Setup.lhs")
                       "Setup.lhs")
                      (else
-                      #f))))
+                      #f)))
+        (pkgdb (string-append "-package-db=" %tmp-db-dir)))
     (if setup-file
         (begin
           (format #t "running \"runhaskell Setup.hs\" with command ~s \
 and parameters ~s~%"
                   command params)
-          (apply invoke "runhaskell" setup-file command params))
+          (apply invoke "runhaskell" pkgdb setup-file command params))
         (error "no Setup.hs nor Setup.lhs found"))))
 
 (define* (configure #:key outputs inputs tests? (configure-flags '())
@@ -141,17 +143,6 @@ and parameters ~s~%"
                 (find-files lib "\\.a$"))))
   #t)
 
-(define (grep rx port)
-  "Given a regular-expression RX including a group, read from PORT until the
-first match and return the content of the group."
-  (let ((line (read-line port)))
-    (if (eof-object? line)
-        #f
-        (let ((rx-result (regexp-exec rx line)))
-          (if rx-result
-              (match:substring rx-result 1)
-              (grep rx port))))))
-
 (define* (setup-compiler #:key system inputs outputs #:allow-other-keys)
   "Setup the compiler environment."
   (let* ((haskell (assoc-ref inputs "haskell"))
@@ -173,15 +164,8 @@ first match and return the content of the group."
   "Generate the GHC package database."
   (let* ((haskell  (assoc-ref inputs "haskell"))
          (name-version (strip-store-file-name haskell))
-         (input-dirs (match inputs
-                       (((_ . dir) ...)
-                        dir)
-                       (_ '())))
          ;; Silence 'find-files' (see 'evaluate-search-paths')
-         (conf-dirs (with-null-error-port
-                     (search-path-as-list
-                      `(,(string-append "lib/" name-version))
-                      input-dirs #:pattern ".*\\.conf.d$")))
+         (conf-dirs (search-path-as-string->list (getenv "GHC_PACKAGE_PATH")))
          (conf-files (append-map (cut find-files <> "\\.conf$") conf-dirs)))
     (mkdir-p %tmp-db-dir)
     (for-each (lambda (file)
@@ -233,6 +217,8 @@ given Haskell package."
          (if (not (vhash-assoc id seen))
              (let ((dep-conf  (string-append src  "/" id ".conf"))
                    (dep-conf* (string-append dest "/" id ".conf")))
+               (when (not (file-exists? dep-conf))
+                   (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file)))
                (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead?
                (loop (vhash-cons id #t seen)
                      (append lst (conf-depends dep-conf))))
@@ -241,12 +227,13 @@ given Haskell package."
   (let* ((out (assoc-ref outputs "out"))
          (doc (assoc-ref outputs "doc"))
          (haskell  (assoc-ref inputs "haskell"))
-         (name-verion (strip-store-file-name haskell))
+         (name-version (strip-store-file-name haskell))
+         (version (last (string-split name-version #\-)))
          (lib (string-append (or (assoc-ref outputs "lib") out) "/lib"))
          (config-dir (string-append lib
-                                    "/" name-verion
+                                    "/ghc-" version
                                     "/" name ".conf.d"))
-         (id-rx (make-regexp "^id: *(.*)$"))
+         (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline))
          (config-file (string-append out "/" name ".conf"))
          (params
           (list (string-append "--gen-pkg-config=" config-file))))
@@ -254,8 +241,15 @@ given Haskell package."
     ;; The conf file is created only when there is a library to register.
     (when (file-exists? config-file)
       (mkdir-p config-dir)
-      (let ((config-file-name+id
-             (call-with-ascii-input-file config-file (cut grep id-rx <>))))
+      (let* ((contents (call-with-input-file config-file read-string))
+             (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1)))
+
+        (when (or
+                (and
+                  (string? config-file-name+id)
+                  (string-null? config-file-name+id))
+                (not config-file-name+id))
+          (error (format #f "The package id for ~a is empty. This is a bug." config-file)))
 
         ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the
         ;; "haddock-interfaces" field and removing the optional "haddock-html"
diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm
index 729ab6154f..18ccf7cd8b 100644
--- a/guix/build/linux-module-build-system.scm
+++ b/guix/build/linux-module-build-system.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2019 Danny Milosavljevic <dannym@scratchpost.org>
 ;;; Copyright © 2020 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -33,7 +34,7 @@
 ;;
 ;; Code:
 
-;; Copied from make-linux-libre's "configure" phase.
+;; Similar to make-linux-libre's "configure" phase.
 (define* (configure #:key inputs target arch #:allow-other-keys)
   (setenv "KCONFIG_NOTIMESTAMP" "1")
   (setenv "KBUILD_BUILD_TIMESTAMP" (getenv "SOURCE_DATE_EPOCH"))
@@ -42,23 +43,28 @@
   (format #t "`ARCH' set to `~a'~%" (getenv "ARCH"))
 
   (when target
+    ;; TODO? (setenv "EXTRA_VERSION" ,extra-version)
+    ;; TODO? kernel ".config".
     (setenv "CROSS_COMPILE" (string-append target "-"))
     (format #t "`CROSS_COMPILE' set to `~a'~%"
-               (getenv "CROSS_COMPILE")))
-  ; TODO: (setenv "EXTRA_VERSION" ,extra-version)
-  ; TODO: kernel ".config".
-  #t)
+            (getenv "CROSS_COMPILE"))))
 
-(define* (build #:key inputs make-flags (source-directory ".") #:allow-other-keys)
+(define* (build #:key (make-flags '()) (parallel-build? #t)
+                (source-directory ".")
+                inputs
+                #:allow-other-keys)
   (apply invoke "make" "-C"
          (string-append (assoc-ref inputs "linux-module-builder")
                         "/lib/modules/build")
-         (string-append "M=" (getcwd) "/" source-directory)
-         (or make-flags '())))
+         (string-append "M=" (canonicalize-path source-directory))
+         `(,@(if parallel-build?
+                 `("-j" ,(number->string (parallel-job-count)))
+                 '())
+           ,@make-flags)))
 
-;; This block was copied from make-linux-libre--only took the "modules_install"
-;; part.
-(define* (install #:key make-flags (source-directory ".")
+;; Similar to the "modules_install" part of make-linux-libre.
+(define* (install #:key (make-flags '()) (parallel-build? #t)
+                  (source-directory ".")
                   inputs native-inputs outputs
                   #:allow-other-keys)
   (let* ((out (assoc-ref outputs "out"))
@@ -68,7 +74,7 @@
     (apply invoke "make" "-C"
             (string-append (assoc-ref inputs "linux-module-builder")
                            "/lib/modules/build")
-            (string-append "M=" (getcwd) "/" source-directory)
+            (string-append "M=" (canonicalize-path source-directory))
             ;; Disable depmod because the Guix system's module directory
             ;; is an union of potentially multiple packages.  It is not
             ;; possible to use depmod to usefully calculate a dependency
@@ -79,7 +85,10 @@
             (string-append "INSTALL_MOD_PATH=" out)
             "INSTALL_MOD_STRIP=1"
             "modules_install"
-            (or make-flags '()))))
+         `(,@(if parallel-build?
+                 `("-j" ,(number->string (parallel-job-count)))
+                 '())
+           ,@make-flags))))
 
 (define %standard-phases
   (modify-phases gnu:%standard-phases
diff --git a/guix/build/renpy-build-system.scm b/guix/build/renpy-build-system.scm
index 66683971c5..e4a88456be 100644
--- a/guix/build/renpy-build-system.scm
+++ b/guix/build/renpy-build-system.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2021 Leo Prikler <leo.prikler@student.tugraz.at>
+;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index ac1b0c2eea..99a3b45004 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -7,6 +7,7 @@
 ;;; Copyright © 2020 Julien Lepiller <julien@lepiller.eu>
 ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
+;;; Copyright © 2021 Tobias Geerinckx-Rice <me@tobias.gr>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -56,6 +57,9 @@
 
             restart-on-EINTR
 
+            device-number
+            device-number->major+minor
+
             mount?
             mount-device-number
             mount-source
@@ -450,6 +454,29 @@ the returned procedure is called."
 
 
 ;;;
+;;; Block devices.
+;;;
+
+;; Convert between major:minor pairs and packed ‘device number’ representation.
+;; XXX These aren't syscalls, but if you squint very hard they are part of the
+;; FFI or however you want to justify me not finding a better fit… :-)
+(define (device-number major minor)     ; see glibc's <sys/sysmacros.h>
+  "Return the device number for the device with MAJOR and MINOR, for use as
+the last argument of `mknod'."
+  (logior (ash (logand #x00000fff major) 8)
+          (ash (logand #xfffff000 major) 32)
+               (logand #x000000ff minor)
+          (ash (logand #xffffff00 minor) 12)))
+
+(define (device-number->major+minor device)     ; see glibc's <sys/sysmacros.h>
+  "Return two values: the major and minor device numbers that make up DEVICE."
+  (values (logior (ash (logand #x00000000000fff00 device) -8)
+                  (ash (logand #xfffff00000000000 device) -32))
+          (logior      (logand #x00000000000000ff device)
+                  (ash (logand #x00000ffffff00000 device) -12))))
+
+
+;;;
 ;;; File systems.
 ;;;
 
@@ -628,7 +655,7 @@ current process."
   (define (string->device-number str)
     (match (string-split str #\:)
       (((= string->number major) (= string->number minor))
-       (+ (* major 256) minor))))
+       (device-number major minor))))
 
   (call-with-input-file "/proc/self/mountinfo"
     (lambda (port)