aboutsummaryrefslogtreecommitdiff
path: root/configure.ac
blob: 689b28d984f01129c8bdaea722a6fb062fc35025 (about) (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
#                                               -*- Autoconf -*-
# Process this file with autoconf to produce a configure script.

AC_PREREQ(2.68)
AC_INIT([GNU Guix],
  [m4_esyscmd([build-aux/git-version-gen .tarball-version])],
  [bug-guix@gnu.org], [guix],
  [https://www.gnu.org/software/guix/])
AC_CONFIG_AUX_DIR([build-aux])

AM_INIT_AUTOMAKE([1.14 gnu silent-rules subdir-objects \
 color-tests parallel-tests -Woverride -Wno-portability])

# Enable silent rules by default.
AM_SILENT_RULES([yes])

AC_CONFIG_SRCDIR([guix.scm])
AC_CONFIG_MACRO_DIR([m4])

dnl For the C++ code.  This must be used early.
AC_USE_SYSTEM_EXTENSIONS

AM_GNU_GETTEXT([external])
AM_GNU_GETTEXT_VERSION([0.18.1])

GUIX_SYSTEM_TYPE
GUIX_ASSERT_SUPPORTED_SYSTEM

AC_ARG_WITH(store-dir,
  AC_HELP_STRING([--with-store-dir=PATH],
    [file name of the store (defaults to /gnu/store)]),
  [storedir="$withval"],
  [storedir="/gnu/store"])
AC_SUBST(storedir)

AC_ARG_WITH([bash-completion-dir],
  AC_HELP_STRING([--with-bash-completion-dir=DIR],
    [name of the Bash completion directory]),
  [bashcompletiondir="$withval"],
  [bashcompletiondir='${sysconfdir}/bash_completion.d'])
AC_SUBST([bashcompletiondir])

AC_ARG_WITH([zsh-completion-dir],
  AC_HELP_STRING([--with-zsh-completion-dir=DIR],
    [name of the Zsh completion directory]),
  [zshcompletiondir="$withval"],
  [zshcompletiondir='${datadir}/zsh/site-functions'])
AC_SUBST([zshcompletiondir])

AC_ARG_WITH([fish-completion-dir],
  AC_HELP_STRING([--with-fish-completion-dir=DIR],
    [name of the Fish completion directory]),
  [fishcompletiondir="$withval"],
  [fishcompletiondir='${datadir}/fish/vendor_completions.d'])
AC_SUBST([fishcompletiondir])

AC_ARG_WITH([selinux-policy-dir],
  AC_HELP_STRING([--with-selinux-policy-dir=DIR],
    [name of the SELinux policy directory]),
  [selinux_policydir="$withval"],
  [selinux_policydir='${datadir}/selinux/'])
AC_SUBST([selinux_policydir])

dnl Better be verbose.
AC_MSG_CHECKING([for the store directory])
AC_MSG_RESULT([$storedir])

AC_ARG_ENABLE([daemon],
  [AS_HELP_STRING([--disable-daemon], [do not build the Nix daemon (C++)])],
  [guix_build_daemon="$enableval"],
  [guix_build_daemon="yes"])

# Prepare a version of $localstatedir & co. that does not contain references
# to shell variables.
guix_prefix="`eval echo $prefix | sed -e"s|NONE|/usr/local|g"`"
guix_localstatedir="`eval echo $localstatedir | sed -e "s|NONE|$guix_prefix|g"`"
guix_sysconfdir="`eval echo $sysconfdir | sed -e "s|NONE|$guix_prefix|g"`"
guix_sbindir="`eval echo $sbindir | sed -e "s|NONE|$guix_prefix|g"`"
AC_SUBST([guix_localstatedir])
AC_SUBST([guix_sysconfdir])
AC_SUBST([guix_sbindir])

GUIX_CHECK_FILE_NAME_LIMITS([can_run_tests])
AM_CONDITIONAL([CAN_RUN_TESTS], [test "x$can_run_tests" = "xyes"])

dnl We require pkg.m4 (from pkg-config) and guile.m4 (from Guile.)
dnl Make sure they are available.
m4_pattern_forbid([PKG_CHECK_MODULES])
m4_pattern_forbid([GUILE_MODULE_AVAILABLE])
m4_pattern_forbid([^GUILE_P])
m4_pattern_allow([^GUILE_PKG_ERRORS])
m4_pattern_forbid([^GUIX_])

dnl Search for 'guile' and 'guild'.  This macro defines
dnl 'GUILE_EFFECTIVE_VERSION'.
GUILE_PKG([2.2])
GUILE_PROGS
if test "x$GUILD" = "x"; then
   AC_MSG_ERROR(['guild' binary not found; please check your guile-2.x installation.])
fi

dnl Installation directories for .scm and .go files.
guilemoduledir="${datarootdir}/guile/site/$GUILE_EFFECTIVE_VERSION"
guileobjectdir="${libdir}/guile/$GUILE_EFFECTIVE_VERSION/site-ccache"
AC_SUBST([guilemoduledir])
AC_SUBST([guileobjectdir])

dnl The GnuTLS bindings are necessary for substitutes over HTTPS and for 'guix
dnl pull', among other things.
GUILE_MODULE_AVAILABLE([have_gnutls], [(gnutls)])
if test "x$have_gnutls" != "xyes"; then
  AC_MSG_ERROR([The Guile bindings of GnuTLS are missing; please install them.])
fi

dnl Check for Guile-Git.
GUILE_MODULE_AVAILABLE([have_guile_git], [(git)])
if test "x$have_guile_git" != "xyes"; then
  AC_MSG_ERROR([Guile-Git is missing; please install it.])
fi

dnl Check for Guile-JSON.
GUIX_CHECK_GUILE_JSON
if test "x$guix_cv_have_recent_guile_json" != "xyes"; then
  AC_MSG_ERROR([Guile-JSON is missing; please install it.])
fi

dnl Guile-Sqlite3 is used by the (guix store ...) modules.
GUIX_CHECK_GUILE_SQLITE3
if test "x$guix_cv_have_recent_guile_sqlite3" != "xyes"; then
  AC_MSG_ERROR([A recent Guile-SQLite3 could not be found; please install it.])
fi

GUILE_MODULE_AVAILABLE([have_guile_gcrypt], [(gcrypt hash)])
if test "x$have_guile_gcrypt" != "xyes"; then
  AC_MSG_ERROR([Guile-Gcrypt could not be found; please install it.])
fi

dnl Guile-newt is used by the graphical installer.
GUILE_MODULE_AVAILABLE([have_guile_newt], [(newt)])

AC_ARG_ENABLE([installer],
    AS_HELP_STRING([--enable-installer], [Build the graphical installer sources.]))

AS_IF([test "x$enable_installer" = "xyes"], [
if test "x$have_guile_newt" != "xyes"; then
  AC_MSG_ERROR([Guile-newt could not be found; please install it.])
fi
])

AM_CONDITIONAL([ENABLE_INSTALLER],
  [test "x$enable_installer" = "xyes"])

dnl Make sure we have a full-fledged Guile.
GUIX_ASSERT_GUILE_FEATURES([regex posix socket net-db threads])

dnl Make sure we don't suffer from the bug in 'equal?' wrt. syntax objects
dnl found in 2.2.1.  See <https://bugs.gnu.org/29903>.
GUIX_ASSERT_SYNTAX_OBJECT_EQUAL

AC_PROG_SED

dnl Decompressors, for use by the substituter and other modules.
AC_PATH_PROG([GZIP], [gzip])
AC_PATH_PROG([BZIP2], [bzip2])
AC_PATH_PROG([XZ], [xz])
AC_SUBST([GZIP])
AC_SUBST([BZIP2])
AC_SUBST([XZ])

AC_ARG_WITH([nix-prefix],
  [AS_HELP_STRING([--with-nix-prefix=DIR],
    [search for Nix in DIR (for testing purposes and '--disable-daemon' builds)])],
  [case "$withval" in
    yes|no) ;;
    *)
      NIX_PREFIX="$withval"
      PATH="$NIX_PREFIX/bin:$PATH"; export PATH
      AC_SUBST([NIX_PREFIX])
      ;;
   esac],
  [])

AC_PATH_PROG([NIX_HASH], [nix-hash])
if test "x$guix_build_daemon$NIX_HASH" = "xno"; then
   AC_MSG_ERROR([Nix programs not found; please install Nix or use `--with-nix-prefix'.])
fi

AC_ARG_WITH([nixpkgs],
  [AS_HELP_STRING([--with-nixpkgs=DIR],
    [search for Nixpkgs in DIR (for testing purposes only)])],
  [case "$withval" in
    yes|no) AC_MSG_ERROR([Please use `--with-nixpkgs=DIR'.]);;
    *)      NIXPKGS="$withval";;
   esac],
  [])

