Merge branch 'master' into staging

8 files changed, 182 insertions, 97 deletions

diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm
index 5094456ab1..f60d68d9b3 100644
--- a/gnu/build/accounts.scm
+++ b/gnu/build/accounts.scm
@@ -238,7 +238,7 @@ to it atomically and set the appropriate permissions."
       (for-each (lambda (entry)
                   (display (entry->string entry) port)
                   (newline port))
-                entries))
+                (delete-duplicates entries)))
 
     (if (port? file-or-port)
         (write-entries file-or-port)
diff --git a/gnu/build/bootloader.scm b/gnu/build/bootloader.scm
index c5febcde1e..9570d6dd18 100644
--- a/gnu/build/bootloader.scm
+++ b/gnu/build/bootloader.scm
@@ -18,15 +18,8 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (gnu build bootloader)
-  #:use-module (srfi srfi-34)
-  #:use-module (srfi srfi-35)
   #:use-module (ice-9 binary-ports)
-  #:use-module (ice-9 popen)
-  #:use-module (ice-9 match)
-  #:use-module (ice-9 rdelim)
-  #:use-module (ice-9 format)
-  #:export (write-file-on-device
-            invoke/quiet))
+  #:export (write-file-on-device))
 
 
 ;;;
@@ -43,56 +36,3 @@
             (seek output offset SEEK_SET)
             (put-bytevector output bv))
           #:binary #t)))))
