Merge branch 'staging' into core-updates

7 files changed, 251 insertions, 79 deletions

diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl
index a140082c0b..7d984155bc 100644
--- a/gnu/system/examples/vm-image.tmpl
+++ b/gnu/system/examples/vm-image.tmpl
@@ -4,9 +4,10 @@
 ;;   guix system reconfigure /etc/config.scm
 ;;
 
-(use-modules (gnu) (srfi srfi-1))
+(use-modules (gnu) (guix) (srfi srfi-1))
 (use-service-modules desktop networking ssh xorg)
-(use-package-modules bootloaders certs fonts nvi wget xorg)
+(use-package-modules bootloaders certs fonts nvi
+                     package-management wget xorg)
 
 (define vm-image-motd (plain-file "motd" "
 \x1b[1;37mThis is the GNU system.  Welcome!\x1b[0m
@@ -34,6 +35,9 @@ accounts.\x1b[0m
   (locale "en_US.utf8")
   (keyboard-layout (keyboard-layout "us" "altgr-intl"))
 
+  ;; Label for the GRUB boot menu.
+  (label (string-append "GNU Guix " (package-version guix)))
+
   (firmware '())
 
   ;; Below we assume /dev/vda is the VM's hard disk.
@@ -88,14 +92,18 @@ root ALL=(ALL) ALL
                  ;; Use the DHCP client service rather than NetworkManager.
                  (service dhcp-client-service-type))
 
-           ;; Remove GDM, NetworkManager, and wpa-supplicant, which don't make
-           ;; sense in a VM.
+           ;; Remove GDM, ModemManager, NetworkManager, and wpa-supplicant,
+           ;; which don't make sense in a VM.
            (remove (lambda (service)
                      (let ((type (service-kind service)))
-                       (memq type (list gdm-service-type
-                                        wpa-supplicant-service-type
-                                        cups-pk-helper-service-type
-                                        network-manager-service-type))))
+                       (or (memq type
+                                 (list gdm-service-type
+                                       wpa-supplicant-service-type
+                                       cups-pk-helper-service-type
+                                       network-manager-service-type
+                                       modem-manager-service-type))
+                           (eq? 'network-manager-applet
+                                (service-type-name type)))))
                    (modify-services %desktop-services
                      (login-service-type config =>
                                          (login-configuration
diff --git a/gnu/system/install.scm b/gnu/system/install.scm
index 45c6051732..453b0bdd6d 100644
--- a/gnu/system/install.scm
+++ b/gnu/system/install.scm
@@ -85,7 +85,8 @@
   '(("de" . "Systeminstallation")
     ("en" . "System Installation")
     ("es" . "Instalación del sistema")
-    ("fr" . "Installation du système")))
+    ("fr" . "Installation du système")
+    ("ru" . "Установка системы")))
 
 (define (log-to-info tty user)
   "Return a script that spawns the Info reader on the right section of the
diff --git a/gnu/system/linux-container.scm b/gnu/system/linux-container.scm
index 149c3d08a3..16eee7a3cd 100644
--- a/gnu/system/linux-container.scm
+++ b/gnu/system/linux-container.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2015 David Thompson <davet@gnu.org>
 ;;; Copyright © 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -35,7 +36,7 @@
             containerized-operating-system
             container-script))
 
-(define (container-essential-services os)
+(define* (container-essential-services os #:key shared-network?)
   "Return a list of essential services corresponding to OS, a
 non-containerized OS.  This procedure essentially strips essential services
 from OS that are needed on the bare metal and not in a container."
@@ -45,18 +46,32 @@ from OS that are needed on the bare metal and not in a container."
                     (list (service-kind %linux-bare-metal-service)
                           firmware-service-type
                           system-service-type)))
-            (operating-system-essential-services os)))
+            (operating-system-default-essential-services os)))
 
   (cons (service system-service-type
                  (let ((locale (operating-system-locale-directory os)))
                    (with-monad %store-monad
                      (return `(("locale" ,locale))))))
-        base))
+        ;; If network is to be shared with the host, remove network
+        ;; configuration files from etc-service.
+        (if shared-network?
+            (modify-services base
+              (etc-service-type
+               files => (remove
+                         (match-lambda
+                           ((filename _)
+                            (member filename
+                                    (map basename %network-configuration-files))))
+                         files)))
+            base)))
 
-(define (containerized-operating-system os mappings)
+(define* (containerized-operating-system os mappings
+                                         #:key
+                                         shared-network?
+                                         (extra-file-systems '()))
   "Return an operating system based on OS for use in a Linux container
 environment.  MAPPINGS is a list of <file-system-mapping> to realize in the
-containerized OS."
+containerized OS.  EXTRA-FILE-SYSTEMS is a list of file systems to add to OS."
   (define user-file-systems
     (remove (lambda (fs)
               (let ((target (file-system-mount-point fs))
@@ -65,8 +80,8 @@ containerized OS."
                     (string=? target "/")
                     (and (string? source)
                          (string-prefix? "/dev/" source))
-                    (string-prefix? "/dev" target)
-                    (string-prefix? "/sys" target))))
+                    (string-prefix? "/dev/" target)
+                    (string-prefix? "/sys/" target))))
             (operating-system-file-systems os)))
 
   (define (mapping->fs fs)
@@ -76,28 +91,63 @@ containerized OS."
   (define useless-services
     ;; Services that make no sense in a container.  Those that attempt to
     ;; access /dev/tty[0-9] in particular cannot work in a container.
-    (list console-font-service-type
-          mingetty-service-type
-          agetty-service-type))
+    (append (list console-font-service-type
+                  mingetty-service-type
+                  agetty-service-type)
+            ;; Remove nscd service if network is shared with the host.
+            (if shared-network?
+                (list nscd-service-type)
+                (list))))
 
   (operating-system
     (inherit os)
     (swap-devices '()) ; disable swap
-    (essential-services (container-essential-services os))
+    (essential-services (container-essential-services
+                         this-operating-system
+                         #:shared-network? shared-network?))
     (services (remove (lambda (service)
                         (memq (service-kind service)
                               useless-services))
                       (operating-system-user-services os)))
-    (file-systems (append (map mapping->fs (cons %store-mapping mappings))
-                          %container-file-systems
-                          user-file-systems))))
+    (file-systems (append (map mapping->fs mappings)
+                          extra-file-systems
+                          user-file-systems
 
-(define* (container-script os #:key (mappings '()))
+                          ;; Provide a dummy root file system so we can create
+                          ;; a 'boot-parameters' file.
+                          (list (file-system
+                                  (mount-point "/")
+                                  (device "nothing")
+                                  (type "dummy")))))))
+
+(define* (container-script os #:key (mappings '()) shared-network?)
   "Return a derivation of a script that runs OS as a Linux container.
 MAPPINGS is a list of <file-system> objects that specify the files/directories
 that will be shared with the host system."
-  (let* ((os           (containerized-operating-system os mappings))
-         (file-systems (filter file-system-needed-for-boot?
+  (define network-mappings
+    ;; Files to map if network is to be shared with the host
+    (append %network-file-mappings
+            (let ((nscd-run-directory "/var/run/nscd"))
+              (if (file-exists? nscd-run-directory)
+                  (list (file-system-mapping
+                         (source nscd-run-directory)
+                         (target nscd-run-directory)))
+                  '()))))
+
+  (define (mountable-file-system? file-system)
+    ;; Return #t if FILE-SYSTEM should be mounted in the container.
+    (and (not (string=? "/" (file-system-mount-point file-system)))
+         (file-system-needed-for-boot? file-system)))
+
+  (let* ((os           (containerized-operating-system
+                        os
+                        (cons %store-mapping
+                              (if shared-network?
+                                  (append network-mappings mappings)
+                                  mappings))
+                        #:shared-network? shared-network?
+                        #:extra-file-systems %container-file-systems))
+         (file-systems (filter mountable-file-system?
                                (operating-system-file-systems os)))
          (specs        (map file-system->spec file-systems)))
 
@@ -121,6 +171,9 @@ that will be shared with the host system."
               ;; users and groups, which is sufficient for most cases.
               ;;
               ;; See: http://www.freedesktop.org/software/systemd/man/systemd-nspawn.html#--private-users=
-              #:host-uids 65536))))
+              #:host-uids 65536
+              #:namespaces (if #$shared-network?
+                               (delq 'net %namespaces)
+                               %namespaces)))))
 
     (gexp->script "run-container" script)))
diff --git a/gnu/system/locale.scm b/gnu/system/locale.scm
index 75417f6698..533a45e149 100644
--- a/gnu/system/locale.scm
+++ b/gnu/system/locale.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -20,6 +20,7 @@
 (define-module (gnu system locale)
   #:use-module (guix gexp)
   #:use-module (guix store)
+  #:use-module (guix modules)
   #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module (guix utils)
@@ -37,7 +38,9 @@
             locale-directory
 
             %default-locale-libcs
-            %default-locale-definitions))
+            %default-locale-definitions
+
+            glibc-supported-locales))
 
 ;;; Commentary:
 ;;;
@@ -202,4 +205,69 @@ data format changes between libc versions."
                         "vi_VN"
                         "zh_CN"))))
 
+
+;;;
+;;; Locales supported by glibc.
+;;;
+
+(define* (glibc-supported-locales #:optional (glibc glibc))
+  "Return a file-like object that contains a list of locale name/encoding
+pairs such as (\"oc_FR.UTF-8\" . \"UTF-8\").  Each pair corresponds to a
+locale supported by GLIBC."
+  (define build
+    (with-imported-modules (source-module-closure
+                            '((guix build gnu-build-system)))
+      #~(begin
+          (use-modules (guix build gnu-build-system)
+                       (srfi srfi-1)
+                       (ice-9 rdelim)
+                       (ice-9 match)
+                       (ice-9 regex)
+                       (ice-9 pretty-print))
+
+          (define unpack
+            (assq-ref %standard-phases 'unpack))
+
+          (define locale-rx
+            ;; Regexp matching a locale line in 'localedata/SUPPORTED'.
+            (make-regexp
+             "^[[:space:]]*([[:graph:]]+)/([[:graph:]]+)[[:space:]]*\\\\$"))
+
+          (define (read-supported-locales port)
+            ;; Read the 'localedata/SUPPORTED' file from PORT.  That file is
+            ;; actually a makefile snippet, with one locale per line, and a
+            ;; header that can be discarded.
+            (let loop ((locales '()))
+              (define line
+                (read-line port))
+
+              (cond ((eof-object? line)
+                     (reverse locales))
+                    ((string-prefix? "#" (string-trim line)) ;comment
+                     (loop locales))
+                    ((string-contains line "=")  ;makefile variable assignment
+                     (loop locales))
+                    (else
+                     (match (regexp-exec locale-rx line)
+                       (#f
+                        (loop locales))
+                       (m
+                        (loop (alist-cons (match:substring m 1)
+                                          (match:substring m 2)
+                                          locales))))))))
+
+          (setenv "PATH"
+                  (string-append #+(file-append tar "/bin") ":"
+                                 #+(file-append xz "/bin") ":"
+                                 #+(file-append gzip "/bin")))
+          (unpack #:source #+(package-source glibc))
+
+          (let ((locales (call-with-input-file "localedata/SUPPORTED"
+                           read-supported-locales)))
+            (call-with-output-file #$output
+              (lambda (port)
+                (pretty-print locales port)))))))
+
+  (computed-file "glibc-supported-locales.scm" build))
+
 ;;; locale.scm ends here
diff --git a/gnu/system/pam.scm b/gnu/system/pam.scm
index 13f76a50ed..85f75517b1 100644
--- a/gnu/system/pam.scm
+++ b/gnu/system/pam.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -207,40 +207,47 @@ dumped in /etc/pam.d/NAME, where NAME is the name of SERVICE."
         (env  (pam-entry ; to honor /etc/environment.
                (control "required")
                (module "pam_env.so"))))
-    (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd)
+    (lambda* (name #:key allow-empty-passwords? (allow-root? #f) motd
+                   login-uid?)
       "Return a standard Unix-style PAM service for NAME.  When
 ALLOW-EMPTY-PASSWORDS? is true, allow empty passwords.  When ALLOW-ROOT? is
 true, allow root to run the command without authentication.  When MOTD is
-true, it should be a file-like object used as the message-of-the-day."
+true, it should be a file-like object used as the message-of-the-day.
+When LOGIN-UID? is true, require the 'pam_loginuid' module; that module sets
+/proc/self/loginuid, which the libc 'getlogin' function relies on."
       ;; See <http://www.linux-pam.org/Linux-PAM-html/sag-configuration-example.html>.
-      (let ((name* name))
-        (pam-service
-         (name name*)
-         (account (list unix))
-         (auth (append (if allow-root?
-                           (list (pam-entry
-                                  (control "sufficient")
-                                  (module "pam_rootok.so")))
-                           '())
-                       (list (if allow-empty-passwords?
-                                 (pam-entry
-                                  (control "required")
-                                  (module "pam_unix.so")
-                                  (arguments '("nullok")))
-                                 unix))))
-         (password (list (pam-entry
-                          (control "required")
-                          (module "pam_unix.so")
-                          ;; Store SHA-512 encrypted passwords in /etc/shadow.
-                          (arguments '("sha512" "shadow")))))
-         (session (if motd
-                      (list env unix
-                            (pam-entry
-                             (control "optional")
-                             (module "pam_motd.so")
-                             (arguments
-                              (list #~(string-append "motd=" #$motd)))))
-                      (list env unix))))))))
+      (pam-service
+       (name name)
+       (account (list unix))
+       (auth (append (if allow-root?
+                         (list (pam-entry
+                                (control "sufficient")
+                                (module "pam_rootok.so")))
+                         '())
+                     (list (if allow-empty-passwords?
+                               (pam-entry
+                                (control "required")
+                                (module "pam_unix.so")
+                                (arguments '("nullok")))
+                               unix))))
+       (password (list (pam-entry
+                        (control "required")
+                        (module "pam_unix.so")
+                        ;; Store SHA-512 encrypted passwords in /etc/shadow.
+                        (arguments '("sha512" "shadow")))))
+       (session `(,@(if motd
+                        (list (pam-entry
+                               (control "optional")
+                               (module "pam_motd.so")
+                               (arguments
+                                (list #~(string-append "motd=" #$motd)))))
+                        '())
+                  ,@(if login-uid?
+                        (list (pam-entry       ;to fill in /proc/self/loginuid
+                               (control "required")
+                               (module "pam_loginuid.so")))
+                        '())
+                  ,env ,unix))))))
 
 (define (rootok-pam-service command)
   "Return a PAM service for COMMAND such that 'root' does not need to
diff --git a/gnu/system/uuid.scm b/gnu/system/uuid.scm
index f13960c3e9..e7a3a0439d 100644
--- a/gnu/system/uuid.scm
+++ b/gnu/system/uuid.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Danny Milosavljevic <dannym@scratchpost.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -175,7 +175,7 @@ ISO9660 UUID representation."
   "Convert FAT32/FAT16 UUID, a 4-byte bytevector, to its string representation."
   (let ((high  (bytevector-uint-ref uuid 0 %fat-endianness 2))
         (low (bytevector-uint-ref uuid 2 %fat-endianness 2)))
-    (format #f "~:@(~x-~x~)" low high)))
+    (format #f "~:@(~4,'0x-~4,'0x~)" low high)))
 
 (define %fat-uuid-rx
   (make-regexp "^([[:xdigit:]]{4})-([[:xdigit:]]{4})$"))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index 92b03b01ad..0d4ed63eec 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -64,6 +64,7 @@
   #:use-module (gnu system file-systems)
   #:use-module (gnu system)
   #:use-module (gnu services)
+  #:use-module (gnu services base)
   #:use-module (gnu system uuid)
 
   #:use-module (srfi srfi-1)
@@ -249,6 +250,12 @@ made available under the /xchg CIFS share."
                       #:guile-for-build guile-for-build
                       #:references-graphs references-graphs)))
 
+(define (has-guix-service-type? os)
+  "Return true if OS contains a service of the type GUIX-SERVICE-TYPE."
+  (not (not (find (lambda (service)
+                     (eq? (service-kind service) guix-service-type))
+                   (operating-system-services os)))))
+
 (define* (iso9660-image #:key
                         (name "iso9660-image")
                         file-system-label
@@ -258,8 +265,9 @@ made available under the /xchg CIFS share."
                         os
                         bootcfg-drv
                         bootloader
-                        register-closures?
-                        (inputs '()))
+                        (register-closures? (has-guix-service-type? os))
+                        (inputs '())
+                        (grub-mkrescue-environment '()))
   "Return a bootable, stand-alone iso9660 image.
 
 INPUTS is a list of inputs (as for packages)."
@@ -283,6 +291,11 @@ INPUTS is a list of inputs (as for packages)."
 
            (sql-schema #$schema)
 
+           ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+           (setenv "GUIX_LOCPATH"
+                   #+(file-append glibc-utf8-locales "/lib/locale"))
+           (setlocale LC_ALL "en_US.utf8")
+
            (let ((inputs
                   '#$(append (list qemu parted e2fsprogs dosfstools xorriso)
                              (map canonical-package
@@ -301,7 +314,9 @@ INPUTS is a list of inputs (as for packages)."
                           inputs)))
 
              (set-path-environment-variable "PATH" '("bin" "sbin") inputs)
-             (make-iso9660-image #$(bootloader-package bootloader)
+             (make-iso9660-image #$xorriso
+                                 '#$grub-mkrescue-environment
+                                 #$(bootloader-package bootloader)
                                  #$bootcfg-drv
                                  #$os
                                  "/xchg/guixsd.iso"
@@ -338,7 +353,7 @@ INPUTS is a list of inputs (as for packages)."
                      os
                      bootcfg-drv
                      bootloader
-                     (register-closures? #t)
+                     (register-closures? (has-guix-service-type? os))
                      (inputs '())
                      copy-inputs?)
   "Return a bootable, stand-alone QEMU image of type DISK-IMAGE-FORMAT (e.g.,
@@ -354,7 +369,9 @@ file (GRUB-CONFIGURATION must be the name of a file in the VM.)
 INPUTS is a list of inputs (as for packages).  When COPY-INPUTS? is true, copy
 all of INPUTS into the image being built.  When REGISTER-CLOSURES? is true,
 register INPUTS in the store database of the image so that Guix can be used in
-the image."
+the image.  By default, REGISTER-CLOSURES? is set to true only if a service of
+type GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
@@ -379,6 +396,11 @@ the image."
 
            (sql-schema #$schema)
 
+           ;; Allow non-ASCII file names--e.g., 'nss-certs'--to be decoded.
+           (setenv "GUIX_LOCPATH"
+                   #+(file-append glibc-utf8-locales "/lib/locale"))
+           (setlocale LC_ALL "en_US.utf8")
+
            (let ((inputs
                   '#$(append (list qemu parted e2fsprogs dosfstools)
                              (map canonical-package
@@ -463,21 +485,32 @@ the image."
 
 (define* (system-docker-image os
                               #:key
-                              (name "guixsd-docker-image")
-                              register-closures?)
+                              (name "guix-docker-image")
+                              (register-closures? (has-guix-service-type? os)))
   "Build a docker image.  OS is the desired <operating-system>.  NAME is the
-base name to use for the output file.  When REGISTER-CLOSURES? is not #f,
-register the closure of OS with Guix in the resulting Docker image.  This only
-makes sense when you want to build a Guix System Docker image that has Guix
-installed inside of it.  If you don't need Guix (e.g., your Docker
-image just contains a web server that is started by the Shepherd), then you
-should set REGISTER-CLOSURES? to #f."
+base name to use for the output file.  When REGISTER-CLOSURES? is true,
+register the closure of OS with Guix in the resulting Docker image.  By
+default, REGISTER-CLOSURES? is set to true only if a service of type
+GUIX-SERVICE-TYPE is present in the services definition of the operating
+system."
   (define schema
     (and register-closures?
          (local-file (search-path %load-path
                                   "guix/store/schema.sql"))))
 
-  (let ((os    (containerized-operating-system os '()))
+  (define boot-program
+    ;; Program that runs the boot script of OS, which in turn starts shepherd.
+    (program-file "boot-program"
+                  #~(let ((system (cadr (command-line))))
+                      (setenv "GUIX_NEW_SYSTEM" system)
+                      (execl #$(file-append guile-2.2 "/bin/guile")
+                             "guile" "--no-auto-compile"
+                             (string-append system "/boot")))))
+
+
+  (let ((os    (operating-system-with-gc-roots
+                (containerized-operating-system os '())
+                (list boot-program)))
         (name  (string-append name ".tar.gz"))
         (graph "system-graph"))
     (define build
@@ -528,9 +561,11 @@ should set REGISTER-CLOSURES? to #f."
                                  (string-append "/xchg/" #$graph)
                                read-reference-graph)))
                  #$os
+                 #:entry-point '(#$boot-program #$os)
                  #:compressor '(#+(file-append gzip "/bin/gzip") "-9n")
                  #:creation-time (make-time time-utc 0 1)
                  #:transformations `((,root-directory -> ""))))))))
+
     (expression->derivation-in-linux-vm
      name build
      #:make-disk-image? #f
@@ -668,12 +703,13 @@ to USB sticks meant to be read-only."
                        #:file-system-label root-label
                        #:file-system-uuid uuid
                        #:os os
-                       #:register-closures? #t
                        #:bootcfg-drv bootcfg
                        #:bootloader (bootloader-configuration-bootloader
                                      (operating-system-bootloader os))
                        #:inputs `(("system" ,os)
-                                  ("bootcfg" ,bootcfg)))
+                                  ("bootcfg" ,bootcfg))
+                       #:grub-mkrescue-environment
+                       '(("MKRESCUE_SED_MODE" . "mbr_hfs")))
         (qemu-image #:name name
                     #:os os
                     #:bootcfg-drv bootcfg
@@ -685,7 +721,6 @@ to USB sticks meant to be read-only."
                     #:file-system-label root-label
                     #:file-system-uuid uuid
                     #:copy-inputs? #t
-                    #:register-closures? #t
                     #:inputs `(("system" ,os)
                                ("bootcfg" ,bootcfg))))))