aboutsummaryrefslogtreecommitdiff
path: root/gnu/build
diff options
context:
space:
mode:
Diffstat (limited to 'gnu/build')
-rw-r--r--gnu/build/accounts.scm24
-rw-r--r--gnu/build/activation.scm37
-rw-r--r--gnu/build/locale.scm95
3 files changed, 139 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/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))))))