-
-(define-syntax-rule (G_ str) str)                 ;for xgettext
-
-(define (open-pipe-with-stderr program . args)
-  "Run PROGRAM with ARGS in an input pipe, but, unlike 'open-pipe*', redirect
-both its standard output and standard error to the pipe.  Return two value:
-the pipe to read PROGRAM's data from, and the PID of the child process running
-PROGRAM."
-  ;; 'open-pipe*' doesn't attempt to capture stderr in any way, which is why
-  ;; we need to roll our own.
-  (match (pipe)
-    ((input .  output)
-     (match (primitive-fork)
-       (0
-        (dynamic-wind
-          (const #t)
-          (lambda ()
-            (close-port input)
-            (dup2 (fileno output) 1)
-            (dup2 (fileno output) 2)
-            (apply execlp program program args))
-          (lambda ()
-            (primitive-exit 127))))
-       (pid
-        (close-port output)
-        (values input pid))))))
-
-;; TODO: Move to (guix build utils) on the next rebuild cycle.
-(define (invoke/quiet program . args)
-  "Invoke PROGRAM with ARGS and capture PROGRAM's standard output and standard
-error.  If PROGRAM succeeds, print nothing and return the unspecified value;
-otherwise, raise a '&message' error condition that includes the status code
-and the output of PROGRAM."
-  (define-values (pipe pid)
-    (apply open-pipe-with-stderr program args))
-
-  (let loop ((lines '()))
-    (match (read-line pipe)
-      ((? eof-object?)
-       (close-port pipe)
-       (match (waitpid pid)
-         ((_ . status)
-          (unless (zero? status)
-            (raise (condition
-                    (&message
-                     (message (format #f (G_ "'~a~{ ~a~}' exited with status ~a; \
-output follows:~%~%~{  ~a~%~}")
-                                      program args
-                                      (or (status:exit-val status)
-                                          status)
-                                      (reverse lines))))))))))
-      (line
-       (loop (cons line lines))))))
diff --git a/gnu/build/cross-toolchain.scm b/gnu/build/cross-toolchain.scm
index d430b8afc4..6bdbdd5411 100644
--- a/gnu/build/cross-toolchain.scm
+++ b/gnu/build/cross-toolchain.scm
@@ -3,6 +3,8 @@
 ;;; Copyright © 2014, 2015, 2018 Mark H Weaver <mhw@netris.org>
 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
 ;;; Copyright © 2016 Manolis Fragkiskos Ragkousis <manolis837@gmail.com>
+;;; Copyright © 2019 Marius Bakke <mbakke@fastmail.com>
+;;; Copyright © 2019 Carl Dong <contact@carldong.me>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -36,11 +38,8 @@
 
 (define %gcc-include-paths
   ;; Environment variables for header search paths.
-  ;; Note: See <http://bugs.gnu.org/22186> for why not 'CPATH'.
-  '("C_INCLUDE_PATH"
-    "CPLUS_INCLUDE_PATH"
-    "OBJC_INCLUDE_PATH"
-    "OBJCPLUS_INCLUDE_PATH"))
+  ;; Note: See <http://bugs.gnu.org/30756> for why not 'C_INCLUDE_PATH' & co.
+  '("CPATH"))
 
 (define %gcc-cross-include-paths
   ;; Search path for target headers when cross-compiling.
@@ -95,7 +94,7 @@ C_INCLUDE_PATH et al."
      ;; We're building the sans-libc cross-compiler, so nothing to do.
      #t)))
 
-(define* (set-cross-path/mingw #:key inputs #:allow-other-keys)
+(define* (set-cross-path/mingw #:key inputs target #:allow-other-keys)
   "Add the cross MinGW headers to CROSS_C_*_INCLUDE_PATH, and remove them from
 C_*INCLUDE_PATH."
   (let ((libc (assoc-ref inputs "libc"))
@@ -112,7 +111,7 @@ C_*INCLUDE_PATH."
 
     (if libc
         (let ((cpath (string-append libc "/include"
-                                    ":" libc "/i686-w64-mingw32/include")))
+                                    ":" libc "/" target "/include")))
           (for-each (cut setenv <> cpath)
                     %gcc-cross-include-paths))
 
@@ -129,7 +128,11 @@ C_*INCLUDE_PATH."
 
             (substitute* (string-append mingw-headers "/crt/_mingw.h")
               (("@MINGW_HAS_SECURE_API@")
-               "#define MINGW_HAS_SECURE_API 1"))
+               "#define MINGW_HAS_SECURE_API 1")
+              (("@DEFAULT_WIN32_WINNT@")
+               "0x502")
+              (("@DEFAULT_MSVCRT_VERSION@")
+               "0x700"))
 
             (let ((cpath (string-append mingw-headers "/include"
                                         ":" mingw-headers "/crt"
@@ -142,7 +145,7 @@ C_*INCLUDE_PATH."
     (when libc
       (setenv "CROSS_LIBRARY_PATH"
               (string-append libc "/lib"
-                             ":" libc "/i686-w64-mingw32/lib")))
+                             ":" libc "/" target "/lib")))
 
     (setenv "CPP" (string-append gcc "/bin/cpp"))
     (for-each (lambda (var)
@@ -168,8 +171,12 @@ C_*INCLUDE_PATH."
 a target triplet."
   (modify-phases phases
     (add-before 'configure 'set-cross-path
-      (if (string-contains target "mingw")
-          set-cross-path/mingw
+      ;; This mingw32 target checking logic should match that of target-mingw?
+      ;; in (guix utils), but (guix utils) is too large too copy over to the
+      ;; build side entirely and for now we have no way to select variables to
+      ;; copy over. See (gnu packages cross-base) for more details.
+      (if (string-suffix? "-mingw32" target)
+          (cut set-cross-path/mingw #:target target <...>)
           set-cross-path))
     (add-after 'install 'make-cross-binutils-visible
       (cut make-cross-binutils-visible #:target target <...>))
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index 03f2ea245c..84a5447977 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -359,8 +359,9 @@ the last argument of `mknod'."
 (define* (mount-root-file-system root type
                                  #:key volatile-root?)
   "Mount the root file system of type TYPE at device ROOT.  If VOLATILE-ROOT?
-is true, mount ROOT read-only and make it a overlay with a writable tmpfs
-using the kernel build-in overlayfs."
+is true, mount ROOT read-only and make it an overlay with a writable tmpfs
+using the kernel built-in overlayfs."
+
   (if volatile-root?
       (begin
         (mkdir-p "/real-root")
@@ -471,10 +472,6 @@ upon error."
              mounts)
         "ext4"))
 
-  (define (lookup-module name)
-    (string-append linux-module-directory "/"
-                   (ensure-dot-ko name)))
-
   (display "Welcome, this is GNU's early boot Guile.\n")
   (display "Use '--repl' for an initrd REPL.\n\n")
 
@@ -489,9 +486,8 @@ upon error."
          (start-repl))
 
        (display "loading kernel modules...\n")
-       (for-each (cut load-linux-module* <>
-                      #:lookup-module lookup-module)
-                 (map lookup-module linux-modules))
+       (load-linux-modules-from-directory linux-modules
+                                          linux-module-directory)
 
        (when keymap-file
          (let ((status (system* "loadkeys" keymap-file)))
diff --git a/gnu/build/linux-container.scm b/gnu/build/linux-container.scm
index 6ccb924861..87695c98fd 100644
--- a/gnu/build/linux-container.scm
+++ b/gnu/build/linux-container.scm
@@ -299,8 +299,10 @@ delete it when leaving the dynamic extent of this call."
         (false-if-exception (delete-file-recursively tmp-dir))))))
 
 (define* (call-with-container mounts thunk #:key (namespaces %namespaces)
-                              (host-uids 1) (guest-uid 0) (guest-gid 0))
-  "Run THUNK in a new container process and return its exit status.
+                              (host-uids 1) (guest-uid 0) (guest-gid 0)
+                              (process-spawned-hook (const #t)))
+  "Run THUNK in a new container process and return its exit status; call
+PROCESS-SPAWNED-HOOK with the PID of the new process that has been spawned.
 MOUNTS is a list of <file-system> objects that specify file systems to mount
 inside the container.  NAMESPACES is a list of symbols corresponding to
 the identifiers for Linux namespaces: mnt, ipc, uts, pid, user, and net.  By
@@ -329,6 +331,7 @@ load path must be adjusted as needed."
            (false-if-exception
             (kill pid SIGKILL))))
 
+       (process-spawned-hook pid)
        (match (waitpid pid)
          ((_ . status) status))))))
 
diff --git a/gnu/build/linux-initrd.scm b/gnu/build/linux-initrd.scm
index 3aaa06d3a0..ea7de58553 100644
--- a/gnu/build/linux-initrd.scm
+++ b/gnu/build/linux-initrd.scm
@@ -71,8 +71,7 @@ COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
       (cpio:write-cpio-archive files port
                                #:file->header cpio:file->cpio-header*)))
 
-  (or (not compress?)
-
+  (if compress?
       ;; Gzip insists on adding a '.gz' suffix and does nothing if the input
       ;; file already has that suffix.  Shuffle files around to placate it.
       (let* ((gz-suffix? (string-suffix? ".gz" output))
@@ -88,7 +87,6 @@ COMPRESS? is true, compress it using GZIP.  On success, return OUTPUT."
                (unless gz-suffix?
                  (rename-file (string-append output ".gz") output))
                output)))
-
       output))
 
 (define (cache-compiled-file-name file)
diff --git a/gnu/build/linux-modules.scm b/gnu/build/linux-modules.scm
index c66ef97012..a149eff329 100644
--- a/gnu/build/linux-modules.scm
+++ b/gnu/build/linux-modules.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2014, 2016, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
+;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -30,8 +31,10 @@
   #:use-module (ice-9 vlist)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
+  #:autoload   (ice-9 pretty-print) (pretty-print)
   #:export (dot-ko
             ensure-dot-ko
+            module-formal-name
             module-aliases
             module-dependencies
             module-soft-dependencies
@@ -42,13 +45,18 @@
             modules-loaded
             module-loaded?
             load-linux-module*
+            load-linux-modules-from-directory
 
             current-module-debugging-port
 
             device-module-aliases
             known-module-aliases
             matching-modules
-            missing-modules))
+            missing-modules
+
+            write-module-name-database
+            write-module-alias-database
+            write-module-device-database))
 
 ;;; Commentary:
 ;;;
@@ -95,6 +103,14 @@ key/value pairs.."
 (define %not-comma
   (char-set-complement (char-set #\,)))
 
+(define (module-formal-name file)
+  "Return the module name of FILE as it appears in its info section.  Usually
+the module name is the same as the base name of FILE, modulo hyphens and minus
+the \".ko\" extension."
+  (match (assq 'name (modinfo-section-contents file))
+    (('name . name) name)
+    (#f #f)))
+
 (define (module-dependencies file)
   "Return the list of modules that FILE depends on.  The returned list
 contains module names, not actual file names."
@@ -310,6 +326,18 @@ appears in BLACK-LIST are not loaded."
              (or (and recursive? (= EEXIST (system-error-errno args)))
                  (apply throw args)))))))
 
+(define (load-linux-modules-from-directory modules directory)
+  "Load MODULES and their dependencies from DIRECTORY, a directory containing
+the '.ko' files.  The '.ko' suffix is automatically added to MODULES if
+needed."
+  (define module-name->file-name
+    (module-name-lookup directory))
+
+  (for-each (lambda (module)
+              (load-linux-module* (module-name->file-name module)
+                                  #:lookup-module module-name->file-name))
+            modules))
+
 
 ;;;
 ;;; Device modules.
@@ -486,4 +514,121 @@ are required to access DEVICE."
         (remove (cut member <> provided) modules))
       '()))
 
+
+;;;
+;;; Module databases.
+;;;
+
+(define (module-name->file-name/guess directory name)
+  "Guess the file name corresponding to NAME, a module name.  That doesn't
+always work because sometimes underscores in NAME map to hyphens (e.g.,
+\"input-leds.ko\"), sometimes not (e.g., \"mac_hid.ko\")."
+  (string-append directory "/" (ensure-dot-ko name)))
+
+(define (module-name-lookup directory)
+  "Return a one argument procedure that takes a module name (e.g.,
+\"input_leds\") and returns its absolute file name (e.g.,
+\"/.../input-leds.ko\")."
+  (catch 'system-error
+    (lambda ()
+      (define mapping
+        (call-with-input-file (string-append directory "/modules.name")
+          read))
+
+      (lambda (name)
+        (or (assoc-ref mapping name)
+            (module-name->file-name/guess directory name))))
+    (lambda args
+      (if (= ENOENT (system-error-errno args))
+          (cut module-name->file-name/guess directory <>)
+          (apply throw args)))))
+
+(define (write-module-name-database directory)
+  "Write a database that maps \"module names\" as they appear in the relevant
+ELF section of '.ko' files, to actual file names.  This format is
+Guix-specific.  It aims to deal with inconsistent naming, in particular
+hyphens vs. underscores."
+  (define mapping
+    (map (lambda (file)
+           (match (module-formal-name file)
+             (#f   (cons (basename file ".ko") file))
+             (name (cons name file))))
+         (find-files directory "\\.ko$")))
+
+  (call-with-output-file (string-append directory "/modules.name")
+    (lambda (port)
+      (display ";; Module name to file name mapping.
+;;
+;; This format is Guix-specific; it is not supported by upstream Linux tools.
+\n"
+               port)
+      (pretty-print mapping port))))
+
+(define (write-module-alias-database directory)
+  "Traverse the '.ko' files in DIRECTORY and create the corresponding
+'modules.alias' file."
+  (define aliases
+    (map (lambda (file)
+           (cons (file-name->module-name file) (module-aliases file)))
+         (find-files directory "\\.ko$")))
+
+  (call-with-output-file (string-append directory "/modules.alias")
+    (lambda (port)
+      (display "# Aliases extracted from modules themselves.\n" port)
+      (for-each (match-lambda
+                  ((module . aliases)
+                   (for-each (lambda (alias)
+                               (format port "alias ~a ~a\n" alias module))
+                             aliases)))
+                aliases))))
+
+(define (aliases->device-tuple aliases)
+  "Traverse ALIASES, a list of module aliases, and search for
+\"char-major-M-N\", \"block-major-M-N\", or \"devname:\" aliases.  When they
+are found, return a tuple (DEVNAME TYPE MAJOR MINOR), otherwise return #f."
+  (define (char/block-major? alias)
+    (or (string-prefix? "char-major-" alias)
+        (string-prefix? "block-major-" alias)))
+
+  (define (char/block-major->tuple alias)
+    (match (string-tokenize alias %not-dash)
+      ((type "major" (= string->number major) (= string->number minor))
+       (list (match type
+               ("char" "c")
+               ("block" "b"))
+             major minor))))
+
+  (let* ((devname     (any (lambda (alias)
+                             (and (string-prefix? "devname:" alias)
+                                  (string-drop alias 8)))
+                           aliases))
+         (major/minor (match (find char/block-major? aliases)
+                        (#f #f)
+                        (str (char/block-major->tuple str)))))
+    (and devname major/minor
+         (cons devname major/minor))))
+
+(define %not-dash
+  (char-set-complement (char-set #\-)))
+
+(define (write-module-device-database directory)
+  "Traverse the '.ko' files in DIRECTORY and create the corresponding
+'modules.devname' file.  This file contains information about modules that can
+be loaded on-demand, such as file system modules."
+  (define aliases
+    (filter-map (lambda (file)
+                  (match (aliases->device-tuple (module-aliases file))
+                    (#f #f)
+                    (tuple (cons (file-name->module-name file) tuple))))
+                (find-files directory "\\.ko$")))
+
+  (call-with-output-file (string-append directory "/modules.devname")
+    (lambda (port)
+      (display "# Device nodes to trigger on-demand module loading.\n" port)
+      (for-each (match-lambda
+                  ((module devname type major minor)
+                   (format port "~a ~a ~a~a:~a~%"
+                           module devname type major minor)))
+                aliases))))
+
 ;;; linux-modules.scm ends here
diff --git a/gnu/build/shepherd.scm b/gnu/build/shepherd.scm
index cf68f2108b..14bdf4edb8 100644
--- a/gnu/build/shepherd.scm
+++ b/gnu/build/shepherd.scm
@@ -67,16 +67,10 @@
           (file-system-mapping
            (source "/etc/group") (target source))))
 
-  (define nscd-socket
-    (file-system-mapping
-     (source "/var/run/nscd") (target source)
-     (writable? #t)))
-
   (append (cons (tmpfs "/tmp") %container-file-systems)
           (let ((mappings `(,@(if (memq 'net namespaces)
                                   '()
-                                  (cons nscd-socket
-                                        %network-file-mappings))
+                                  %network-file-mappings)
                             ,@(if (and (memq 'mnt namespaces)
                                        (not (memq 'user namespaces)))
                                   accounts
@@ -156,14 +150,16 @@ namespace, in addition to essential bind-mounts such /proc."
     (when log-file
       ;; Create LOG-FILE so we can map it in the container.
       (unless (file-exists? log-file)
-        (call-with-output-file log-file (const #t))))
+        (call-with-output-file log-file (const #t))
+        (when user
+          (let ((pw (getpwnam user)))
+            (chown log-file (passwd:uid pw) (passwd:gid pw))))))
 
     (let ((pid (run-container container-directory
                               mounts namespaces 1
                               (lambda ()
                                 (mkdir-p "/var/run")
                                 (clean-up pid-file)
-                                (clean-up log-file)
 
                                 (exec-command command
                                               #:user user