AC_MSG_CHECKING([for Nixpkgs source tree])
if test -f "$NIXPKGS/default.nix"; then
   AC_MSG_RESULT([$NIXPKGS])
   AC_SUBST([NIXPKGS])
else
   AC_MSG_RESULT([not found])
fi

LIBGCRYPT_LIBDIR="no"
LIBGCRYPT_PREFIX="no"

AC_ARG_WITH([libgcrypt-prefix],
  [AS_HELP_STRING([--with-libgcrypt-prefix=DIR], [search for GNU libgcrypt in DIR])],
  [case "$withval" in
    yes|no)
      ;;
    *)
      LIBGCRYPT_PREFIX="$withval"
      LIBGCRYPT_LIBDIR="$withval/lib"
      ;;
   esac])

AC_ARG_WITH([libgcrypt-libdir],
  [AS_HELP_STRING([--with-libgcrypt-libdir=DIR],
     [search for GNU libgcrypt's shared library in DIR])],
  [case "$withval" in
    yes|no)
      LIBGCRYPT_LIBDIR="no"
      ;;
    *)
      LIBGCRYPT_LIBDIR="$withval"
      ;;
   esac])

dnl If none of the --with-libgcrypt-* options was used, try to determine the
dnl the library directory.
case "x$LIBGCRYPT_PREFIX$LIBGCRYPT_LIBDIR" in
  xnono)
    GUIX_LIBGCRYPT_LIBDIR([LIBGCRYPT_LIBDIR])
    ;;
