diff options
Diffstat (limited to 'gnu/build')
| -rw-r--r-- | gnu/build/accounts.scm | 24 | ||||
| -rw-r--r-- | gnu/build/activation.scm | 37 | ||||
| -rw-r--r-- | gnu/build/linux-boot.scm | 4 | ||||
| -rw-r--r-- | gnu/build/locale.scm | 95 |
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)))))) |