Merge branch 'master' into core-updates

4 files changed, 143 insertions, 17 deletions

diff --git a/gnu/build/accounts.scm b/gnu/build/accounts.scm
index c43ce85b60..b90149565f 100644
--- a/gnu/build/accounts.scm
+++ b/gnu/build/accounts.scm
@@ -19,6 +19,7 @@
 (define-module (gnu build accounts)
   #:use-module (guix records)
   #:use-module (guix combinators)
+  #:use-module ((guix build syscalls) #:select (fdatasync))
   #:use-module (gnu system accounts)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-11)
@@ -51,6 +52,7 @@
             group-entry-gid
             group-entry-members
 
+            %password-lock-file
             write-group
             write-passwd
             write-shadow
@@ -224,6 +226,19 @@ each field."
                    (serialization list->comma-separated comma-separated->list)
                    (default '())))
 
+(define %password-lock-file
+  ;; The password database lock file used by libc's 'lckpwdf'.  Users should
+  ;; grab this lock with 'with-file-lock' when they access the databases.
+  "/etc/.pwd.lock")
+
+(define-syntax-rule (catch-ENOSYS exp)
+  (catch 'system-error
+    (lambda () exp)
+    (lambda args
+      (if (= ENOSYS (system-error-errno args))
+          #f
+          (apply throw args)))))
+
 (define (database-writer file mode entry->string)
   (lambda* (entries #:optional (file-or-port file))
     "Write ENTRIES to FILE-OR-PORT.  When FILE-OR-PORT is a file name, write
@@ -243,9 +258,16 @@ to it atomically and set the appropriate permissions."
             (lambda ()
               (chmod port mode)
               (write-entries port)
+
+              ;; XXX: When booting with the statically-linked Guile,
+              ;; 'fdatasync' is unavailable.
+              (catch-ENOSYS (fdatasync port))
+
+              (close-port port)
               (rename-file template file-or-port))
             (lambda ()
-              (close-port port)
+              (unless (port-closed? port)
+                (close-port port))
               (when (file-exists? template)
                 (delete-file template))))))))
 
diff --git a/gnu/build/activation.scm b/gnu/build/activation.scm
index cfdf17df0f..c6c7e7fd3b 100644
--- a/gnu/build/activation.scm
+++ b/gnu/build/activation.scm
@@ -22,6 +22,7 @@
   #:use-module (gnu build accounts)
   #:use-module (gnu build linux-boot)
   #:use-module (guix build utils)
+  #:use-module ((guix build syscalls) #:select (with-file-lock))
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
@@ -129,22 +130,26 @@ group records) are all available."
   ;; Allow home directories to be created under /var/lib.
   (mkdir-p "/var/lib")
 
-  (let-values (((groups passwd shadow)
-                (user+group-databases users groups)))
-    (write-group groups)
-    (write-passwd passwd)
-    (write-shadow shadow)
-
-    ;; Home directories of non-system accounts are created by
-    ;; 'activate-user-home'.
-    (for-each make-home-directory system-accounts)
-
-    ;; Turn shared home directories, such as /var/empty, into root-owned,
-    ;; read-only places.
-    (for-each (lambda (directory)
-                (chown directory 0 0)
-                (chmod directory #o555))
-              (duplicates (map user-account-home-directory system-accounts)))))
+  ;; Take same lock as libc's 'lckpwdf' (but without a timeout) while we read
+  ;; and write the databases.  This ensures there's no race condition with
+  ;; other tools that might be accessing it at the same time.
+  (with-file-lock %password-lock-file
+    (let-values (((groups passwd shadow)
+                  (user+group-databases users groups)))
+      (write-group groups)
+      (write-passwd passwd)
+      (write-shadow shadow)))
+
+  ;; Home directories of non-system accounts are created by
+  ;; 'activate-user-home'.
+  (for-each make-home-directory system-accounts)
+
+  ;; Turn shared home directories, such as /var/empty, into root-owned,
+  ;; read-only places.
+  (for-each (lambda (directory)
+              (chown directory 0 0)
+              (chmod directory #o555))
+            (duplicates (map user-account-home-directory system-accounts))))
 
 (define (activate-user-home users)
   "Create and populate the home directory of USERS, a list of tuples, unless
diff --git a/gnu/build/linux-boot.scm b/gnu/build/linux-boot.scm
index a35d18ad7c..03f2ea245c 100644
--- a/gnu/build/linux-boot.scm
+++ b/gnu/build/linux-boot.scm
@@ -517,6 +517,8 @@ upon error."
          (unless (pre-mount)
            (error "pre-mount actions failed")))
 
+       (setenv "EXT2FS_NO_MTAB_OK" "1")
+
        (if root
            ;; The "--root=SPEC" kernel command-line option always provides a
            ;; string, but the string can represent a device, a UUID, or a
@@ -533,6 +535,8 @@ upon error."
        (for-each mount-file-system
                  (remove root-mount-point? mounts))
 
+       (setenv "EXT2FS_NO_MTAB_OK" #f)
+
        (if to-load
            (begin
              (switch-root "/root")
diff --git a/gnu/build/locale.scm b/gnu/build/locale.scm
new file mode 100644
index 0000000000..412759a320
--- /dev/null
+++ b/gnu/build/locale.scm
@@ -0,0 +1,95 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2019 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (gnu build locale)
+  #:use-module (guix build utils)
+  #:use-module (srfi srfi-1)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 regex)
+  #:export (build-locale
+            normalize-codeset
+            locale->name+codeset
+            read-supported-locales))
+
+(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))))))))
+
+(define (normalize-codeset codeset)
+  "Compute the \"normalized\" variant of CODESET."
+  ;; info "(libc) Using gettextized software", for the algorithm used to
+  ;; compute the normalized codeset.
+  (letrec-syntax ((-> (syntax-rules ()
+                        ((_ proc value)
+                         (proc value))
+                        ((_ proc rest ...)
+                         (proc (-> rest ...))))))
+    (-> (lambda (str)
+          (if (string-every char-set:digit str)
+              (string-append "iso" str)
+              str))
+        string-downcase
+        (lambda (str)
+          (string-filter char-set:letter+digit str))
+        codeset)))
+
+(define* (build-locale locale
+                       #:key
+                       (localedef "localedef")
+                       (directory ".")
+                       (codeset "UTF-8")
+                       (name (string-append locale "." codeset)))
+  "Compute locale data for LOCALE and CODESET--e.g., \"en_US\" and
+\"UTF-8\"--with LOCALEDEF, and store it in DIRECTORY under NAME."
+  (format #t "building locale '~a'...~%" name)
+  (invoke localedef "--no-archive" "--prefix" directory
+          "-i" locale "-f" codeset
+          (string-append directory "/" name)))
+
+(define (locale->name+codeset locale)
+  "Split a locale name such as \"aa_ER@saaho.UTF-8\" into two values: the
+language/territory/modifier part, and the codeset."
+  (match (string-rindex locale #\.)
+    (#f  (values locale #f))
+    (dot (values (string-take locale dot)
+                 (string-drop locale (+ dot 1))))))