esac

AC_SUBST([LIBGCRYPT_PREFIX])
AC_SUBST([LIBGCRYPT_LIBDIR])

dnl Library name of zlib suitable for 'dynamic-link'.
GUIX_LIBZ_LIBDIR([libz_libdir])
if test "x$libz_libdir" = "x"; then
  LIBZ="libz"
else
  LIBZ="$libz_libdir/libz"
fi
AC_MSG_CHECKING([for zlib's shared library name])
AC_MSG_RESULT([$LIBZ])
AC_SUBST([LIBZ])

dnl Library name of lzlib suitable for 'dynamic-link'.
GUIX_LIBLZ_FILE_NAME([LIBLZ])
if test "x$LIBLZ" = "x"; then
  LIBLZ="liblz"
else
  # Strip the .so or .so.1 extension since that's what 'dynamic-link' expects.
  LIBLZ="`echo $LIBLZ | sed -es'/\.so\(\.[[0-9.]]\+\)\?//g'`"
fi
AC_SUBST([LIBLZ])

dnl Check for Guile-SSH, for the (guix ssh) module.
GUIX_CHECK_GUILE_SSH
AM_CONDITIONAL([HAVE_GUILE_SSH],
  [test "x$guix_cv_have_recent_guile_ssh" = "xyes"])

AC_CACHE_SAVE

m4_include([config-daemon.ac])

dnl `dot' (from the Graphviz package) is only needed for maintainers.
dnl See `Building from Git' in the manual for more info.
AM_MISSING_PROG([DOT], [dot])

dnl Manual pages.
AM_MISSING_PROG([HELP2MAN], [help2man])

dnl Documentation translation.
AM_MISSING_PROG([PO4A_TRANSLATE], [po4a-translate])
AM_MISSING_PROG([PO4A_UPDATEPO], [po4a-updatepo])

dnl Emacs (optional), for 'etc/indent-package.el'.
AC_PATH_PROG([EMACS], [emacs], [/usr/bin/emacs])
AC_SUBST([EMACS])

case "$storedir" in
  /gnu/store)
    ;;
  *)
    AC_MSG_WARN([Using a store directory other than '/gnu/store' will prevent you])
    AC_MSG_WARN([from downloading substitutes from gnu.org.])
    ;;
esac

AC_CONFIG_FILES([Makefile
                 po/guix/Makefile.in
                 po/packages/Makefile.in
                 etc/guix-daemon.cil
                 guix/config.scm])

AC_CONFIG_FILES([test-env:build-aux/test-env.in], [chmod +x test-env])
AC_CONFIG_FILES([pre-inst-env:build-aux/pre-inst-env.in],
  [chmod +x pre-inst-env])
AC_CONFIG_FILES([etc/indent-code.el], [chmod +x etc/indent-code.el])

AC_OUTPUT
e 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 accounts) #:use-module (guix records) #:use-module (guix combinators) #:use-module (gnu system accounts) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 match) #:use-module (ice-9 vlist) #:use-module (ice-9 rdelim) #:export (password-entry password-entry? password-entry-name password-entry-uid password-entry-gid password-entry-real-name password-entry-directory password-entry-shell shadow-entry shadow-entry? shadow-entry-name shadow-entry-minimum-change-period shadow-entry-maximum-change-period shadow-entry-change-warning-time shadow-entry-maximum-inactivity shadow-entry-expiration group-entry group-entry? group-entry-name group-entry-gid group-entry-members write-group write-passwd write-shadow read-group read-passwd read-shadow %id-min %id-max %system-id-min %system-id-max user+group-databases)) ;;; Commentary: ;;; ;;; This modules provides functionality equivalent to the C library's ;;; <shadow.h>, <pwd.h>, and <grp.h> routines, as well as a subset of the ;;; functionality of the Shadow command-line tools. It can parse and write ;;; /etc/passwd, /etc/shadow, and /etc/group. It can also take care of UID ;;; and GID allocation in a way similar to what 'useradd' does. ;;; ;;; The benefit is twofold: less code is involved, and the ID allocation ;;; strategy and state preservation is made explicit. ;;; ;;; Code: ;;; ;;; Machinery to define user and group databases. ;;; (define-syntax serialize-field (syntax-rules (serialization) ((_ entry (field get (serialization ->string string->) _ ...)) (->string (get entry))) ((_ entry (field get _ ...)) (get entry)))) (define-syntax deserialize-field (syntax-rules (serialization) ((_ str (field get (serialization ->string string->) _ ...)) (string-> str)) ((_ str (field get _ ...)) str))) (define-syntax let/fields (syntax-rules () ((_ (((name get attributes ...) rest ...) lst) body ...) (let ((l lst)) (let ((name (deserialize-field (car l) (name get attributes ...)))) (let/fields ((rest ...) (cdr l)) body ...)))) ((_ (() lst) body ...) (begin body ...)))) (define-syntax define-database-entry (syntax-rules (serialization) "Define a record data type, as per 'define-record-type*', with additional information on how to serialize and deserialize the whole database as well as each field." ((_ <record> record make-record record? (serialization separator entry->string string->entry) fields ...) (let-syntax ((field-name (syntax-rules () ((_ (name _ (... ...))) name)))) (define-record-type* <record> record make-record record? fields ...) (define (entry->string entry) (string-join (list (serialize-field entry fields) ...) (string separator))) (define (string->entry str) (let/fields ((fields ...) (string-split str #\:)) (make-record (field-name fields) ...))))))) (define number->string* (match-lambda ((? number? number) (number->string number)) (_ ""))) (define (false-if-string=? false-string) (lambda (str) (if (string=? str false-string) #f str))) (define (string-if-false str) (lambda (obj) (if (not obj) str obj))) (define (comma-separated->list str) (string-tokenize str (char-set-complement (char-set #\,)))) (define (list->comma-separated lst) (string-join lst ",")) ;;; ;;; Database definitions. ;;; (define-database-entry <password-entry> ;<pwd.h> password-entry make-password-entry password-entry? (serialization #\: password-entry->string string->password-entry) (name password-entry-name) (password password-entry-password (serialization (const "x") (const #f)) (default "x")) (uid password-entry-uid (serialization number->string string->number)) (gid password-entry-gid (serialization number->string string->number)) (real-name password-entry-real-name (default "")) (directory password-entry-directory) (shell password-entry-shell (default "/bin/sh"))) (define-database-entry <shadow-entry> ;<shadow.h> shadow-entry make-shadow-entry shadow-entry? (serialization #\: shadow-entry->string string->shadow-entry) (name shadow-entry-name) ;string (password shadow-entry-password ;string | #f (serialization (string-if-false "!") (false-if-string=? "!")) (default #f)) (last-change shadow-entry-last-change ;days since 1970-01-01 (serialization number->string* string->number) (default 0)) (minimum-change-period shadow-entry-minimum-change-period (serialization number->string* string->number) (default #f)) ;days | #f (maximum-change-period shadow-entry-maximum-change-period (serialization number->string* string->number) (default #f)) ;days | #f (change-warning-time shadow-entry-change-warning-time (serialization number->string* string->number) (default #f)) ;days | #f (maximum-inactivity shadow-entry-maximum-inactivity (serialization number->string* string->number) (default #f)) ;days | #f (expiration shadow-entry-expiration (serialization number->string* string->number) (default #f)) ;days since 1970-01-01 | #f (flags shadow-entry-flags ;"reserved" (serialization number->string* string->number) (default #f))) (define-database-entry <group-entry> ;<grp.h> group-entry make-group-entry group-entry? (serialization #\: group-entry->string string->group-entry) (name group-entry-name) (password group-entry-password (serialization (string-if-false "x") (false-if-string=? "x")) (default #f)) (gid group-entry-gid (serialization number->string string->number)) (members group-entry-members (serialization list->comma-separated comma-separated->list) (default '()))) (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 to it atomically and set the appropriate permissions." (define (write-entries port) (for-each (lambda (entry) (display (entry->string entry) port) (newline port)) entries)) (if (port? file-or-port) (write-entries file-or-port) (let* ((template (string-append file-or-port ".XXXXXX")) (port (mkstemp! template))) (dynamic-wind (const #t) (lambda () (chmod port mode) (write-entries port) (rename-file template file-or-port)) (lambda () (close-port port) (when (file-exists? template) (delete-file template)))))))) (define write-passwd (database-writer "/etc/passwd" #o644 password-entry->string)) (define write-shadow (database-writer "/etc/shadow" #o600 shadow-entry->string)) (define write-group (database-writer "/etc/group" #o644 group-entry->string)) (define (database-reader file string->entry) (lambda* (#:optional (file-or-port file)) (define (read-entries port) (let loop ((entries '())) (match (read-line port) ((? eof-object?) (reverse entries)) (line (loop (cons (string->entry line) entries)))))) (if (port? file-or-port) (read-entries file-or-port) (call-with-input-file file-or-port read-entries)))) (define read-passwd (database-reader "/etc/passwd" string->password-entry)) (define read-shadow (database-reader "/etc/shadow" string->shadow-entry)) (define read-group (database-reader "/etc/group" string->group-entry)) ;;; ;;; Building databases. ;;; (define-record-type* <allocation> allocation make-allocation allocation? (ids allocation-ids (default vlist-null)) (next-id allocation-next-id (default %id-min)) (next-system-id allocation-next-system-id (default %system-id-max))) ;; Trick to avoid name clashes... (define-syntax %allocation (identifier-syntax allocation)) ;; Minimum and maximum UIDs and GIDs (from find_new_uid.c and find_new_gid.c ;; in Shadow.) (define %id-min 1000) (define %id-max 60000) (define %system-id-min 100) (define %system-id-max 999) (define (system-id? id) (and (> id %system-id-min) (<= id %system-id-max))) (define (user-id? id) (and (>= id %id-min) (< id %id-max))) (define* (allocate-id assignment #:key system?) "Return two values: a newly allocated ID, and an updated <allocation> record based on ASSIGNMENT. If SYSTEM? is true, return a system ID." (define next ;; Return the next available ID, looping if necessary. (if system? (lambda (id) (let ((next-id (- id 1))) (if (< next-id %system-id-min) %system-id-max next-id))) (lambda (id) (let ((next-id (+ id 1))) (if (>= next-id %id-max) %id-min next-id))))) (let loop ((id (if system? (allocation-next-system-id assignment) (allocation-next-id assignment)))) (if (vhash-assv id (allocation-ids assignment)) (loop (next id)) (let ((taken (vhash-consv id #t (allocation-ids assignment)))) (values (if system? (allocation (inherit assignment) (next-system-id (next id)) (ids taken)) (allocation (inherit assignment) (next-id (next id)) (ids taken))) id))))) (define* (reserve-ids allocation ids #:key (skip? #t)) "Mark the numbers listed in IDS as reserved in ALLOCATION. When SKIP? is true, start allocation after the highest (or lowest, depending on whether it's a system ID allocation) number among IDS." (%allocation (inherit allocation) (next-id (if skip? (+ (reduce max (- (allocation-next-id allocation) 1) (filter user-id? ids)) 1) (allocation-next-id allocation))) (next-system-id (if skip? (- (reduce min (+ 1 (allocation-next-system-id allocation)) (filter system-id? ids)) 1) (allocation-next-system-id allocation))) (ids (fold (cut vhash-consv <> #t <>) (allocation-ids allocation) ids)))) (define (allocated? allocation id) "Return true if ID is already allocated as part of ALLOCATION." (->bool (vhash-assv id (allocation-ids allocation)))) (define (lookup-procedure lst key) "Return a lookup procedure for the elements of LST, calling KEY to obtain the key of each element." (let ((table (fold (lambda (obj table) (vhash-cons (key obj) obj table)) vlist-null lst))) (lambda (key) (match (vhash-assoc key table) (#f #f) ((_ . value) value))))) (define* (allocate-groups groups members #:optional (current-groups '())) "Return a list of group entries for GROUPS, a list of <user-group>. Members for each group are taken from MEMBERS, a vhash that maps group names to member names. GIDs and passwords found in CURRENT-GROUPS, a list of group entries, are reused." (define gids ;; Mark all the currently-used GIDs and the explicitly requested GIDs as ;; reserved. (reserve-ids (reserve-ids (allocation) (map group-entry-gid current-groups)) (filter-map user-group-id groups) #:skip? #f)) (define previous-entry (lookup-procedure current-groups group-entry-name)) (reverse (fold2 (lambda (group result allocation) (let ((name (user-group-name group)) (password (user-group-password group)) (requested-id (user-group-id group)) (system? (user-group-system? group))) (let*-values (((previous) (previous-entry name)) ((allocation id) (cond ((number? requested-id) (values (reserve-ids allocation (list requested-id)) requested-id)) (previous (values allocation (group-entry-gid previous))) (else (allocate-id allocation #:system? system?))))) (values (cons (group-entry (name name) (password (if previous (group-entry-password previous) password)) (gid id) (members (vhash-fold* cons '() name members))) result) allocation)))) '() gids groups))) (define* (allocate-passwd users groups #:optional (current-passwd '())) "Return a list of password entries for USERS, a list of <user-account>. Take GIDs from GROUPS, a list of group entries. Reuse UIDs from CURRENT-PASSWD, a list of password entries, when possible; otherwise allocate new UIDs." (define uids (reserve-ids (reserve-ids (allocation) (map password-entry-uid current-passwd)) (filter-map user-account-uid users) #:skip? #f)) (define previous-entry (lookup-procedure current-passwd password-entry-name)) (define (group-id name) (or (any (lambda (entry) (and (string=? (group-entry-name entry) name) (group-entry-gid entry))) groups) (error "group not found" name))) (reverse (fold2 (lambda (user result allocation) (let ((name (user-account-name user)) (requested-id (user-account-uid user)) (group (user-account-group user)) (real-name (user-account-comment user)) (directory (user-account-home-directory user)) (shell (user-account-shell user)) (system? (user-account-system? user))) (let*-values (((previous) (previous-entry name)) ((allocation id) (cond ((number? requested-id) (values (reserve-ids allocation (list requested-id)) requested-id)) (previous (values allocation (password-entry-uid previous))) (else (allocate-id allocation #:system? system?))))) (values (cons (password-entry (name name) (uid id) (directory directory) (gid (if (number? group) group (group-id group))) (real-name (if previous (password-entry-real-name previous) real-name)) (shell (if previous (password-entry-shell previous) shell))) result) allocation)))) '() uids users))) (define* (days-since-epoch #:optional (current-time current-time)) "Return the number of days elapsed since the 1st of January, 1970." (let* ((now (current-time time-utc)) (epoch (make-time time-utc 0 0)) (diff (time-difference now epoch))) (quotient (time-second diff) (* 24 3600)))) (define* (passwd->shadow users passwd #:optional (current-shadow '()) #:key (current-time current-time)) "Return a list of shadow entries for the password entries listed in PASSWD. Reuse shadow entries from CURRENT-SHADOW when they exist, and take the initial password from USERS." (define previous-entry (lookup-procedure current-shadow shadow-entry-name)) (define now (days-since-epoch current-time)) (map (lambda (user passwd) (or (previous-entry (password-entry-name passwd)) (shadow-entry (name (password-entry-name passwd)) (password (user-account-password user)) (last-change now)))) users passwd)) (define (empty-if-not-found thunk) "Call THUNK and return the empty list if that throws to ENOENT." (catch 'system-error thunk (lambda args (if (= ENOENT (system-error-errno args)) '() (apply throw args))))) (define* (user+group-databases users groups #:key (current-passwd (empty-if-not-found read-passwd)) (current-groups (empty-if-not-found read-group)) (current-shadow (empty-if-not-found read-shadow)) (current-time current-time)) "Return three values: the list of group entries, the list of password entries, and the list of shadow entries corresponding to USERS and GROUPS. Preserve stateful bits from CURRENT-PASSWD, CURRENT-GROUPS, and CURRENT-SHADOW: UIDs, GIDs, passwords, user shells, etc." (define members ;; Map group name to user names. (fold (lambda (user members) (fold (cute vhash-cons <> (user-account-name user) <>) members (user-account-supplementary-groups user))) vlist-null users)) (define group-entries (allocate-groups groups members current-groups)) (define passwd-entries (allocate-passwd users group-entries current-passwd)) (define shadow-entries (passwd->shadow users passwd-entries current-shadow #:current-time current-time)) (values group-entries passwd-entries shadow-entries))