@@ -61,15 +61,15 @@ (define-module (gnu services base)
#:use-module (gnu packages admin)
#:use-module ((gnu packages linux)
#:select (alsa-utils btrfs-progs crda eudev
- e2fsprogs f2fs-tools fuse gpm kbd lvm2 rng-tools
- util-linux xfsprogs))
+ e2fsprogs f2fs-tools fuse gpm kbd lvm2 rng-tools
+ util-linux xfsprogs))
#:use-module (gnu packages bash)
#:use-module ((gnu packages base)
#:select (coreutils glibc glibc/hurd
- glibc-utf8-locales
- libc-utf8-locales-for-target
- make-glibc-utf8-locales
- tar canonical-package))
+ glibc-utf8-locales
+ libc-utf8-locales-for-target
+ make-glibc-utf8-locales
+ tar canonical-package))
#:use-module ((gnu packages cross-base)
#:select (cross-libc))
#:use-module ((gnu packages compression) #:select (gzip))
@@ -346,12 +346,360 @@ (define %root-file-system-shepherd-service
(shepherd-service
(documentation "Take care of the root file system.")
(provision '(root-file-system))
+ ;; Is it possible to have (gnu build linux-boot) loaded already?
+ ;; In that case, I'd like to move a lot of stuff there.
+ (modules '((ice-9 textual-ports)
+ (ice-9 control)
+ (ice-9 string-fun)
+ (ice-9 match)
+ (ice-9 ftw) ; scandir
+ (srfi srfi-1) ; filter, for-each, find.
+ (srfi srfi-26) ; cut
+ (ice-9 exceptions))) ; guard
(start #~(const #t))
(stop #~(lambda _
- ;; Return #f if successfully stopped.
+ ;;; Return #f if successfully stopped.
+
+ ;;; Beginning of inlined module (fuser)
+
+ (define log (make-parameter (lambda args
+ (apply format (current-error-port) args))))
+ (define PROC-DIR-NAME "/proc")
+ (define DEFAULT-SILENT-ERRORS
+ (list ENOENT ESRCH))
+
+ (define* (call-with-safe-syscall thunk
+ #:key
+ (on-error #f)
+ (silent-errors DEFAULT-SILENT-ERRORS)
+ (error-message-format #f)
+ (error-context '()))
+ "Call THUNK, handling system errors:
+- If ERROR-MESSAGE-FORMAT and the error is not in SILENT-ERRORS, calls format
+with ERROR-MESSAGE-FORMAT and ERROR-CONTEXT and (strerror errno) as arguments.
+- Return ON-ERROR on error."
+ (catch 'system-error
+ thunk
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (unless (member errno silent-errors)
+ (when error-message-format
+ (apply format
+ (current-error-port)
+ error-message-format
+ (append
+ error-context
+ (list (strerror errno))))))
+ on-error))))
+
+ (define (safe-stat path)
+ "Get stat info for PATH--or #f if not possible."
+ (call-with-safe-syscall (lambda () (stat path))
+ #:error-message-format "Error: Cannot stat ~s: ~a~%"
+ #:error-context (list path)
+ #:silent-errors '()
+ #:on-error #f))
+
+ (define (safe-umount path)
+ "Umount PATH--if possible.."
+ (call-with-safe-syscall (lambda () (umount path))
+ #:error-message-format "Error: Cannot umount ~s: ~a~%"
+ #:error-context (list path)
+ #:silent-errors '()
+ #:on-error 'error))
+
+ (define (safe-lstat path)
+ "Get lstat info for PATH--or #f if not possible."
+ (call-with-safe-syscall (lambda () (lstat path))
+ #:error-message-format "Error: Cannot lstat ~s: ~a~%"
+ #:error-context (list path)
+ #:on-error #f))
+
+ (define (safe-scandir path)
+ "scandir PATH--or #f if not possible."
+ (let ((result (scandir path)))
+ (if result
+ result
+ (begin
+ ((log) "Error: Cannot scandir ~s: ?~%" path)
+ '()))))
+
+;;; Processes
+
+ (define (safe-get-fd-flags pid fd)
+ "Get flags for FD in PID--or #f if not possible."
+ (let ((fdinfo-path (format #f "~a/~a/fdinfo/~a" PROC-DIR-NAME pid fd)))
+ (call-with-safe-syscall (lambda ()
+ (call-with-input-file fdinfo-path
+ (lambda (port)
+ ;; Find 'flags:' line and parse octal value
+ (let loop ()
+ (let ((line (get-line port)))
+ (cond ((eof-object? line) #f)
+ ((string-prefix? "flags:\t" line)
+ (match (string-split line #\tab)
+ ((_ flags-str)
+ (catch 'invalid-argument
+ (lambda ()
+ (string->number flags-str 8))
+ (lambda args
+ #f)))
+ (_ #f)))
+ (else (loop))))))))
+ #:error-message-format "Error: Cannot read ~s: ~a~%"
+ #:error-context (list fdinfo-path)
+ #:on-error #f)))
+
+ (define (safe-get-processes)
+ "Get a list of all PIDs from proc--or #f if not possible."
+ (let ((proc-dir PROC-DIR-NAME))
+ (catch 'system-error
+ (lambda ()
+ ;; Keep only numbers.
+ (filter-map string->number (safe-scandir proc-dir)))
+ ;; FIXME is errno even useful?
+ (lambda scan-err
+ ((log) "Error scanning ~s: ~a~%"
+ proc-dir (strerror (system-error-errno scan-err)))
+ '()))))
+
+ (define (safe-fd-on-device? pid fd target-device)
+ "Return whether fd FD on pid PID is on device TARGET-DEVICE."
+ (let* ((fd-path (readlink (format #f "~a/~a/fd/~a" PROC-DIR-NAME pid fd)))
+ (stat (safe-lstat fd-path)))
+ (and stat (eqv? (stat:dev stat)
+ target-device))))
+
+ (define (safe-get-process-fds pid)
+ "Get a list of all FDs of PID from proc--or #f if not possible."
+ (let ((fd-dir (format #f "~a/~a/fd" PROC-DIR-NAME pid)))
+ ;; Keep only numbers.
+ (filter-map string->number (safe-scandir fd-dir))))
+
+ (define (filter-process-fd-flags pid fds predicate)
+ "Get FLAGS from proc for PID and call PREDICATE with (FD FLAGS) each."
+ (filter (lambda (fd)
+ (predicate fd (safe-get-fd-flags pid fd)))
+ fds))
+
+ (define (safe-get-process-command pid)
+ "Return command of process PID--or #f if not possible."
+ (let ((cmdline-path (format #f "~a/~a/cmdline" PROC-DIR-NAME pid)))
+ (call-with-safe-syscall (lambda ()
+ (call-with-input-file cmdline-path
+ (lambda (port)
+ (let ((full-cmdline (get-string-all port)))
+ (match (string-split full-cmdline #\nul)
+ ((command-name . _) command-name))))))
+ #:error-message-format "Error: Cannot read ~s: ~a~%"
+ #:error-context (list cmdline-path)
+ #:on-error #f)))
+
+ (define (safe-kill-process pid kill-signal)
+ "Kill process PID with KILL-SIGNAL if possible."
+ (call-with-safe-syscall (lambda ()
+ (kill pid kill-signal)
+ #t)
+ #:on-error 'error
+ #:silent-errors '()
+ #:error-message-format
+ "Error: Failed to kill process ~a: ~a~%"
+ #:error-context '()))
+
+;;; Mounts
+
+ (define (safe-get-device mount-point)
+ "Get the device ID (st_dev) of MOUNT-POINT--or #f if not possible."
+ (and=>
+ (safe-stat mount-point)
+ stat:dev))
+
+ (define (safe-parse-mountinfo path)
+ "Read and parse /proc/self/mountinfo (or specified path).
+Return a list of parsed entries, where each entry is:
+(list mount-id parent-id mount-point-string)
+Return '() on file read error or if file is unparseable."
+ (call-with-safe-syscall ; TODO: call-with-input-file is not actually a syscall.
+ (lambda ()
+ (let ((entries '()))
+ (call-with-input-file path
+ (lambda (port)
+ (let loop ()
+ (let ((line (get-line port)))
+ (unless (eof-object? line)
+ (match (string-split line #\space)
+ ;; mnt_id par_id major:minor root mount_point ...
+ ((m-id-str p-id-str _ _ mp . _)
+ ;; Attempt to parse IDs, skip line on error
+ (catch 'invalid-argument
+ (lambda ()
+ (let ((mount-id (string->number m-id-str))
+ (parent-id (string->number p-id-str)))
+ ;; Add successfully parsed entry to list
+ (set! entries (cons (list mount-id parent-id mp)
+ entries))
+ (loop))) ; Continue to next line
+ (lambda args
+ ((log)
+ "Warning: Skipping mountinfo line due to parse error: ~s (~a)~%"
+ line args)
+ (loop))))
+ (_ (loop))))))))
+ ;; Return parsed entries in file order
+ (reverse entries)))
+ #:error-message-format "Error: Cannot read or parse mountinfo file ~s: ~a"
+ #:error-context (list path)
+ #:on-error '()))
+
+ (define (safe-find-nested-mounts root-mount-point target-device)
+ "Find mount points that block the unmounting of ROOT-MOUNT-POINT.
+TARGET-DEVICE argument is ignored.
+Mountpoints are returned depth-first (in the order they can be unmounted).
+ROOT-MOUNT-POINT is included."
+ (let* ((mountinfo (safe-parse-mountinfo (format #f "~a/self/mountinfo" PROC-DIR-NAME))))
+ (define (safe-find-mounts-via-mountinfo accumulator lives root-mount-point)
+ (if (member root-mount-point accumulator)
+ ((log) "Cycle detected~%"))
+ (let ((accumulator (cons root-mount-point accumulator)))
+ (if (= lives 0)
+ (begin
+ ((log) "Error: Recursive mountpoints too deep.~%")
+ accumulator)
+ (let ((root-entry (find (lambda (entry)
+ (match entry
+ ((_ _ mp) (string=? mp root-mount-point))
+ (_ #f))) ; Should not happen
+ mountinfo)))
+ (if root-entry
+ (let ((root-mount-id (car root-entry)))
+ (fold (lambda (entry accumulator)
+ (match entry
+ ((_ parent-id mp)
+ (if (= parent-id root-mount-id)
+ (safe-find-mounts-via-mountinfo accumulator
+ (- lives 1)
+ mp)
+ accumulator))
+ (_ accumulator)))
+ accumulator
+ mountinfo))
+ (begin
+ ((log) "Error: Could not find mount ID for ~s in parsed mountinfo~%"
+ root-mount-point)
+ accumulator))))))
+ (safe-find-mounts-via-mountinfo '() 100 root-mount-point)))
+
+ ;;; End of inlined module (fuser)
+
+ (define MOUNT-POINT "/")
+
+ (define O_ACCMODE #o0003)
+
+ (define (flags-has-write-access? flags)
+ "Given open FLAGS, return whether it (probably) signifies write access."
+ (and flags (not (= (logand flags O_ACCMODE)
+ O_RDONLY))))
+
+ (define (ask-to-kill? pid command)
+ "Ask whether to kill process with id PID (and command COMMAND)"
+ ((log) "~%Process Found: PID ~a Command: ~s~%" pid command)
+ ((log) "Kill process ~a? [y/N] " pid)
+ (force-output (current-error-port))
+ (let ((response (read-char (current-input-port))))
+ (if (not (eof-object? response))
+ ;; Consume rest of line.
+ (read-line (current-input-port)))
+ (or (eqv? response #\y)
+ (eqv? response #\Y))))
+
(sync)
- (let ((null (%make-void-port "w")))
+ (let* ((null (%make-void-port "w"))
+ (call-with-io-file (lambda (file-name proc)
+ (let ((port (open file-name O_RDWR)))
+ (set-current-input-port port)
+ (set-current-output-port port)
+ (set-current-error-port port)
+ (catch #t (lambda ()
+ (proc)
+ (set-current-input-port null)
+ (set-current-output-port null)
+ (set-current-error-port null)
+ (close port))
+ (lambda args
+ (set-current-input-port null)
+ (set-current-output-port null)
+ (set-current-error-port null)
+ (close port)))))))
+ (let-syntax ((with-mounted-filesystem (syntax-rules ()
+ ((_ source mountpoint file-system-type options exp ...)
+ (call-with-mounted-filesystem source mountpoint file-system-type options
+ (lambda () (begin exp ...)))))))
+
+ (define (call-with-logging thunk)
+ (with-mounted-filesystem "none" "/proc" "proc" 0
+ (with-mounted-filesystem "none" "/dev" "devtmpfs" 0
+ (catch 'system-error
+ (lambda ()
+ (mknod "/dev/tty" 'char-special #o600 (+ (* 5 256) 0)))
+ (const #f))
+ ;; we don't have chvt :(
+ ;; (it would need to use %ioctl fd VT_ACTIVATE int on /dev/tty)
+ ;(chvt 12)
+ (call-with-io-file "/dev/tty" thunk))))
+
+ (define (get-clean-ups)
+ ;; We rarely (or ever) log--and if we did have a logger
+ ;; at all times, we'd show up on our own shitlist.
+ ;; So: open logger, log, close logger--on every message.
+ (parameterize ((log (lambda args
+ (call-with-logging
+ (lambda ()
+ (format (current-error-port) args))))))
+ (let* ((root-device (safe-get-device MOUNT-POINT))
+ (mounts (safe-find-nested-mounts MOUNT-POINT root-device))
+ (mount-devices (map safe-get-device mounts)))
+ (let* ((our-pid (getpid))
+ (pids (filter (lambda (pid)
+ (not (= pid our-pid)))
+ (safe-get-processes)))
+ (pids (filter (lambda (pid)
+ (match (filter-process-fd-flags pid
+ (safe-get-process-fds pid)
+ (lambda (fd flags)
+ (and (flags-has-write-access? flags)
+ (find (lambda (target-device)
+ (safe-fd-on-device? pid fd target-device))
+ mount-devices))))
+ ((x . _) #t)
+ (_ #f)))
+ pids)))
+ (list pids mounts mount-devices)))))
+
+ (define (call-with-mounted-filesystem source mountpoint file-system-type options proc)
+ (mount source mountpoint file-system-type options #:update-mtab? #f)
+ (catch #t
+ (lambda ()
+ (proc)
+ (umount mountpoint))
+ (lambda args
+ (umount mountpoint))))
+
+ ;; This will take care of setting up a logger for the entire runtime of the function.
+ (define (kill-processes pids mounts mount-devices signal)
+ (call-with-logging
+ (lambda ()
+ (let ((error-port (current-error-port)))
+ ((log) "Searched for processes writing on devices ~s (mount points ~s)...~%" mount-devices mounts)
+ (format error-port "Found ~a process(es) matching the criteria.~%" (length pids))
+ (for-each (lambda (pid)
+ (let ((command (safe-get-process-command pid)))
+ (if (ask-to-kill? pid command)
+ (safe-kill-process pid signal)
+ (format error-port "Skipping PID ~a (~s).~%" pid command))))
+ pids)
+ (format error-port "~%Process scan complete.~%")))))
+
;; Redirect the default output ports.
(set-current-output-port null)
(set-current-error-port null)
@@ -363,18 +711,46 @@ (define %root-file-system-shepherd-service
;; root file system can be re-mounted read-only.
(let loop ((n 10))
(unless (catch 'system-error
- (lambda ()
- (mount #f "/" #f
- (logior MS_REMOUNT MS_RDONLY)
- #:update-mtab? #f)
- #t)
- (const #f))
+ (lambda ()
+ (mount #f "/" #f
+ (logior MS_REMOUNT MS_RDONLY)
+ #:update-mtab? #f)
+ #t)
+ (const #f))
+ (when (zero? n)
+ ;; 1. Send SIGTERM to all writing processes (if any)
+ (match (get-clean-ups)
+ ((pids mounts mount-devices)
+ (when (> (length pids) 0)
+ (kill-processes pids mounts mount-devices SIGTERM)
+ ((@ (fibers) sleep) 5))))
+
+ ;; 2. Send SIGKILL to all writing processes
+ (match (get-clean-ups)
+ ((pids mounts mount-devices)
+ (when (> (length pids) 0)
+ (kill-processes pids mounts mount-devices SIGKILL)
+ ((@ (fibers) sleep) 5))
+
+ ;; 3. Unmount filesystems
+ (for-each safe-umount mounts)))
+
+ ;; Should have been unmounted already--but we are paranoid
+ ;; (and possibly were blocking ourselves anyway).
+ (catch 'system-error
+ (lambda ()
+ (mount #f "/" #f
+ (logior MS_REMOUNT MS_RDONLY)
+ #:update-mtab? #f)
+ #t)
+ (const #f))
+ ((@ (fibers) sleep) 10))
(unless (zero? n)
;; Yield to the other fibers. That gives logging fibers
;; an opportunity to close log files so the 'mount' call
;; doesn't fail with EBUSY.
((@ (fibers) sleep) 1)
- (loop (- n 1)))))
+ (loop (- n 1))))))
#f)))
(respawn? #f)))
@@ -425,57 +801,57 @@ (define (file-system-shepherd-service file-system)
(and (or mount? create?)
(with-imported-modules (source-module-closure
'((gnu build file-systems)))
- (shepherd-service
- (provision (list (file-system->shepherd-service-name file-system)))
- (requirement `(root-file-system
- udev
- ,@(map dependency->shepherd-service-name dependencies)
- ,@requirements))
- (documentation "Check, mount, and unmount the given file system.")
- (start #~(lambda args
- #$(if create?
- #~(mkdir-p #$target)
- #t)
+ (shepherd-service
+ (provision (list (file-system->shepherd-service-name file-system)))
+ (requirement `(root-file-system
+ udev
+ ,@(map dependency->shepherd-service-name dependencies)
+ ,@requirements))
+ (documentation "Check, mount, and unmount the given file system.")
+ (start #~(lambda args
+ #$(if create?
+ #~(mkdir-p #$target)
+ #t)
- #$(if mount?
- #~(let (($PATH (getenv "PATH")))
- ;; Make sure fsck.ext2 & co. can be found.
- (dynamic-wind
- (lambda ()
- ;; Don’t display the PATH settings.
- (with-output-to-port (%make-void-port "w")
- (lambda ()
- (set-path-environment-variable "PATH"
- '("bin" "sbin")
- '#$packages))))
- (lambda ()
- (mount-file-system
- (spec->file-system
- '#$(file-system->spec file-system))
- #:root "/"))
- (lambda ()
- (setenv "PATH" $PATH))))
- #t)
- #t))
- (stop #~(lambda args
- ;; Normally there are no processes left at this point, so
- ;; TARGET can be safely unmounted.
+ #$(if mount?
+ #~(let (($PATH (getenv "PATH")))
+ ;; Make sure fsck.ext2 & co. can be found.
+ (dynamic-wind
+ (lambda ()
+ ;; Don’t display the PATH settings.
+ (with-output-to-port (%make-void-port "w")
+ (lambda ()
+ (set-path-environment-variable "PATH"
+ '("bin" "sbin")
+ '#$packages))))
+ (lambda ()
+ (mount-file-system
+ (spec->file-system
+ '#$(file-system->spec file-system))
+ #:root "/"))
+ (lambda ()
+ (setenv "PATH" $PATH))))
+ #t)
+ #t))
+ (stop #~(lambda args
+ ;; Normally there are no processes left at this point, so
+ ;; TARGET can be safely unmounted.
- ;; Make sure PID 1 doesn't keep TARGET busy.
- (chdir "/")
+ ;; Make sure PID 1 doesn't keep TARGET busy.
+ (chdir "/")
- #$(if (file-system-mount-may-fail? file-system)
- #~(catch 'system-error
- (lambda () (umount #$target))
- (const #f))
- #~(umount #$target))
- #f))
+ #$(if (file-system-mount-may-fail? file-system)
+ #~(catch 'system-error
+ (lambda () (umount #$target))
+ (const #f))
+ #~(umount #$target))
+ #f))
- ;; We need additional modules.
- (modules `(((gnu build file-systems)
- #:select (mount-file-system))
- (gnu system file-systems)
- ,@%default-modules)))))))
+ ;; We need additional modules.
+ (modules `(((gnu build file-systems)
+ #:select (mount-file-system))
+ (gnu system file-systems)
+ ,@%default-modules)))))))
(define (file-system-shepherd-services file-systems)
"Return the list of Shepherd services for FILE-SYSTEMS."
@@ -523,12 +899,12 @@ (define (file-system-shepherd-services file-systems)
(for-each (lambda (mount-point)
(format #t "unmounting '~a'...~%" mount-point)
(catch 'system-error
- (lambda ()
- (umount mount-point))
- (lambda args
- (let ((errno (system-error-errno args)))
- (format #t "failed to unmount '~a': ~a~%"
- mount-point (strerror errno))))))
+ (lambda ()
+ (umount mount-point))
+ (lambda args
+ (let ((errno (system-error-errno args)))
+ (format #t "failed to unmount '~a': ~a~%"
+ mount-point (strerror errno))))))
(filter (negate known?) (mount-points)))
#f))))
@@ -635,12 +1011,12 @@ (define (urandom-seed-shepherd-service _)
;; available. So, we handle a failed read or any other error
;; reported by the operating system.
(let ((buf (catch 'system-error
- (lambda ()
- (call-with-input-file "/dev/hwrng"
- (lambda (hwrng)
- (get-bytevector-n hwrng 512))))
- ;; Silence is golden...
- (const #f))))
+ (lambda ()
+ (call-with-input-file "/dev/hwrng"
+ (lambda (hwrng)
+ (get-bytevector-n hwrng 512))))
+ ;; Silence is golden...
+ (const #f))))
(when buf
(call-with-output-file "/dev/urandom"
(lambda (urandom)
@@ -711,23 +1087,23 @@ (define-record-type* <rngd-configuration>
(define rngd-service-type
(shepherd-service-type
- 'rngd
- (lambda (config)
- (define rng-tools (rngd-configuration-rng-tools config))
- (define device (rngd-configuration-device config))
+ 'rngd
+ (lambda (config)
+ (define rng-tools (rngd-configuration-rng-tools config))
+ (define device (rngd-configuration-device config))
- (define rngd-command
- (list (file-append rng-tools "/sbin/rngd")
- "-f" "-r" device))
+ (define rngd-command
+ (list (file-append rng-tools "/sbin/rngd")
+ "-f" "-r" device))
- (shepherd-service
- (documentation "Add TRNG to entropy pool.")
- (requirement '(user-processes udev))
- (provision '(trng))
- (start #~(make-forkexec-constructor '#$rngd-command))
- (stop #~(make-kill-destructor))))
- (rngd-configuration)
- (description "Run the @command{rngd} random number generation daemon to
+ (shepherd-service
+ (documentation "Add TRNG to entropy pool.")
+ (requirement '(user-processes udev))
+ (provision '(trng))
+ (start #~(make-forkexec-constructor '#$rngd-command))
+ (stop #~(make-kill-destructor))))
+ (rngd-configuration)
+ (description "Run the @command{rngd} random number generation daemon to
supply entropy to the kernel's pool.")))
(define-deprecated (rngd-service #:key (rng-tools rng-tools)
@@ -791,7 +1167,7 @@ (define hosts-service-type
(let* ((serialize-host-record
(lambda (record)
(match-record record <host> (address canonical-name aliases)
- (format #f "~a~/~a~{~^~/~a~}~%" address canonical-name aliases))))
+ (format #f "~a~/~a~{~^~/~a~}~%" address canonical-name aliases))))
(host-etc-service
(lambda (lst)
`(("hosts" ,(plain-file "hosts"
@@ -1041,7 +1417,7 @@ (define-record-type* <agetty-configuration>
(extra-options agetty-extra-options ;list of strings
(default '()))
(shepherd-requirement agetty-shepherd-requirement ;list of SHEPHERD requirements
- (default '()))
+ (default '()))
;;; XXX Unimplemented for now!
;;; (issue-file agetty-issue-file ;file-like
;;; (default #f))
@@ -1052,189 +1428,189 @@ (define (default-serial-port)
to use as the tty. This is primarily useful for headless systems."
(with-imported-modules (source-module-closure
'((gnu build linux-boot))) ;for 'find-long-options'
- #~(begin
- ;; console=device,options
- ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
- ;; options: BBBBPNF. P n|o|e, N number of bits,
- ;; F flow control (r RTS)
- (let* ((not-comma (char-set-complement (char-set #\,)))
- (command (linux-command-line))
- (agetty-specs (find-long-options "agetty.tty" command))
- (console-specs (filter (lambda (spec)
- (and (string-prefix? "tty" spec)
- (not (or
- (string-prefix? "tty0" spec)
- (string-prefix? "tty1" spec)
- (string-prefix? "tty2" spec)
- (string-prefix? "tty3" spec)
- (string-prefix? "tty4" spec)
- (string-prefix? "tty5" spec)
- (string-prefix? "tty6" spec)
- (string-prefix? "tty7" spec)
- (string-prefix? "tty8" spec)
- (string-prefix? "tty9" spec)))))
- (find-long-options "console" command)))
- (specs (append agetty-specs console-specs)))
- (match specs
- (() #f)
- ((spec _ ...)
- ;; Extract device name from first spec.
- (match (string-tokenize spec not-comma)
- ((device-name _ ...)
- device-name))))))))
+ #~(begin
+ ;; console=device,options
+ ;; device: can be tty0, ttyS0, lp0, ttyUSB0 (serial).
+ ;; options: BBBBPNF. P n|o|e, N number of bits,
+ ;; F flow control (r RTS)
+ (let* ((not-comma (char-set-complement (char-set #\,)))
+ (command (linux-command-line))
+ (agetty-specs (find-long-options "agetty.tty" command))
+ (console-specs (filter (lambda (spec)
+ (and (string-prefix? "tty" spec)
+ (not (or
+ (string-prefix? "tty0" spec)
+ (string-prefix? "tty1" spec)
+ (string-prefix? "tty2" spec)
+ (string-prefix? "tty3" spec)
+ (string-prefix? "tty4" spec)
+ (string-prefix? "tty5" spec)
+ (string-prefix? "tty6" spec)
+ (string-prefix? "tty7" spec)
+ (string-prefix? "tty8" spec)
+ (string-prefix? "tty9" spec)))))
+ (find-long-options "console" command)))
+ (specs (append agetty-specs console-specs)))
+ (match specs
+ (() #f)
+ ((spec _ ...)
+ ;; Extract device name from first spec.
+ (match (string-tokenize spec not-comma)
+ ((device-name _ ...)
+ device-name))))))))
(define (agetty-shepherd-service config)
(match-record config <agetty-configuration>
- (agetty tty term baud-rate auto-login
- login-program login-pause? eight-bits? no-reset? remote? flow-control?
- host no-issue? init-string no-clear? local-line extract-baud?
- skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
- detect-case? wait-cr? no-hints? no-hostname? long-hostname?
- erase-characters kill-characters chdir delay nice extra-options
- shepherd-requirement)
- (list
- (shepherd-service
- (documentation "Run agetty on a tty.")
- (provision (list (symbol-append 'term- (string->symbol (or tty "console")))))
+ (agetty tty term baud-rate auto-login
+ login-program login-pause? eight-bits? no-reset? remote? flow-control?
+ host no-issue? init-string no-clear? local-line extract-baud?
+ skip-login? no-newline? login-options chroot hangup? keep-baud? timeout
+ detect-case? wait-cr? no-hints? no-hostname? long-hostname?
+ erase-characters kill-characters chdir delay nice extra-options
+ shepherd-requirement)
+ (list
+ (shepherd-service
+ (documentation "Run agetty on a tty.")
+ (provision (list (symbol-append 'term- (string->symbol (or tty "console")))))
- ;; Since the login prompt shows the host name, wait for the 'host-name'
- ;; service to be done. Also wait for udev essentially so that the tty
- ;; text is not lost in the middle of kernel messages (see also
- ;; mingetty-shepherd-service).
- (requirement (cons* 'user-processes 'host-name 'udev
- shepherd-requirement))
+ ;; Since the login prompt shows the host name, wait for the 'host-name'
+ ;; service to be done. Also wait for udev essentially so that the tty
+ ;; text is not lost in the middle of kernel messages (see also
+ ;; mingetty-shepherd-service).
+ (requirement (cons* 'user-processes 'host-name 'udev
+ shepherd-requirement))
- (modules '((ice-9 match) (gnu build linux-boot)))
- (start
- (with-imported-modules (source-module-closure
- '((gnu build linux-boot)))
- #~(lambda args
- (let ((defaulted-tty #$(or tty (default-serial-port))))
- (apply
- (if defaulted-tty
- (make-forkexec-constructor
- (list #$(file-append util-linux "/sbin/agetty")
- #$@extra-options
- #$@(if eight-bits?
- #~("--8bits")
- #~())
- #$@(if no-reset?
- #~("--noreset")
- #~())
- #$@(if remote?
- #~("--remote")
- #~())
- #$@(if flow-control?
- #~("--flow-control")
- #~())
- #$@(if host
- #~("--host" #$host)
- #~())
- #$@(if no-issue?
- #~("--noissue")
- #~())
- #$@(if init-string
- #~("--init-string" #$init-string)
- #~())
- #$@(if no-clear?
- #~("--noclear")
- #~())
+ (modules '((ice-9 match) (gnu build linux-boot)))
+ (start
+ (with-imported-modules (source-module-closure
+ '((gnu build linux-boot)))
+ #~(lambda args
+ (let ((defaulted-tty #$(or tty (default-serial-port))))
+ (apply
+ (if defaulted-tty
+ (make-forkexec-constructor
+ (list #$(file-append util-linux "/sbin/agetty")
+ #$@extra-options
+ #$@(if eight-bits?
+ #~("--8bits")
+ #~())
+ #$@(if no-reset?
+ #~("--noreset")
+ #~())
+ #$@(if remote?
+ #~("--remote")
+ #~())
+ #$@(if flow-control?
+ #~("--flow-control")
+ #~())
+ #$@(if host
+ #~("--host" #$host)
+ #~())
+ #$@(if no-issue?
+ #~("--noissue")
+ #~())
+ #$@(if init-string
+ #~("--init-string" #$init-string)
+ #~())
+ #$@(if no-clear?
+ #~("--noclear")
+ #~())
;;; FIXME This doesn't work as expected. According to agetty(8), if this option
;;; is not passed, then the default is 'auto'. However, in my tests, when that
;;; option is selected, agetty never presents the login prompt, and the
;;; term-ttyS0 service respawns every few seconds.
- #$@(if local-line
- #~(#$(match local-line
- ('auto "--local-line=auto")
- ('always "--local-line=always")
- ('never "-local-line=never")))
- #~())
- #$@(if tty
- #~()
- #~("--keep-baud"))
- #$@(if extract-baud?
- #~("--extract-baud")
- #~())
- #$@(if skip-login?
- #~("--skip-login")
- #~())
- #$@(if no-newline?
- #~("--nonewline")
- #~())
- #$@(if login-options
- #~("--login-options" #$login-options)
- #~())
- #$@(if chroot
- #~("--chroot" #$chroot)
- #~())
- #$@(if hangup?
- #~("--hangup")
- #~())
- #$@(if keep-baud?
- #~("--keep-baud")
- #~())
- #$@(if timeout
- #~("--timeout" #$(number->string timeout))
- #~())
- #$@(if detect-case?
- #~("--detect-case")
- #~())
- #$@(if wait-cr?
- #~("--wait-cr")
- #~())
- #$@(if no-hints?
- #~("--nohints?")
- #~())
- #$@(if no-hostname?
- #~("--nohostname")
- #~())
- #$@(if long-hostname?
- #~("--long-hostname")
- #~())
- #$@(if erase-characters
- #~("--erase-chars" #$erase-characters)
- #~())
- #$@(if kill-characters
- #~("--kill-chars" #$kill-characters)
- #~())
- #$@(if chdir
- #~("--chdir" #$chdir)
- #~())
- #$@(if delay
- #~("--delay" #$(number->string delay))
- #~())
- #$@(if nice
- #~("--nice" #$(number->string nice))
- #~())
- #$@(if auto-login
- (list "--autologin" auto-login)
- '())
- #$@(if login-program
- #~("--login-program" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--login-pause")
- #~())
- defaulted-tty
- #$@(if baud-rate
- #~(#$baud-rate)
- #~())
- #$@(if term
- #~(#$term)
- #~())))
- #$(if tty
- #~(const #f) ;always fail to start
- #~(lambda _ ;succeed, but don't do anything
- (format #t "~a: \
+ #$@(if local-line
+ #~(#$(match local-line
+ ('auto "--local-line=auto")
+ ('always "--local-line=always")
+ ('never "-local-line=never")))
+ #~())
+ #$@(if tty
+ #~()
+ #~("--keep-baud"))
+ #$@(if extract-baud?
+ #~("--extract-baud")
+ #~())
+ #$@(if skip-login?
+ #~("--skip-login")
+ #~())
+ #$@(if no-newline?
+ #~("--nonewline")
+ #~())
+ #$@(if login-options
+ #~("--login-options" #$login-options)
+ #~())
+ #$@(if chroot
+ #~("--chroot" #$chroot)
+ #~())
+ #$@(if hangup?
+ #~("--hangup")
+ #~())
+ #$@(if keep-baud?
+ #~("--keep-baud")
+ #~())
+ #$@(if timeout
+ #~("--timeout" #$(number->string timeout))
+ #~())
+ #$@(if detect-case?
+ #~("--detect-case")
+ #~())
+ #$@(if wait-cr?
+ #~("--wait-cr")
+ #~())
+ #$@(if no-hints?
+ #~("--nohints?")
+ #~())
+ #$@(if no-hostname?
+ #~("--nohostname")
+ #~())
+ #$@(if long-hostname?
+ #~("--long-hostname")
+ #~())
+ #$@(if erase-characters
+ #~("--erase-chars" #$erase-characters)
+ #~())
+ #$@(if kill-characters
+ #~("--kill-chars" #$kill-characters)
+ #~())
+ #$@(if chdir
+ #~("--chdir" #$chdir)
+ #~())
+ #$@(if delay
+ #~("--delay" #$(number->string delay))
+ #~())
+ #$@(if nice
+ #~("--nice" #$(number->string nice))
+ #~())
+ #$@(if auto-login
+ (list "--autologin" auto-login)
+ '())
+ #$@(if login-program
+ #~("--login-program" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--login-pause")
+ #~())
+ defaulted-tty
+ #$@(if baud-rate
+ #~(#$baud-rate)
+ #~())
+ #$@(if term
+ #~(#$term)
+ #~())))
+ #$(if tty
+ #~(const #f) ;always fail to start
+ #~(lambda _ ;succeed, but don't do anything
+ (format #t "~a: \
no serial port console requested; doing nothing~%"
- '#$(car provision))
- 'idle)))
- args)))))
- (stop #~(let ((stop (make-kill-destructor)))
- (lambda (running)
- (if (eq? 'idle running)
- #f
- (stop running)))))))))
+ '#$(car provision))
+ 'idle)))
+ args)))))
+ (stop #~(let ((stop (make-kill-destructor)))
+ (lambda (running)
+ (if (eq? 'idle running)
+ #f
+ (stop running)))))))))
(define agetty-service-type
(service-type (name 'agetty)
@@ -1290,61 +1666,61 @@ (define (mingetty-shepherd-service config)
login-pause? clear-on-logout? delay
print-issue print-hostname nice
working-directory root-directory shepherd-requirement)
- (list
- (shepherd-service
- (documentation "Run mingetty on an tty.")
- (provision (list (symbol-append 'term- (string->symbol tty))))
+ (list
+ (shepherd-service
+ (documentation "Run mingetty on an tty.")
+ (provision (list (symbol-append 'term- (string->symbol tty))))
- (requirement shepherd-requirement)
+ (requirement shepherd-requirement)
- (start #~(make-forkexec-constructor
- (list #$(file-append mingetty "/sbin/mingetty")
+ (start #~(make-forkexec-constructor
+ (list #$(file-append mingetty "/sbin/mingetty")
- ;; Avoiding 'vhangup' allows us to avoid 'setfont'
- ;; errors down the path where various ioctls get
- ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
- ;; in Linux.
- "--nohangup" #$tty
+ ;; Avoiding 'vhangup' allows us to avoid 'setfont'
+ ;; errors down the path where various ioctls get
+ ;; EIO--see 'hung_up_tty_ioctl' in driver/tty/tty_io.c
+ ;; in Linux.
+ "--nohangup" #$tty
- #$@(if clear-on-logout?
- #~()
- #~("--noclear"))
- #$@(if auto-login
- #~("--autologin" #$auto-login)
- #~())
- #$@(if login-program
- #~("--loginprog" #$login-program)
- #~())
- #$@(if login-pause?
- #~("--loginpause")
- #~())
- #$@(if delay
- #~("--delay" #$(number->string delay))
- #~())
- #$@(match print-issue
- (#t
- #~())
- ('no-nl
- #~("--nonewline"))
- (#f
- #~("--noissue")))
- #$@(match print-hostname
- (#t
- #~())
- ('long
- #~("--long-hostname"))
- (#f
- #~("--nohostname")))
- #$@(if nice
- #~("--nice" #$(number->string nice))
- #~())
- #$@(if working-directory
- #~("--chdir" #$working-directory)
- #~())
- #$@(if root-directory
- #~("--chroot" #$root-directory)
- #~()))))
- (stop #~(make-kill-destructor))))))
+ #$@(if clear-on-logout?
+ #~()
+ #~("--noclear"))
+ #$@(if auto-login
+ #~("--autologin" #$auto-login)
+ #~())
+ #$@(if login-program
+ #~("--loginprog" #$login-program)
+ #~())
+ #$@(if login-pause?
+ #~("--loginpause")
+ #~())
+ #$@(if delay
+ #~("--delay" #$(number->string delay))
+ #~())
+ #$@(match print-issue
+ (#t
+ #~())
+ ('no-nl
+ #~("--nonewline"))
+ (#f
+ #~("--noissue")))
+ #$@(match print-hostname
+ (#t
+ #~())
+ ('long
+ #~("--long-hostname"))
+ (#f
+ #~("--nohostname")))
+ #$@(if nice
+ #~("--nice" #$(number->string nice))
+ #~())
+ #$@(if working-directory
+ #~("--chdir" #$working-directory)
+ #~())
+ #$@(if root-directory
+ #~("--chroot" #$root-directory)
+ #~()))))
+ (stop #~(make-kill-destructor))))))
(define mingetty-service-type
(service-type (name 'mingetty)
@@ -1374,12 +1750,12 @@ (define-record-type* <nscd-configuration> nscd-configuration
(default '()))
(glibc nscd-configuration-glibc ;file-like
(default (let-system (system target)
- ;; Unless we're cross-compiling, arrange to use nscd
- ;; from 'glibc-final' instead of pulling in a second
- ;; glibc copy.
- (if target
- (cross-libc target)
- (canonical-package glibc))))))
+ ;; Unless we're cross-compiling, arrange to use nscd
+ ;; from 'glibc-final' instead of pulling in a second
+ ;; glibc copy.
+ (if target
+ (cross-libc target)
+ (canonical-package glibc))))))
(define-record-type* <nscd-cache> nscd-cache make-nscd-cache
nscd-cache?
@@ -1388,7 +1764,7 @@ (define-record-type* <nscd-cache> nscd-cache make-nscd-cache
(negative-time-to-live nscd-cache-negative-time-to-live
(default 20)) ;integer
(suggested-size nscd-cache-suggested-size ;integer ("default module
- ;of hash table")
+ ;of hash table")
(default 211))
(check-files? nscd-cache-check-files? ;Boolean
(default #t))
@@ -1446,45 +1822,45 @@ (define (nscd.conf-file config)
@code{<nscd-configuration>} object."
(define (cache->config cache)
(match-record cache <nscd-cache>
- (database positive-time-to-live negative-time-to-live
- suggested-size check-files?
- persistent? shared? max-database-size auto-propagate?)
- (let ((database (symbol->string database)))
- (string-append "\nenable-cache\t" database "\tyes\n"
+ (database positive-time-to-live negative-time-to-live
+ suggested-size check-files?
+ persistent? shared? max-database-size auto-propagate?)
+ (let ((database (symbol->string database)))
+ (string-append "\nenable-cache\t" database "\tyes\n"
- "positive-time-to-live\t" database "\t"
- (number->string positive-time-to-live) "\n"
- "negative-time-to-live\t" database "\t"
- (number->string negative-time-to-live) "\n"
- "suggested-size\t" database "\t"
- (number->string suggested-size) "\n"
- "check-files\t" database "\t"
- (if check-files? "yes\n" "no\n")
- "persistent\t" database "\t"
- (if persistent? "yes\n" "no\n")
- "shared\t" database "\t"
- (if shared? "yes\n" "no\n")
- "max-db-size\t" database "\t"
- (number->string max-database-size) "\n"
- "auto-propagate\t" database "\t"
- (if auto-propagate? "yes\n" "no\n")))))
+ "positive-time-to-live\t" database "\t"
+ (number->string positive-time-to-live) "\n"
+ "negative-time-to-live\t" database "\t"
+ (number->string negative-time-to-live) "\n"
+ "suggested-size\t" database "\t"
+ (number->string suggested-size) "\n"
+ "check-files\t" database "\t"
+ (if check-files? "yes\n" "no\n")
+ "persistent\t" database "\t"
+ (if persistent? "yes\n" "no\n")
+ "shared\t" database "\t"
+ (if shared? "yes\n" "no\n")
+ "max-db-size\t" database "\t"
+ (number->string max-database-size) "\n"
+ "auto-propagate\t" database "\t"
+ (if auto-propagate? "yes\n" "no\n")))))
(match-record config <nscd-configuration>
- (log-file debug-level caches)
- (plain-file "nscd.conf"
- (string-append "\
+ (log-file debug-level caches)
+ (plain-file "nscd.conf"
+ (string-append "\
# Configuration of libc's name service cache daemon (nscd).\n\n"
- (if log-file
- (string-append "logfile\t" log-file)
- "")
- "\n"
- (if debug-level
- (string-append "debug-level\t"
- (number->string debug-level))
- "")
- "\n"
- (string-concatenate
- (map cache->config caches))))))
+ (if log-file
+ (string-append "logfile\t" log-file)
+ "")
+ "\n"
+ (if debug-level
+ (string-append "debug-level\t"
+ (number->string debug-level))
+ "")
+ "\n"
+ (string-concatenate
+ (map cache->config caches))))))
(define (nscd-action-procedure nscd config option)
;; XXX: This is duplicated from mcron; factorize.
@@ -1498,15 +1874,15 @@ (define (nscd-action-procedure nscd config option)
(match (read-line pipe 'concat)
((? eof-object?)
(catch 'system-error
- (lambda ()
- (zero? (close-pipe pipe)))
- (lambda args
- ;; There's a race with the SIGCHLD handler, which could
- ;; call 'waitpid' before 'close-pipe' above does. If we
- ;; get ECHILD, that means we lost the race; in that case, we
- ;; cannot tell what the exit code was (FIXME).
- (or (= ECHILD (system-error-errno args))
- (apply throw args)))))
+ (lambda ()
+ (zero? (close-pipe pipe)))
+ (lambda args
+ ;; There's a race with the SIGCHLD handler, which could
+ ;; call 'waitpid' before 'close-pipe' above does. If we
+ ;; get ECHILD, that means we lost the race; in that case, we
+ ;; cannot tell what the exit code was (FIXME).
+ (or (= ECHILD (system-error-errno args))
+ (apply throw args)))))
(line
(display line)
(loop)))))))
@@ -1656,8 +2032,8 @@ (define syslog.conf "/etc/syslog.conf")
(define (syslog-etc configuration)
(match-record configuration <syslog-configuration>
- (config-file)
- (list `(,(basename syslog.conf) ,config-file))))
+ (config-file)
+ (list `(,(basename syslog.conf) ,config-file))))
(define (syslog-shepherd-service config)
(define config-file
@@ -1818,43 +2194,43 @@ (define (substitute-key-authorization keys guix)
archive' public keys, with GUIX."
(define default-acl
(with-extensions (list guile-gcrypt)
- (with-imported-modules `(((guix config) => ,(make-config.scm))
- ,@(source-module-closure '((guix pki))
- #:select? not-config?))
- (computed-file "acl"
- #~(begin
- (use-modules (guix pki)
- (gcrypt pk-crypto)
- (ice-9 rdelim))
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure '((guix pki))
+ #:select? not-config?))
+ (computed-file "acl"
+ #~(begin
+ (use-modules (guix pki)
+ (gcrypt pk-crypto)
+ (ice-9 rdelim))
- (define keys
- (map (lambda (file)
- (call-with-input-file file
- (compose string->canonical-sexp
- read-string)))
- '(#$@keys)))
+ (define keys
+ (map (lambda (file)
+ (call-with-input-file file
+ (compose string->canonical-sexp
+ read-string)))
+ '(#$@keys)))
- (call-with-output-file #$output
- (lambda (port)
- (write-acl (public-keys->acl keys)
- port))))))))
+ (call-with-output-file #$output
+ (lambda (port)
+ (write-acl (public-keys->acl keys)
+ port))))))))
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (define acl-file #$%acl-file)
- ;; If the ACL already exists, move it out of the way. Create a backup
- ;; if it's a regular file: it's likely that the user manually updated
- ;; it with 'guix archive --authorize'.
- (if (file-exists? acl-file)
- (if (and (symbolic-link? acl-file)
- (store-file-name? (readlink acl-file)))
- (delete-file acl-file)
- (rename-file acl-file (string-append acl-file ".bak")))
- (mkdir-p (dirname acl-file)))
+ #~(begin
+ (use-modules (guix build utils))
+ (define acl-file #$%acl-file)
+ ;; If the ACL already exists, move it out of the way. Create a backup
+ ;; if it's a regular file: it's likely that the user manually updated
+ ;; it with 'guix archive --authorize'.
+ (if (file-exists? acl-file)
+ (if (and (symbolic-link? acl-file)
+ (store-file-name? (readlink acl-file)))
+ (delete-file acl-file)
+ (rename-file acl-file (string-append acl-file ".bak")))
+ (mkdir-p (dirname acl-file)))
- ;; Installed the declared ACL.
- (symlink #+default-acl acl-file))))
+ ;; Installed the declared ACL.
+ (symlink #+default-acl acl-file))))
(define (install-channels-file channels)
"Return a gexp with code to install CHANNELS, a list of channels, in
@@ -1864,22 +2240,22 @@ (define (install-channels-file channels)
`(list ,@(map channel->code channels))))
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- ;; If channels.scm already exists, move it out of the way. Create a
- ;; backup if it's a regular file: it's likely that the user
- ;; manually defined it.
- (if (file-exists? "/etc/guix/channels.scm")
- (if (and (symbolic-link? "/etc/guix/channels.scm")
- (store-file-name? (readlink "/etc/guix/channels.scm")))
- (delete-file "/etc/guix/channels.scm")
- (rename-file "/etc/guix/channels.scm"
- "/etc/guix/channels.scm.bak"))
- (mkdir-p "/etc/guix"))
+ ;; If channels.scm already exists, move it out of the way. Create a
+ ;; backup if it's a regular file: it's likely that the user
+ ;; manually defined it.
+ (if (file-exists? "/etc/guix/channels.scm")
+ (if (and (symbolic-link? "/etc/guix/channels.scm")
+ (store-file-name? (readlink "/etc/guix/channels.scm")))
+ (delete-file "/etc/guix/channels.scm")
+ (rename-file "/etc/guix/channels.scm"
+ "/etc/guix/channels.scm.bak"))
+ (mkdir-p "/etc/guix"))
- ;; Installed the declared channels.
- (symlink #+channels-file "/etc/guix/channels.scm"))))
+ ;; Installed the declared channels.
+ (symlink #+channels-file "/etc/guix/channels.scm"))))
(define %default-authorized-guix-keys
;; List of authorized substitute keys.
@@ -1890,33 +2266,33 @@ (define (guix-machines-files-installation machines)
"Return a gexp to install MACHINES, a list of gexps, as
/etc/guix/machines.scm, which is used for offloading."
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- (define machines-file
- "/etc/guix/machines.scm")
+ (define machines-file
+ "/etc/guix/machines.scm")
- ;; If MACHINES-FILE already exists, move it out of the way.
- ;; Create a backup if it's a regular file: it's likely that the
- ;; user manually updated it.
- (let ((stat (false-if-exception (lstat machines-file))))
- (if stat
- (if (and (eq? 'symlink (stat:type stat))
- (store-file-name? (readlink machines-file)))
- (delete-file machines-file)
- (rename-file machines-file
- (string-append machines-file ".bak")))
- (mkdir-p (dirname machines-file))))
+ ;; If MACHINES-FILE already exists, move it out of the way.
+ ;; Create a backup if it's a regular file: it's likely that the
+ ;; user manually updated it.
+ (let ((stat (false-if-exception (lstat machines-file))))
+ (if stat
+ (if (and (eq? 'symlink (stat:type stat))
+ (store-file-name? (readlink machines-file)))
+ (delete-file machines-file)
+ (rename-file machines-file
+ (string-append machines-file ".bak")))
+ (mkdir-p (dirname machines-file))))
- ;; Installed the declared machines file.
- (symlink #+(scheme-file "machines.scm"
- #~((@ (srfi srfi-1) append-map)
- (lambda (entry)
- (if (build-machine? entry)
- (list entry)
- entry))
- #$machines))
- machines-file))))
+ ;; Installed the declared machines file.
+ (symlink #+(scheme-file "machines.scm"
+ #~((@ (srfi srfi-1) append-map)
+ (lambda (entry)
+ (if (build-machine? entry)
+ (list entry)
+ entry))
+ #$machines))
+ machines-file))))
(define (run-with-writable-store)
"Return a wrapper that runs the given command under the specified UID and
@@ -1925,31 +2301,31 @@ (define (run-with-writable-store)
(program-file "run-with-writable-store"
(with-imported-modules (source-module-closure
'((guix build syscalls)))
- #~(begin
- (use-modules (guix build syscalls)
- (ice-9 match))
+ #~(begin
+ (use-modules (guix build syscalls)
+ (ice-9 match))
- (define (ensure-writable-store store)
- ;; Create a new mount namespace and remount STORE with
- ;; write permissions if it's read-only.
- (unshare CLONE_NEWNS)
- (let ((fs (statfs store)))
- (unless (zero? (logand (file-system-mount-flags fs)
- ST_RDONLY))
- (mount store store "none"
- (logior MS_BIND MS_REMOUNT)))))
+ (define (ensure-writable-store store)
+ ;; Create a new mount namespace and remount STORE with
+ ;; write permissions if it's read-only.
+ (unshare CLONE_NEWNS)
+ (let ((fs (statfs store)))
+ (unless (zero? (logand (file-system-mount-flags fs)
+ ST_RDONLY))
+ (mount store store "none"
+ (logior MS_BIND MS_REMOUNT)))))
- (match (command-line)
- ((_ user group command args ...)
- (ensure-writable-store #$(%store-prefix))
- (let ((uid (or (string->number user)
- (passwd:uid (getpwnam user))))
- (gid (or (string->number group)
- (group:gid (getgrnam group)))))
- (setgroups #())
- (setgid gid)
- (setuid uid)
- (apply execl command command args))))))))
+ (match (command-line)
+ ((_ user group command args ...)
+ (ensure-writable-store #$(%store-prefix))
+ (let ((uid (or (string->number user)
+ (passwd:uid (getpwnam user))))
+ (gid (or (string->number group)
+ (group:gid (getgrnam group)))))
+ (setgroups #())
+ (setgid gid)
+ (setuid uid)
+ (apply execl command command args))))))))
(define (guix-ownership-change-program)
"Return a program that changes ownership of the store and other data files
@@ -1958,61 +2334,61 @@ (define (guix-ownership-change-program)
"validate-guix-ownership"
(with-imported-modules (source-module-closure
'((guix build utils)))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 ftw)
- (ice-9 match))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 ftw)
+ (ice-9 match))
- (define (lchown file uid gid)
- (let ((parent (open (dirname file) O_DIRECTORY)))
- (chown-at parent (basename file) uid gid
- AT_SYMLINK_NOFOLLOW)
- (close-port parent)))
+ (define (lchown file uid gid)
+ (let ((parent (open (dirname file) O_DIRECTORY)))
+ (chown-at parent (basename file) uid gid
+ AT_SYMLINK_NOFOLLOW)
+ (close-port parent)))
- (define (change-ownership directory uid gid)
- ;; chown -R UID:GID DIRECTORY
- (file-system-fold (const #t) ;enter?
- (lambda (file stat result) ;leaf
- (if (eq? 'symlink (stat:type stat))
- (lchown file uid gid)
- (chown file uid gid)))
- (const #t) ;down
- (lambda (directory stat result) ;up
- (chown directory uid gid))
- (const #t) ;skip
- (lambda (file stat errno result)
- (format (current-error-port)
- "i/o error: ~a: ~a~%"
- file (strerror errno))
- #f)
- #t ;seed
- directory
- lstat))
+ (define (change-ownership directory uid gid)
+ ;; chown -R UID:GID DIRECTORY
+ (file-system-fold (const #t) ;enter?
+ (lambda (file stat result) ;leaf
+ (if (eq? 'symlink (stat:type stat))
+ (lchown file uid gid)
+ (chown file uid gid)))
+ (const #t) ;down
+ (lambda (directory stat result) ;up
+ (chown directory uid gid))
+ (const #t) ;skip
+ (lambda (file stat errno result)
+ (format (current-error-port)
+ "i/o error: ~a: ~a~%"
+ file (strerror errno))
+ #f)
+ #t ;seed
+ directory
+ lstat))
- (define (claim-data-ownership uid gid)
- (format #t "Changing file ownership for /gnu/store \
+ (define (claim-data-ownership uid gid)
+ (format #t "Changing file ownership for /gnu/store \
and data directories to ~a:~a...~%"
- uid gid)
- (change-ownership #$(%store-prefix) uid gid)
- (let ((excluded '("." ".." "profiles" "userpool")))
- (for-each (lambda (directory)
- (change-ownership (in-vicinity "/var/guix" directory)
- uid gid))
- (scandir "/var/guix"
- (lambda (file)
- (not (member file
- excluded))))))
- (chown "/var/guix" uid gid)
- (change-ownership "/etc/guix" uid gid)
- (mkdir-p "/var/log/guix")
- (change-ownership "/var/log/guix" uid gid))
+ uid gid)
+ (change-ownership #$(%store-prefix) uid gid)
+ (let ((excluded '("." ".." "profiles" "userpool")))
+ (for-each (lambda (directory)
+ (change-ownership (in-vicinity "/var/guix" directory)
+ uid gid))
+ (scandir "/var/guix"
+ (lambda (file)
+ (not (member file
+ excluded))))))
+ (chown "/var/guix" uid gid)
+ (change-ownership "/etc/guix" uid gid)
+ (mkdir-p "/var/log/guix")
+ (change-ownership "/var/log/guix" uid gid))
- (match (command-line)
- ((_ (= string->number (? integer? uid))
- (= string->number (? integer? gid)))
- (setlocale LC_ALL "C.UTF-8") ;for file name decoding
- (setvbuf (current-output-port) 'line)
- (claim-data-ownership uid gid)))))))
+ (match (command-line)
+ ((_ (= string->number (? integer? uid))
+ (= string->number (? integer? gid)))
+ (setlocale LC_ALL "C.UTF-8") ;for file name decoding
+ (setvbuf (current-output-port) 'line)
+ (claim-data-ownership uid gid)))))))
(define-record-type* <guix-configuration>
guix-configuration make-guix-configuration
@@ -2079,23 +2455,23 @@ (define shepherd-set-http-proxy-action
(documentation
"Change the HTTP(S) proxy used by 'guix-daemon' and restart it.")
(procedure #~(lambda* (_ #:optional proxy)
- (let ((environment (environ)))
- ;; A bit of a hack: communicate PROXY to the 'start'
- ;; method via environment variables.
- (if proxy
- (begin
- (format #t "changing HTTP/HTTPS \
+ (let ((environment (environ)))
+ ;; A bit of a hack: communicate PROXY to the 'start'
+ ;; method via environment variables.
+ (if proxy
+ (begin
+ (format #t "changing HTTP/HTTPS \
proxy of 'guix-daemon' to ~s...~%"
- proxy)
- (setenv "http_proxy" proxy))
- (begin
- (format #t "clearing HTTP/HTTPS \
+ proxy)
+ (setenv "http_proxy" proxy))
+ (begin
+ (format #t "clearing HTTP/HTTPS \
proxy of 'guix-daemon'...~%")
- (unsetenv "http_proxy")))
- (perform-service-action (lookup-service 'guix-daemon)
- 'restart)
- (environ environment)
- #t)))))
+ (unsetenv "http_proxy")))
+ (perform-service-action (lookup-service 'guix-daemon)
+ 'restart)
+ (environ environment)
+ #t)))))
(define shepherd-discover-action
;; Shepherd action to enable or disable substitute servers discovery.
@@ -2105,208 +2481,208 @@ (define shepherd-discover-action
"Enable or disable substitute servers discovery and restart the
'guix-daemon'.")
(procedure #~(lambda* (_ status)
- (let ((environment (environ)))
- (if (and status
- (string=? status "on"))
- (begin
- (format #t "enable substitute servers discovery~%")
- (setenv "discover" "on"))
- (begin
- (format #t "disable substitute servers discovery~%")
- (unsetenv "discover")))
- (perform-service-action (lookup-service 'guix-daemon)
- 'restart)
- (environ environment)
- #t)))))
+ (let ((environment (environ)))
+ (if (and status
+ (string=? status "on"))
+ (begin
+ (format #t "enable substitute servers discovery~%")
+ (setenv "discover" "on"))
+ (begin
+ (format #t "disable substitute servers discovery~%")
+ (unsetenv "discover")))
+ (perform-service-action (lookup-service 'guix-daemon)
+ 'restart)
+ (environ environment)
+ #t)))))
(define (guix-shepherd-services config)
"Return a <shepherd-service> for the Guix daemon service with CONFIG."
(define locales
(let-system (system target)
- (if (target-hurd? (or target system))
- (make-glibc-utf8-locales glibc/hurd)
- glibc-utf8-locales)))
+ (if (target-hurd? (or target system))
+ (make-glibc-utf8-locales glibc/hurd)
+ glibc-utf8-locales)))
(match-record config <guix-configuration>
- (guix privileged?
- build-group build-accounts chroot? authorize-key? authorized-keys
- use-substitutes? substitute-urls max-silent-time timeout
- log-compression discover? extra-options log-file
- http-proxy tmpdir chroot-directories environment
- socket-directory-permissions socket-directory-group
- socket-directory-user)
- (list (shepherd-service
- (provision '(guix-ownership))
- (requirement '(user-processes user-homes))
- (one-shot? #t)
- (start #~(lambda ()
- (let* ((store #$(%store-prefix))
- (stat (lstat store))
- (privileged? #$(guix-configuration-privileged?
- config))
- (change-ownership #$(guix-ownership-change-program))
- (with-writable-store #$(run-with-writable-store)))
- ;; Check whether we're switching from privileged to
- ;; unprivileged guix-daemon, or vice versa, and adjust
- ;; file ownership accordingly. Spawn a child process
- ;; if and only if something needs to be changed.
- ;;
- ;; Note: This service remains in 'starting' state for
- ;; as long as CHANGE-OWNERSHIP is running. That way,
- ;; 'guix-daemon' starts only once we're done.
- (cond ((and (not privileged?)
- (or (zero? (stat:uid stat))
- (zero? (stat:gid stat))))
- (let ((user (getpwnam "guix-daemon")))
- (format #t "Changing to unprivileged guix-daemon.~%")
- (zero?
- (system* with-writable-store "0" "0"
- change-ownership
- (number->string (passwd:uid user))
- (number->string (passwd:gid user))))))
- ((and privileged?
- (and (not (zero? (stat:uid stat)))
- (not (zero? (stat:gid stat)))))
- (format #t "Changing to privileged guix-daemon.~%")
- (zero? (system* with-writable-store "0" "0"
- change-ownership "0" "0")))
- (else #t)))))
- (documentation "Ensure that the store and other data files used by
+ (guix privileged?
+ build-group build-accounts chroot? authorize-key? authorized-keys
+ use-substitutes? substitute-urls max-silent-time timeout
+ log-compression discover? extra-options log-file
+ http-proxy tmpdir chroot-directories environment
+ socket-directory-permissions socket-directory-group
+ socket-directory-user)
+ (list (shepherd-service
+ (provision '(guix-ownership))
+ (requirement '(user-processes user-homes))
+ (one-shot? #t)
+ (start #~(lambda ()
+ (let* ((store #$(%store-prefix))
+ (stat (lstat store))
+ (privileged? #$(guix-configuration-privileged?
+ config))
+ (change-ownership #$(guix-ownership-change-program))
+ (with-writable-store #$(run-with-writable-store)))
+ ;; Check whether we're switching from privileged to
+ ;; unprivileged guix-daemon, or vice versa, and adjust
+ ;; file ownership accordingly. Spawn a child process
+ ;; if and only if something needs to be changed.
+ ;;
+ ;; Note: This service remains in 'starting' state for
+ ;; as long as CHANGE-OWNERSHIP is running. That way,
+ ;; 'guix-daemon' starts only once we're done.
+ (cond ((and (not privileged?)
+ (or (zero? (stat:uid stat))
+ (zero? (stat:gid stat))))
+ (let ((user (getpwnam "guix-daemon")))
+ (format #t "Changing to unprivileged guix-daemon.~%")
+ (zero?
+ (system* with-writable-store "0" "0"
+ change-ownership
+ (number->string (passwd:uid user))
+ (number->string (passwd:gid user))))))
+ ((and privileged?
+ (and (not (zero? (stat:uid stat)))
+ (not (zero? (stat:gid stat)))))
+ (format #t "Changing to privileged guix-daemon.~%")
+ (zero? (system* with-writable-store "0" "0"
+ change-ownership "0" "0")))
+ (else #t)))))
+ (documentation "Ensure that the store and other data files used by
guix-daemon have the right ownership."))
- (shepherd-service
- (documentation "Run the Guix daemon.")
- (provision '(guix-daemon))
- (requirement `(user-processes
- guix-ownership
- ,@(if discover? '(avahi-daemon) '())))
- (actions (list shepherd-set-http-proxy-action
- shepherd-discover-action))
- (modules '((srfi srfi-1)
- (ice-9 match)
- (gnu build shepherd)
- (guix build utils)))
- (start
- (with-imported-modules `(((guix config) => ,(make-config.scm))
- ,@(source-module-closure
- '((gnu build shepherd)
- (guix build utils))
- #:select? not-config?))
- #~(lambda args
- (define proxy
- ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
- ;; the 'set-http-proxy' action.
- (or (getenv "http_proxy") #$http-proxy))
+ (shepherd-service
+ (documentation "Run the Guix daemon.")
+ (provision '(guix-daemon))
+ (requirement `(user-processes
+ guix-ownership
+ ,@(if discover? '(avahi-daemon) '())))
+ (actions (list shepherd-set-http-proxy-action
+ shepherd-discover-action))
+ (modules '((srfi srfi-1)
+ (ice-9 match)
+ (gnu build shepherd)
+ (guix build utils)))
+ (start
+ (with-imported-modules `(((guix config) => ,(make-config.scm))
+ ,@(source-module-closure
+ '((gnu build shepherd)
+ (guix build utils))
+ #:select? not-config?))
+ #~(lambda args
+ (define proxy
+ ;; HTTP/HTTPS proxy. The 'http_proxy' variable is set by
+ ;; the 'set-http-proxy' action.
+ (or (getenv "http_proxy") #$http-proxy))
- (define discover?
- (or (getenv "discover") #$discover?))
+ (define discover?
+ (or (getenv "discover") #$discover?))
- (define daemon-command
- (cons* #$@(if privileged?
- #~()
- #~(#$(run-with-writable-store)
- "guix-daemon" "guix-daemon"))
+ (define daemon-command
+ (cons* #$@(if privileged?
+ #~()
+ #~(#$(run-with-writable-store)
+ "guix-daemon" "guix-daemon"))
- #$(file-append guix "/bin/guix-daemon")
- #$@(if privileged?
- #~("--build-users-group" #$build-group)
- #~())
- "--max-silent-time"
- #$(number->string max-silent-time)
- "--timeout" #$(number->string timeout)
- "--log-compression"
- #$(symbol->string log-compression)
- #$@(if use-substitutes?
- '()
- '("--no-substitutes"))
- (string-append "--discover="
- (if discover? "yes" "no"))
- "--substitute-urls" #$(string-join substitute-urls)
- #$@extra-options
+ #$(file-append guix "/bin/guix-daemon")
+ #$@(if privileged?
+ #~("--build-users-group" #$build-group)
+ #~())
+ "--max-silent-time"
+ #$(number->string max-silent-time)
+ "--timeout" #$(number->string timeout)
+ "--log-compression"
+ #$(symbol->string log-compression)
+ #$@(if use-substitutes?
+ '()
+ '("--no-substitutes"))
+ (string-append "--discover="
+ (if discover? "yes" "no"))
+ "--substitute-urls" #$(string-join substitute-urls)
+ #$@extra-options
- #$@(if chroot?
- '()
- '("--disable-chroot"))
- ;; Add CHROOT-DIRECTORIES and all their dependencies
- ;; (if these are store items) to the chroot.
- (append-map
- (lambda (file)
- (append-map (lambda (directory)
- (list "--chroot-directory"
- directory))
- (call-with-input-file file
- read)))
- '#$(map references-file
- chroot-directories))))
+ #$@(if chroot?
+ '()
+ '("--disable-chroot"))
+ ;; Add CHROOT-DIRECTORIES and all their dependencies
+ ;; (if these are store items) to the chroot.
+ (append-map
+ (lambda (file)
+ (append-map (lambda (directory)
+ (list "--chroot-directory"
+ directory))
+ (call-with-input-file file
+ read)))
+ '#$(map references-file
+ chroot-directories))))
- (define environment-variables
- (append (list #$@(if tmpdir
- (list (string-append "TMPDIR=" tmpdir))
- '())
+ (define environment-variables
+ (append (list #$@(if tmpdir
+ (list (string-append "TMPDIR=" tmpdir))
+ '())
- ;; Make sure we run in a UTF-8 locale so that
- ;; 'guix offload' correctly restores nars
- ;; that contain UTF-8 file names such as
- ;; 'nss-certs'. See
- ;; <https://bugs.gnu.org/32942>.
- (string-append "GUIX_LOCPATH="
- #$locales "/lib/locale")
- "LC_ALL=en_US.utf8"
- ;; Make 'tar' and 'gzip' available so
- ;; that 'guix perform-download' can use
- ;; them when downloading from Software
- ;; Heritage via '(guix swh)'.
- (string-append "PATH="
- #$(file-append tar "/bin") ":"
- #$(file-append gzip "/bin")))
- (if proxy
- (list (string-append "http_proxy=" proxy)
- (string-append "https_proxy=" proxy))
- '())
- '#$environment))
+ ;; Make sure we run in a UTF-8 locale so that
+ ;; 'guix offload' correctly restores nars
+ ;; that contain UTF-8 file names such as
+ ;; 'nss-certs'. See
+ ;; <https://bugs.gnu.org/32942>.
+ (string-append "GUIX_LOCPATH="
+ #$locales "/lib/locale")
+ "LC_ALL=en_US.utf8"
+ ;; Make 'tar' and 'gzip' available so
+ ;; that 'guix perform-download' can use
+ ;; them when downloading from Software
+ ;; Heritage via '(guix swh)'.
+ (string-append "PATH="
+ #$(file-append tar "/bin") ":"
+ #$(file-append gzip "/bin")))
+ (if proxy
+ (list (string-append "http_proxy=" proxy)
+ (string-append "https_proxy=" proxy))
+ '())
+ '#$environment))
- ;; Ensure that a fresh directory is used, in case the old
- ;; one was more permissive and processes have a file
- ;; descriptor referencing it hanging around, ready to use
- ;; with openat.
- (false-if-exception
- (delete-file-recursively "/var/guix/daemon-socket"))
+ ;; Ensure that a fresh directory is used, in case the old
+ ;; one was more permissive and processes have a file
+ ;; descriptor referencing it hanging around, ready to use
+ ;; with openat.
+ (false-if-exception
+ (delete-file-recursively "/var/guix/daemon-socket"))
- (match args
- (((= string->number (? integer? pid)))
- ;; Start the guix-daemon in the same mnt namespace as
- ;; PID. This is necessary when running the installer.
- ;; Assume /var/guix/daemon-socket was created by a
- ;; previous 'start' call without arguments.
- (fork+exec-command/container
- daemon-command
- #:pid pid
- #:environment-variables environment-variables
- #:log-file #$log-file))
- (()
- ;; Default to socket activation.
- (let ((socket (endpoint
- (make-socket-address
- AF_UNIX
- "/var/guix/daemon-socket/socket")
- #:name "socket"
- #:socket-owner
- (or #$socket-directory-user
- #$(if privileged? 0 "guix-daemon"))
- #:socket-group
- (or #$socket-directory-group
- #$(if privileged? 0 "guix-daemon"))
- #:socket-directory-permissions
- #$socket-directory-permissions)))
- ((make-systemd-constructor daemon-command
- (list socket)
- #:environment-variables
- environment-variables
- #:log-file #$log-file))))))))
- (stop #~(lambda (value)
- (if (or (process? value) (integer? value))
- ((make-kill-destructor) value)
- ((make-systemd-destructor) value))))))))
+ (match args
+ (((= string->number (? integer? pid)))
+ ;; Start the guix-daemon in the same mnt namespace as
+ ;; PID. This is necessary when running the installer.
+ ;; Assume /var/guix/daemon-socket was created by a
+ ;; previous 'start' call without arguments.
+ (fork+exec-command/container
+ daemon-command
+ #:pid pid
+ #:environment-variables environment-variables
+ #:log-file #$log-file))
+ (()
+ ;; Default to socket activation.
+ (let ((socket (endpoint
+ (make-socket-address
+ AF_UNIX
+ "/var/guix/daemon-socket/socket")
+ #:name "socket"
+ #:socket-owner
+ (or #$socket-directory-user
+ #$(if privileged? 0 "guix-daemon"))
+ #:socket-group
+ (or #$socket-directory-group
+ #$(if privileged? 0 "guix-daemon"))
+ #:socket-directory-permissions
+ #$socket-directory-permissions)))
+ ((make-systemd-constructor daemon-command
+ (list socket)
+ #:environment-variables
+ environment-variables
+ #:log-file #$log-file))))))))
+ (stop #~(lambda (value)
+ (if (or (process? value) (integer? value))
+ ((make-kill-destructor) value)
+ ((make-systemd-destructor) value))))))))
(define (guix-accounts config)
"Return the user accounts and user groups for CONFIG."
@@ -2339,39 +2715,39 @@ (define (guix-accounts config)
(define (guix-activation config)
"Return the activation gexp for CONFIG."
(match-record config <guix-configuration>
- (guix generate-substitute-key? authorize-key? authorized-keys channels)
- #~(begin
- ;; Assume that the store has BUILD-GROUP as its group. We could
- ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
- ;; chown leads to an entire copy of the tree, which is a bad idea.
+ (guix generate-substitute-key? authorize-key? authorized-keys channels)
+ #~(begin
+ ;; Assume that the store has BUILD-GROUP as its group. We could
+ ;; otherwise call 'chown' here, but the problem is that on a COW overlayfs,
+ ;; chown leads to an entire copy of the tree, which is a bad idea.
- ;; Generate a key pair and optionally authorize substitute server keys.
- (unless (or #$(not generate-substitute-key?)
- (file-exists? "/etc/guix/signing-key.pub"))
- (system* #$(file-append guix "/bin/guix") "archive"
- "--generate-key"))
+ ;; Generate a key pair and optionally authorize substitute server keys.
+ (unless (or #$(not generate-substitute-key?)
+ (file-exists? "/etc/guix/signing-key.pub"))
+ (system* #$(file-append guix "/bin/guix") "archive"
+ "--generate-key"))
- ;; Optionally install /etc/guix/acl...
- #$(if authorize-key?
- (substitute-key-authorization authorized-keys guix)
- #~#f)
+ ;; Optionally install /etc/guix/acl...
+ #$(if authorize-key?
+ (substitute-key-authorization authorized-keys guix)
+ #~#f)
- ;; ... and /etc/guix/channels.scm...
- #$(and channels (install-channels-file channels))
+ ;; ... and /etc/guix/channels.scm...
+ #$(and channels (install-channels-file channels))
- ;; ... and /etc/guix/machines.scm.
- #$(if (null? (guix-configuration-build-machines config))
- #~#f
- (guix-machines-files-installation
- #~(list #$@(guix-configuration-build-machines config)))))))
+ ;; ... and /etc/guix/machines.scm.
+ #$(if (null? (guix-configuration-build-machines config))
+ #~#f
+ (guix-machines-files-installation
+ #~(list #$@(guix-configuration-build-machines config)))))))
(define-record-type* <guix-extension>
guix-extension make-guix-extension
guix-extension?
(authorized-keys guix-extension-authorized-keys ;list of file-like
- (default '()))
+ (default '()))
(substitute-urls guix-extension-substitute-urls ;list of strings
- (default '()))
+ (default '()))
(build-machines guix-extension-build-machines ;list of gexps
(default '()))
(chroot-directories guix-extension-chroot-directories ;list of file-like/strings
@@ -2471,67 +2847,67 @@ (define (guix-publish-shepherd-service config)
lst))))
(match-record config <guix-publish-configuration>
- (guix port host nar-path cache workers ttl negative-ttl
- cache-bypass-threshold advertise?)
- (let ((command #~(list #$(file-append guix "/bin/guix")
- "publish" "-u" "guix-publish"
- "-p" #$(number->string port)
- #$@(config->compression-options config)
- (string-append "--nar-path=" #$nar-path)
- (string-append "--listen=" #$host)
- #$@(if advertise?
- #~("--advertise")
- #~())
- #$@(if workers
- #~((string-append "--workers="
- #$(number->string
- workers)))
- #~())
- #$@(if ttl
- #~((string-append "--ttl="
- #$(number->string ttl)
- "s"))
- #~())
- #$@(if negative-ttl
- #~((string-append "--negative-ttl="
- #$(number->string negative-ttl)
- "s"))
- #~())
- #$@(if cache
- #~((string-append "--cache=" #$cache)
- #$(string-append
- "--cache-bypass-threshold="
- (number->string
- cache-bypass-threshold)))
- #~())))
- (options #~(#:environment-variables
- ;; Make sure we run in a UTF-8 locale so we can produce
- ;; nars for packages that contain UTF-8 file names such
- ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
- (list (string-append "GUIX_LOCPATH="
- #$(libc-utf8-locales-for-target)
- "/lib/locale")
- "LC_ALL=en_US.utf8")
- #:log-file "/var/log/guix-publish.log"))
- (endpoints #~(let ((ai (false-if-exception
- (getaddrinfo #$host
- #$(number->string port)
- AI_NUMERICSERV))))
- (if (pair? ai)
- (list (endpoint (addrinfo:addr (car ai))))
- '()))))
- (list (shepherd-service
- (provision '(guix-publish))
- (requirement `(user-processes
- guix-daemon
- ,@(if advertise? '(avahi-daemon) '())))
+ (guix port host nar-path cache workers ttl negative-ttl
+ cache-bypass-threshold advertise?)
+ (let ((command #~(list #$(file-append guix "/bin/guix")
+ "publish" "-u" "guix-publish"
+ "-p" #$(number->string port)
+ #$@(config->compression-options config)
+ (string-append "--nar-path=" #$nar-path)
+ (string-append "--listen=" #$host)
+ #$@(if advertise?
+ #~("--advertise")
+ #~())
+ #$@(if workers
+ #~((string-append "--workers="
+ #$(number->string
+ workers)))
+ #~())
+ #$@(if ttl
+ #~((string-append "--ttl="
+ #$(number->string ttl)
+ "s"))
+ #~())
+ #$@(if negative-ttl
+ #~((string-append "--negative-ttl="
+ #$(number->string negative-ttl)
+ "s"))
+ #~())
+ #$@(if cache
+ #~((string-append "--cache=" #$cache)
+ #$(string-append
+ "--cache-bypass-threshold="
+ (number->string
+ cache-bypass-threshold)))
+ #~())))
+ (options #~(#:environment-variables
+ ;; Make sure we run in a UTF-8 locale so we can produce
+ ;; nars for packages that contain UTF-8 file names such
+ ;; as 'nss-certs'. See <https://bugs.gnu.org/26948>.
+ (list (string-append "GUIX_LOCPATH="
+ #$(libc-utf8-locales-for-target)
+ "/lib/locale")
+ "LC_ALL=en_US.utf8")
+ #:log-file "/var/log/guix-publish.log"))
+ (endpoints #~(let ((ai (false-if-exception
+ (getaddrinfo #$host
+ #$(number->string port)
+ AI_NUMERICSERV))))
+ (if (pair? ai)
+ (list (endpoint (addrinfo:addr (car ai))))
+ '()))))
+ (list (shepherd-service
+ (provision '(guix-publish))
+ (requirement `(user-processes
+ guix-daemon
+ ,@(if advertise? '(avahi-daemon) '())))
- ;; Use lazy socket activation unless ADVERTISE? is true: in that
- ;; case the process should start right away to advertise itself.
- (start #~(make-systemd-constructor
- #$command #$endpoints #$@options
- #:lazy-start? #$(not advertise?)))
- (stop #~(make-systemd-destructor)))))))
+ ;; Use lazy socket activation unless ADVERTISE? is true: in that
+ ;; case the process should start right away to advertise itself.
+ (start #~(make-systemd-constructor
+ #$command #$endpoints #$@options
+ #:lazy-start? #$(not advertise?)))
+ (stop #~(make-systemd-destructor)))))))
(define %guix-publish-accounts
(list (user-group (name "guix-publish") (system? #t))
@@ -2547,14 +2923,14 @@ (define (guix-publish-activation config)
(let ((cache (guix-publish-configuration-cache config)))
(if cache
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- (mkdir-p #$cache)
- (let* ((pw (getpw "guix-publish"))
- (uid (passwd:uid pw))
- (gid (passwd:gid pw)))
- (chown #$cache uid gid))))
+ (mkdir-p #$cache)
+ (let* ((pw (getpw "guix-publish"))
+ (uid (passwd:uid pw))
+ (gid (passwd:gid pw)))
+ (chown #$cache uid gid))))
#t)))
(define guix-publish-service-type
@@ -2592,24 +2968,24 @@ (define (udev-configurations-union subdirectory packages)
(define build
(with-imported-modules '((guix build union)
(guix build utils))
- #~(begin
- (use-modules (guix build union)
- (guix build utils)
- (srfi srfi-1)
- (srfi srfi-26))
+ #~(begin
+ (use-modules (guix build union)
+ (guix build utils)
+ (srfi srfi-1)
+ (srfi srfi-26))
- (define %standard-locations
- '(#$(string-append "/lib/udev/" subdirectory)
- #$(string-append "/libexec/udev/" subdirectory)))
+ (define %standard-locations
+ '(#$(string-append "/lib/udev/" subdirectory)
+ #$(string-append "/libexec/udev/" subdirectory)))
- (define (configuration-sub-directory directory)
- ;; Return the sub-directory of DIRECTORY containing udev
- ;; configurations, or #f if none was found.
- (find directory-exists?
- (map (cut string-append directory <>) %standard-locations)))
+ (define (configuration-sub-directory directory)
+ ;; Return the sub-directory of DIRECTORY containing udev
+ ;; configurations, or #f if none was found.
+ (find directory-exists?
+ (map (cut string-append directory <>) %standard-locations)))
- (union-build #$output
- (filter-map configuration-sub-directory '#$packages)))))
+ (union-build #$output
+ (filter-map configuration-sub-directory '#$packages)))))
(computed-file (string-append "udev-" subdirectory) build))
@@ -2635,19 +3011,19 @@ (define (file->udev-configuration-file subdirectory file-name file)
of FILE."
(computed-file file-name
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- (define configuration-directory
- (string-append #$output
- "/lib/udev/"
- #$subdirectory))
+ (define configuration-directory
+ (string-append #$output
+ "/lib/udev/"
+ #$subdirectory))
- (define file-copy-dest
- (string-append configuration-directory "/" #$file-name))
+ (define file-copy-dest
+ (string-append configuration-directory "/" #$file-name))
- (mkdir-p configuration-directory)
- (copy-file #$file file-copy-dest)))))
+ (mkdir-p configuration-directory)
+ (copy-file #$file file-copy-dest)))))
(define (file->udev-rule file-name file)
"Return a directory with a udev rule file FILE-NAME which is a copy of FILE."
@@ -2683,65 +3059,65 @@ (define (udev-shepherd-service config)
(start
(with-imported-modules (source-module-closure
'((gnu build linux-boot)))
- #~(lambda ()
- (define udevd
- ;; 'udevd' from eudev.
- #$(file-append udev "/sbin/udevd"))
+ #~(lambda ()
+ (define udevd
+ ;; 'udevd' from eudev.
+ #$(file-append udev "/sbin/udevd"))
- (define (wait-for-udevd)
- ;; Wait until someone's listening on udevd's control
- ;; socket.
- (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
- (let try ()
- (catch 'system-error
- (lambda ()
- (connect sock PF_UNIX "/run/udev/control")
- (close-port sock))
- (lambda args
- (format #t "waiting for udevd...~%")
- (usleep 500000)
- (try))))))
+ (define (wait-for-udevd)
+ ;; Wait until someone's listening on udevd's control
+ ;; socket.
+ (let ((sock (socket AF_UNIX SOCK_SEQPACKET 0)))
+ (let try ()
+ (catch 'system-error
+ (lambda ()
+ (connect sock PF_UNIX "/run/udev/control")
+ (close-port sock))
+ (lambda args
+ (format #t "waiting for udevd...~%")
+ (usleep 500000)
+ (try))))))
- ;; Allow udev to find the modules.
- (setenv "LINUX_MODULE_DIRECTORY"
- "/run/booted-system/kernel/lib/modules")
+ ;; Allow udev to find the modules.
+ (setenv "LINUX_MODULE_DIRECTORY"
+ "/run/booted-system/kernel/lib/modules")
- (let* ((kernel-release
- (utsname:release (uname)))
- (linux-module-directory
- (getenv "LINUX_MODULE_DIRECTORY"))
- (directory
- (string-append linux-module-directory "/"
- kernel-release))
- (old-umask (umask #o022)))
- ;; If we're in a container, DIRECTORY might not exist,
- ;; for instance because the host runs a different
- ;; kernel. In that case, skip it; we'll just miss a few
- ;; nodes like /dev/fuse.
- (when (file-exists? directory)
- (make-static-device-nodes directory))
- (umask old-umask))
+ (let* ((kernel-release
+ (utsname:release (uname)))
+ (linux-module-directory
+ (getenv "LINUX_MODULE_DIRECTORY"))
+ (directory
+ (string-append linux-module-directory "/"
+ kernel-release))
+ (old-umask (umask #o022)))
+ ;; If we're in a container, DIRECTORY might not exist,
+ ;; for instance because the host runs a different
+ ;; kernel. In that case, skip it; we'll just miss a few
+ ;; nodes like /dev/fuse.
+ (when (file-exists? directory)
+ (make-static-device-nodes directory))
+ (umask old-umask))
- (let ((pid (fork+exec-command
- (list udevd)
- #:environment-variables
- (cons*
- (string-append "LINUX_MODULE_DIRECTORY="
- (getenv "LINUX_MODULE_DIRECTORY"))
- (default-environment-variables)))))
- ;; Wait until udevd is up and running. This appears to
- ;; be needed so that the events triggered below are
- ;; actually handled.
- (wait-for-udevd)
+ (let ((pid (fork+exec-command
+ (list udevd)
+ #:environment-variables
+ (cons*
+ (string-append "LINUX_MODULE_DIRECTORY="
+ (getenv "LINUX_MODULE_DIRECTORY"))
+ (default-environment-variables)))))
+ ;; Wait until udevd is up and running. This appears to
+ ;; be needed so that the events triggered below are
+ ;; actually handled.
+ (wait-for-udevd)
- ;; Trigger device node creation.
- (system* #$(file-append udev "/bin/udevadm")
- "trigger" "--action=add")
+ ;; Trigger device node creation.
+ (system* #$(file-append udev "/bin/udevadm")
+ "trigger" "--action=add")
- ;; Wait for things to settle down.
- (system* #$(file-append udev "/bin/udevadm")
- "settle")
- pid))))
+ ;; Wait for things to settle down.
+ (system* #$(file-append udev "/bin/udevadm")
+ "settle")
+ pid))))
(stop #~(make-kill-destructor))
;; When halting the system, 'udev' is actually killed by
@@ -2760,27 +3136,27 @@ (define udev.conf
(define (udev-etc config)
(match-record config <udev-configuration>
- (udev rules hardware)
- (let* ((hardware
- (udev-configurations-union "hwdb.d" (cons* udev hardware)))
- (hwdb.bin
- (computed-file
- "hwdb.bin"
- (with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
- (setenv "UDEV_HWDB_PATH" #$hardware)
- (invoke #+(file-append udev "/bin/udevadm")
- "hwdb"
- "--update"
- "-o" #$output))))))
- `(("udev"
- ,(file-union "udev"
- `(("udev.conf" ,udev.conf)
- ("rules.d"
- ,(udev-rules-union (cons* udev kvm-udev-rule
- rules)))
- ("hwdb.bin" ,hwdb.bin))))))))
+ (udev rules hardware)
+ (let* ((hardware
+ (udev-configurations-union "hwdb.d" (cons* udev hardware)))
+ (hwdb.bin
+ (computed-file
+ "hwdb.bin"
+ (with-imported-modules '((guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
+ (setenv "UDEV_HWDB_PATH" #$hardware)
+ (invoke #+(file-append udev "/bin/udevadm")
+ "hwdb"
+ "--update"
+ "-o" #$output))))))
+ `(("udev"
+ ,(file-union "udev"
+ `(("udev.conf" ,udev.conf)
+ ("rules.d"
+ ,(udev-rules-union (cons* udev kvm-udev-rule
+ rules)))
+ ("hwdb.bin" ,hwdb.bin))))))))
(define udev-service-type
(service-type (name 'udev)
@@ -2856,7 +3232,7 @@ (define (swap-space->shepherd-service-name space)
(else
target))))))
-; TODO Remove after deprecation
+ ; TODO Remove after deprecation
(define (swap-deprecated->shepherd-service-name sdep)
(symbol-append 'swap-
(string->symbol
@@ -2881,7 +3257,7 @@ (define swap-service-type
(cond ((swap-space? swap)
(map dependency->shepherd-service-name
(swap-space-dependencies swap)))
- ; TODO Remove after deprecation
+ ; TODO Remove after deprecation
((and (string? swap) (string-prefix? "/dev/mapper/" swap))
(list (symbol-append 'device-mapping-
(string->symbol (basename swap)))))
@@ -2900,7 +3276,7 @@ (define swap-service-type
#$(file-system-label->string target)))
(else
target))))
- ; TODO Remove after deprecation
+ ; TODO Remove after deprecation
((uuid? swap)
#~(find-partition-by-uuid #$(uuid-bytevector swap)))
((file-system-label? swap)
@@ -2910,33 +3286,33 @@ (define swap-service-type
swap)))
(with-imported-modules (source-module-closure '((gnu build file-systems)))
- (shepherd-service
- (provision (list (swap->shepherd-service-name swap)))
- (requirement `(,@(if (target-hurd?) '() '(udev)) ,@requirements))
- (documentation "Enable the given swap space.")
- (modules `((gnu build file-systems)
- ,@%default-modules))
- (start #~(lambda ()
- (let ((device #$device-lookup))
- (and device
- (begin
- #$(if (target-hurd?)
- #~(system* "swapon" device)
- #~(restart-on-EINTR
- (swapon device
- #$(if (swap-space? swap)
- (swap-space->flags-bit-mask
- swap)
- 0))))
- #t)))))
- (stop #~(lambda _
- (let ((device #$device-lookup))
- (when device
- #$(if (target-hurd?)
- #~(system* "swapoff" device)
- #~(restart-on-EINTR (swapoff device))))
- #f)))
- (respawn? #f))))
+ (shepherd-service
+ (provision (list (swap->shepherd-service-name swap)))
+ (requirement `(,@(if (target-hurd?) '() '(udev)) ,@requirements))
+ (documentation "Enable the given swap space.")
+ (modules `((gnu build file-systems)
+ ,@%default-modules))
+ (start #~(lambda ()
+ (let ((device #$device-lookup))
+ (and device
+ (begin
+ #$(if (target-hurd?)
+ #~(system* "swapon" device)
+ #~(restart-on-EINTR
+ (swapon device
+ #$(if (swap-space? swap)
+ (swap-space->flags-bit-mask
+ swap)
+ 0))))
+ #t)))))
+ (stop #~(lambda _
+ (let ((device #$device-lookup))
+ (when device
+ #$(if (target-hurd?)
+ #~(system* "swapoff" device)
+ #~(restart-on-EINTR (swapoff device))))
+ #f)))
+ (respawn? #f))))
(description "Turn on the virtual memory swap area.")))
(define (swap-service swap)
@@ -2956,21 +3332,21 @@ (define-record-type* <gpm-configuration>
(define (gpm-shepherd-service config)
(match-record config <gpm-configuration>
- (gpm options)
- (list (shepherd-service
- (requirement '(user-processes udev))
- (provision '(gpm))
- ;; 'gpm' runs in the background and sets a PID file.
- ;; Note that it requires running as "root".
- (start #~(make-forkexec-constructor
- (list #$(file-append gpm "/sbin/gpm")
- #$@options)
- #:pid-file "/var/run/gpm.pid"
- #:pid-file-timeout 3))
- (stop #~(lambda (_)
- ;; Return #f if successfully stopped.
- (not (zero? (system* #$(file-append gpm "/sbin/gpm")
- "-k")))))))))
+ (gpm options)
+ (list (shepherd-service
+ (requirement '(user-processes udev))
+ (provision '(gpm))
+ ;; 'gpm' runs in the background and sets a PID file.
+ ;; Note that it requires running as "root".
+ (start #~(make-forkexec-constructor
+ (list #$(file-append gpm "/sbin/gpm")
+ #$@options)
+ #:pid-file "/var/run/gpm.pid"
+ #:pid-file-timeout 3))
+ (stop #~(lambda (_)
+ ;; Return #f if successfully stopped.
+ (not (zero? (system* #$(file-append gpm "/sbin/gpm")
+ "-k")))))))))
(define gpm-service-type
(service-type (name 'gpm)
@@ -3235,38 +3611,38 @@ (define (network-set-up/hurd config)
(program-file "set-up-pflocal" #~(begin 'nothing-to-do! #t))
(program-file "set-up-pfinet"
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils)
- (ice-9 format))
+ #~(begin
+ (use-modules (guix build utils)
+ (ice-9 format))
- ;; TODO: Do that without forking.
- (let ((options '#$(static-networking->hurd-pfinet-options
- config)))
- (format #t "starting '~a~{ ~s~}'~%"
- #$(file-append hurd "/hurd/pfinet")
- options)
- (apply invoke #$(file-append hurd "/bin/settrans")
- "--active"
- "--create"
- "--keep-active"
- "/servers/socket/2"
- #$(file-append hurd "/hurd/pfinet")
- options)))))))
+ ;; TODO: Do that without forking.
+ (let ((options '#$(static-networking->hurd-pfinet-options
+ config)))
+ (format #t "starting '~a~{ ~s~}'~%"
+ #$(file-append hurd "/hurd/pfinet")
+ options)
+ (apply invoke #$(file-append hurd "/bin/settrans")
+ "--active"
+ "--create"
+ "--keep-active"
+ "/servers/socket/2"
+ #$(file-append hurd "/hurd/pfinet")
+ options)))))))
(define (network-tear-down/hurd config)
(program-file "tear-down-pfinet"
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- ;; Forcefully terminate pfinet. XXX: In theory this
- ;; should just undo the addresses and routes of CONFIG;
- ;; this could be done using ioctls like SIOCDELRT, but
- ;; these are IPv4-only; another option would be to use
- ;; fsysopts but that seems to crash pfinet.
- (invoke #$(file-append hurd "/bin/settrans") "-fg"
- "/servers/socket/2")
- #f))))
+ ;; Forcefully terminate pfinet. XXX: In theory this
+ ;; should just undo the addresses and routes of CONFIG;
+ ;; this could be done using ioctls like SIOCDELRT, but
+ ;; these are IPv4-only; another option would be to use
+ ;; fsysopts but that seems to crash pfinet.
+ (invoke #$(file-append hurd "/bin/settrans") "-fg"
+ "/servers/socket/2")
+ #f))))
(define (network-set-up/linux config)
(define max-set-up-duration
@@ -3274,199 +3650,199 @@ (define (network-set-up/linux config)
60)
(match-record config <static-networking>
- (addresses links routes)
- (program-file "set-up-network"
- (with-extensions (list guile-netlink)
- #~(begin
- (use-modules (ip addr) (ip link) (ip route)
- (srfi srfi-1)
- (ice-9 format)
- (ice-9 match))
+ (addresses links routes)
+ (program-file "set-up-network"
+ (with-extensions (list guile-netlink)
+ #~(begin
+ (use-modules (ip addr) (ip link) (ip route)
+ (srfi srfi-1)
+ (ice-9 format)
+ (ice-9 match))
- (define (match-link-by field-accessor value)
- (fold (lambda (link result)
- (if (equal? (field-accessor link) value)
- link
- result))
- #f
- (get-links)))
+ (define (match-link-by field-accessor value)
+ (fold (lambda (link result)
+ (if (equal? (field-accessor link) value)
+ link
+ result))
+ #f
+ (get-links)))
- (define (alist->keyword+value alist)
- (fold (match-lambda*
- (((k . v) r)
- (cons* (symbol->keyword k) v r))) '() alist))
+ (define (alist->keyword+value alist)
+ (fold (match-lambda*
+ (((k . v) r)
+ (cons* (symbol->keyword k) v r))) '() alist))
- ;; FIXME: It is interesting that "modprobe bonding" creates an
- ;; interface bond0 straigt away. If we won't have bonding
- ;; module, and execute `ip link add name bond0 type bond' we
- ;; will get
- ;;
- ;; RTNETLINK answers: File exists
- ;;
- ;; This breaks our configuration if we want to
- ;; use `bond0' name. Create (force modprobe
- ;; bonding) and delete the interface to free up
- ;; bond0 name.
- #$(let lp ((links links))
- (cond
- ((null? links) #f)
- ((and (network-link? (car links))
- ;; Type is not mandatory
- (false-if-exception
- (eq? (network-link-type (car links)) 'bond)))
- #~(begin
- (false-if-exception (link-add "bond0" "bond"))
- (link-del "bond0")))
- (else (lp (cdr links)))))
+ ;; FIXME: It is interesting that "modprobe bonding" creates an
+ ;; interface bond0 straigt away. If we won't have bonding
+ ;; module, and execute `ip link add name bond0 type bond' we
+ ;; will get
+ ;;
+ ;; RTNETLINK answers: File exists
+ ;;
+ ;; This breaks our configuration if we want to
+ ;; use `bond0' name. Create (force modprobe
+ ;; bonding) and delete the interface to free up
+ ;; bond0 name.
+ #$(let lp ((links links))
+ (cond
+ ((null? links) #f)
+ ((and (network-link? (car links))
+ ;; Type is not mandatory
+ (false-if-exception
+ (eq? (network-link-type (car links)) 'bond)))
+ #~(begin
+ (false-if-exception (link-add "bond0" "bond"))
+ (link-del "bond0")))
+ (else (lp (cdr links)))))
- #$@(map (match-lambda
- (($ <network-link> name type mac-address arguments)
- (cond
- ;; Create a new interface
- ((and (string? name) (symbol? type))
- #~(begin
- (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
- ;; XXX: If we add routes, addresses must be
- ;; already assigned, and interfaces must be
- ;; up. It doesn't matter if they won't have
- ;; carrier or anything.
- (link-set #$name #:up #t)))
+ #$@(map (match-lambda
+ (($ <network-link> name type mac-address arguments)
+ (cond
+ ;; Create a new interface
+ ((and (string? name) (symbol? type))
+ #~(begin
+ (link-add #$name (symbol->string '#$type) #:type-args '#$arguments)
+ ;; XXX: If we add routes, addresses must be
+ ;; already assigned, and interfaces must be
+ ;; up. It doesn't matter if they won't have
+ ;; carrier or anything.
+ (link-set #$name #:up #t)))
- ;; Amend an existing interface
- ((and (string? name)
- (eq? type #f))
- #~(let ((link (match-link-by link-name #$name)))
- (if link
- (apply link-set
- (link-id link)
- (alist->keyword+value '#$arguments))
- (format #t (G_ "Interface with name '~a' not found~%") #$name))))
- ((string? mac-address)
- #~(let ((link (match-link-by link-addr #$mac-address)))
- (if link
- (apply link-set
- (link-id link)
- (alist->keyword+value '#$arguments))
- (format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
- links)
+ ;; Amend an existing interface
+ ((and (string? name)
+ (eq? type #f))
+ #~(let ((link (match-link-by link-name #$name)))
+ (if link
+ (apply link-set
+ (link-id link)
+ (alist->keyword+value '#$arguments))
+ (format #t (G_ "Interface with name '~a' not found~%") #$name))))
+ ((string? mac-address)
+ #~(let ((link (match-link-by link-addr #$mac-address)))
+ (if link
+ (apply link-set
+ (link-id link)
+ (alist->keyword+value '#$arguments))
+ (format #t (G_ "Interface with mac-address '~a' not found~%") #$mac-address)))))))
+ links)
- ;; 'wait-for-link' below could wait forever when
- ;; passed a non-existent device. To ensure timely
- ;; completion, install an alarm.
- (alarm #$max-set-up-duration)
+ ;; 'wait-for-link' below could wait forever when
+ ;; passed a non-existent device. To ensure timely
+ ;; completion, install an alarm.
+ (alarm #$max-set-up-duration)
- #$@(map (lambda (address)
- #~(let ((device
- #$(network-address-device address)))
- ;; Before going any further, wait for the
- ;; device to show up.
- (format #t "Waiting for network device '~a'...~%"
- device)
- (wait-for-link device)
+ #$@(map (lambda (address)
+ #~(let ((device
+ #$(network-address-device address)))
+ ;; Before going any further, wait for the
+ ;; device to show up.
+ (format #t "Waiting for network device '~a'...~%"
+ device)
+ (wait-for-link device)
- (addr-add #$(network-address-device address)
- #$(network-address-value address)
- #:ipv6?
- #$(network-address-ipv6? address))
- ;; FIXME: loopback?
- (link-set #$(network-address-device address)
- #:multicast-on #t
- #:up #t)))
- addresses)
+ (addr-add #$(network-address-device address)
+ #$(network-address-value address)
+ #:ipv6?
+ #$(network-address-ipv6? address))
+ ;; FIXME: loopback?
+ (link-set #$(network-address-device address)
+ #:multicast-on #t
+ #:up #t)))
+ addresses)
- #$@(map (lambda (route)
- #~(route-add #$(network-route-destination route)
- #:device
- #$(network-route-device route)
- #:ipv6?
- #$(network-route-ipv6? route)
- #:via
- #$(network-route-gateway route)
- #:src
- #$(network-route-source route)))
- routes)
- #t)))))
+ #$@(map (lambda (route)
+ #~(route-add #$(network-route-destination route)
+ #:device
+ #$(network-route-device route)
+ #:ipv6?
+ #$(network-route-ipv6? route)
+ #:via
+ #$(network-route-gateway route)
+ #:src
+ #$(network-route-source route)))
+ routes)
+ #t)))))
(define (network-tear-down/linux config)
(match-record config <static-networking>
- (addresses links routes)
- (program-file "tear-down-network"
- (with-extensions (list guile-netlink)
- #~(begin
- (use-modules (ip addr) (ip link) (ip route)
- (netlink error)
- (srfi srfi-34))
+ (addresses links routes)
+ (program-file "tear-down-network"
+ (with-extensions (list guile-netlink)
+ #~(begin
+ (use-modules (ip addr) (ip link) (ip route)
+ (netlink error)
+ (srfi srfi-34))
- (define-syntax-rule (false-if-netlink-error exp)
- (guard (c ((netlink-error? c) #f))
- exp))
+ (define-syntax-rule (false-if-netlink-error exp)
+ (guard (c ((netlink-error? c) #f))
+ exp))
- ;; Wrap calls in 'false-if-netlink-error' so this
- ;; script goes as far as possible undoing the effects
- ;; of "set-up-network".
+ ;; Wrap calls in 'false-if-netlink-error' so this
+ ;; script goes as far as possible undoing the effects
+ ;; of "set-up-network".
- #$@(map (lambda (route)
- #~(false-if-netlink-error
- (route-del #$(network-route-destination route)
- #:device
- #$(network-route-device route)
- #:ipv6?
- #$(network-route-ipv6? route)
- #:via
- #$(network-route-gateway route)
- #:src
- #$(network-route-source route))))
- routes)
+ #$@(map (lambda (route)
+ #~(false-if-netlink-error
+ (route-del #$(network-route-destination route)
+ #:device
+ #$(network-route-device route)
+ #:ipv6?
+ #$(network-route-ipv6? route)
+ #:via
+ #$(network-route-gateway route)
+ #:src
+ #$(network-route-source route))))
+ routes)
- ;; Cleanup addresses first, they might be assigned to
- ;; created bonds, vlans or bridges.
- #$@(map (lambda (address)
- #~(false-if-netlink-error
- (addr-del #$(network-address-device
- address)
- #$(network-address-value address)
- #:ipv6?
- #$(network-address-ipv6? address))))
- addresses)
+ ;; Cleanup addresses first, they might be assigned to
+ ;; created bonds, vlans or bridges.
+ #$@(map (lambda (address)
+ #~(false-if-netlink-error
+ (addr-del #$(network-address-device
+ address)
+ #$(network-address-value address)
+ #:ipv6?
+ #$(network-address-ipv6? address))))
+ addresses)
- ;; It is now safe to delete some links
- #$@(map (match-lambda
- (($ <network-link> name type mac-address arguments)
- (cond
- ;; We delete interfaces that were created
- ((and (string? name) (symbol? type))
- #~(false-if-netlink-error
- (link-del #$name)))
- (else #t))))
- links)
- #f)))))
+ ;; It is now safe to delete some links
+ #$@(map (match-lambda
+ (($ <network-link> name type mac-address arguments)
+ (cond
+ ;; We delete interfaces that were created
+ ((and (string? name) (symbol? type))
+ #~(false-if-netlink-error
+ (link-del #$name)))
+ (else #t))))
+ links)
+ #f)))))
(define (static-networking-shepherd-service config)
(match-record config <static-networking>
- (addresses links routes provision requirement name-servers)
- (let ((loopback? (and provision (memq 'loopback provision))))
- (shepherd-service
+ (addresses links routes provision requirement name-servers)
+ (let ((loopback? (and provision (memq 'loopback provision))))
+ (shepherd-service
- (documentation
- "Bring up the networking interface using a static IP address.")
- (requirement requirement)
- (provision provision)
+ (documentation
+ "Bring up the networking interface using a static IP address.")
+ (requirement requirement)
+ (provision provision)
- (start #~(lambda _
- ;; Return #t if successfully started.
- (zero? (system*
- #$(let-system (system target)
- (if (string-contains (or target system) "-linux")
- (network-set-up/linux config)
- (network-set-up/hurd config)))))))
- (stop #~(lambda _
- ;; Return #f is successfully stopped.
- (zero? (system*
- #$(let-system (system target)
- (if (string-contains (or target system) "-linux")
- (network-tear-down/linux config)
- (network-tear-down/hurd config)))))))
- (respawn? #f)))))
+ (start #~(lambda _
+ ;; Return #t if successfully started.
+ (zero? (system*
+ #$(let-system (system target)
+ (if (string-contains (or target system) "-linux")
+ (network-set-up/linux config)
+ (network-set-up/hurd config)))))))
+ (stop #~(lambda _
+ ;; Return #f is successfully stopped.
+ (zero? (system*
+ #$(let-system (system target)
+ (if (string-contains (or target system) "-linux")
+ (network-tear-down/linux config)
+ (network-tear-down/hurd config)))))))
+ (respawn? #f)))))
(define (static-networking-shepherd-services networks)
(map static-networking-shepherd-service networks))
@@ -3700,35 +4076,35 @@ (define (make-greetd-sway-greeter-command sway sway-config)
(program-file
"greeter-sway-command"
(with-imported-modules '((guix build utils))
- #~(begin
- (use-modules (guix build utils))
+ #~(begin
+ (use-modules (guix build utils))
- (let* ((username (getenv "USER"))
- (user (getpwnam username))
- (useruid (passwd:uid user))
- (usergid (passwd:gid user))
- (useruid-s (number->string useruid))
- ;; /run/user/<greeter-user-uid> won't exist yet
- ;; this will contain WAYLAND_DISPLAY socket file
- ;; and log-file below
- (user-home-dir "/tmp/.greeter-home")
- (user-xdg-runtime-dir (string-append user-home-dir "/run"))
- (user-xdg-cache-dir (string-append user-home-dir "/cache"))
- (log-file (string-append (number->string (getpid)) ".log"))
- (log-file (string-append user-home-dir "/" log-file)))
- (for-each (lambda (d)
- (mkdir-p d)
- (chown d useruid usergid) (chmod d #o700))
- (list user-home-dir
- user-xdg-runtime-dir
- user-xdg-cache-dir))
- (setenv "HOME" user-home-dir)
- (setenv "XDG_CACHE_DIR" user-xdg-cache-dir)
- (setenv "XDG_RUNTIME_DIR" user-xdg-runtime-dir)
- (dup2 (open-fdes log-file
- (logior O_CREAT O_WRONLY O_APPEND) #o640) 1)
- (dup2 1 2)
- (execl #$sway-bin #$sway-bin "-d" "-c" #$sway-config)))))))
+ (let* ((username (getenv "USER"))
+ (user (getpwnam username))
+ (useruid (passwd:uid user))
+ (usergid (passwd:gid user))
+ (useruid-s (number->string useruid))
+ ;; /run/user/<greeter-user-uid> won't exist yet
+ ;; this will contain WAYLAND_DISPLAY socket file
+ ;; and log-file below
+ (user-home-dir "/tmp/.greeter-home")
+ (user-xdg-runtime-dir (string-append user-home-dir "/run"))
+ (user-xdg-cache-dir (string-append user-home-dir "/cache"))
+ (log-file (string-append (number->string (getpid)) ".log"))
+ (log-file (string-append user-home-dir "/" log-file)))
+ (for-each (lambda (d)
+ (mkdir-p d)
+ (chown d useruid usergid) (chmod d #o700))
+ (list user-home-dir
+ user-xdg-runtime-dir
+ user-xdg-cache-dir))
+ (setenv "HOME" user-home-dir)
+ (setenv "XDG_CACHE_DIR" user-xdg-cache-dir)
+ (setenv "XDG_RUNTIME_DIR" user-xdg-runtime-dir)
+ (dup2 (open-fdes log-file
+ (logior O_CREAT O_WRONLY O_APPEND) #o640) 1)
+ (dup2 1 2)
+ (execl #$sway-bin #$sway-bin "-d" "-c" #$sway-config)))))))
(define-record-type* <greetd-wlgreet-configuration>
greetd-wlgreet-configuration make-greetd-wlgreet-configuration
@@ -3795,21 +4171,21 @@ (define (make-greetd-wlgreet-config-color section-name color)
(define (make-greetd-wlgreet-config command color)
(match-record color <greetd-wlgreet-configuration>
- (output-mode scale background headline prompt prompt-error border)
- (mixed-text-file
- "wlgreet.toml"
- "command = \"" command "\"\n"
- "outputMode = \"" output-mode "\"\n"
- "scale = " (number->string scale) "\n"
- (apply string-append
- (map (match-lambda
- ((section-name . color)
- (make-greetd-wlgreet-config-color section-name color)))
- `(("background" . ,background)
- ("headline" . ,headline)
- ("prompt" . ,prompt)
- ("prompt-error" . ,prompt-error)
- ("border" . ,border)))))))
+ (output-mode scale background headline prompt prompt-error border)
+ (mixed-text-file
+ "wlgreet.toml"
+ "command = \"" command "\"\n"
+ "outputMode = \"" output-mode "\"\n"
+ "scale = " (number->string scale) "\n"
+ (apply string-append
+ (map (match-lambda
+ ((section-name . color)
+ (make-greetd-wlgreet-config-color section-name color)))
+ `(("background" . ,background)
+ ("headline" . ,headline)
+ ("prompt" . ,prompt)
+ ("prompt-error" . ,prompt-error)
+ ("border" . ,border)))))))
(define-record-type* <greetd-wlgreet-sway-session>
greetd-wlgreet-sway-session make-greetd-wlgreet-sway-session
@@ -3836,18 +4212,18 @@ (define (warn-deprecated-greetd-wlgreet-sway-session-wlgreet-session value)
(define (make-greetd-wlgreet-sway-session-sway-config session)
(match-record session <greetd-wlgreet-sway-session>
(sway sway-configuration wlgreet wlgreet-configuration command)
- (let ((wlgreet-bin (file-append wlgreet "/bin/wlgreet"))
- (wlgreet-config-file
- (make-greetd-wlgreet-config command wlgreet-configuration))
- (swaymsg-bin (file-append sway "/bin/swaymsg")))
- (mixed-text-file
- "wlgreet-sway-config"
- (if sway-configuration
- #~(string-append "include " #$sway-configuration "\n")
- "")
- "xwayland disable\n"
- "exec \"" wlgreet-bin " --config " wlgreet-config-file
- "; " swaymsg-bin " exit\"\n"))))
+ (let ((wlgreet-bin (file-append wlgreet "/bin/wlgreet"))
+ (wlgreet-config-file
+ (make-greetd-wlgreet-config command wlgreet-configuration))
+ (swaymsg-bin (file-append sway "/bin/swaymsg")))
+ (mixed-text-file
+ "wlgreet-sway-config"
+ (if sway-configuration
+ #~(string-append "include " #$sway-configuration "\n")
+ "")
+ "xwayland disable\n"
+ "exec \"" wlgreet-bin " --config " wlgreet-config-file
+ "; " swaymsg-bin " exit\"\n"))))
(define (greetd-wlgreet-session-to-config session config)
(let* ((wlgreet (or (greetd-wlgreet config)
@@ -3880,10 +4256,10 @@ (define-gexp-compiler (greetd-wlgreet-sway-session-compiler
session
(greetd-wlgreet-sway-session-wlgreet-session session)))))
(match-record s <greetd-wlgreet-sway-session> (sway)
- (lower-object
- (make-greetd-sway-greeter-command
- sway
- (make-greetd-wlgreet-sway-session-sway-config s))))))
+ (lower-object
+ (make-greetd-sway-greeter-command
+ sway
+ (make-greetd-wlgreet-sway-session-sway-config s))))))
(define-record-type* <greetd-gtkgreet-sway-session>
greetd-gtkgreet-sway-session make-greetd-gtkgreet-sway-session
@@ -3899,26 +4275,26 @@ (define-record-type* <greetd-gtkgreet-sway-session>
(define (make-greetd-gtkgreet-sway-session-sway-config session)
(match-record session <greetd-gtkgreet-sway-session>
(sway sway-configuration gtkgreet gtkgreet-style command)
- (let ((gtkgreet-bin (file-append gtkgreet "/bin/gtkgreet"))
- (swaymsg-bin (file-append sway "/bin/swaymsg")))
- (mixed-text-file
- "gtkgreet-sway-config"
- (if sway-configuration
- #~(string-append "include " #$sway-configuration "\n")
- "")
- "xwayland disable\n"
- "exec \"" gtkgreet-bin " -l"
- (if gtkgreet-style #~(string-append " -s " #$gtkgreet-style) "")
- " -c " command "; " swaymsg-bin " exit\"\n"))))
+ (let ((gtkgreet-bin (file-append gtkgreet "/bin/gtkgreet"))
+ (swaymsg-bin (file-append sway "/bin/swaymsg")))
+ (mixed-text-file
+ "gtkgreet-sway-config"
+ (if sway-configuration
+ #~(string-append "include " #$sway-configuration "\n")
+ "")
+ "xwayland disable\n"
+ "exec \"" gtkgreet-bin " -l"
+ (if gtkgreet-style #~(string-append " -s " #$gtkgreet-style) "")
+ " -c " command "; " swaymsg-bin " exit\"\n"))))
(define-gexp-compiler (greetd-gtkgreet-sway-session-compiler
(session <greetd-gtkgreet-sway-session>)
system target)
(match-record session <greetd-gtkgreet-sway-session> (sway)
- (lower-object
- (make-greetd-sway-greeter-command
- sway
- (make-greetd-gtkgreet-sway-session-sway-config session)))))
+ (lower-object
+ (make-greetd-sway-greeter-command
+ sway
+ (make-greetd-gtkgreet-sway-session-sway-config session)))))
(define-record-type* <greetd-terminal-configuration>
greetd-terminal-configuration make-greetd-terminal-configuration
@@ -3963,13 +4339,13 @@ (define (make-greetd-terminal-configuration-file config)
(define %greetd-file-systems
(list (file-system
- (device "none")
- (mount-point "/run/greetd/pam_mount")
- (type "tmpfs")
- (check? #f)
- (flags '(no-suid no-dev no-exec))
- (options "mode=0755")
- (create-mount-point? #t))))
+ (device "none")
+ (mount-point "/run/greetd/pam_mount")
+ (type "tmpfs")
+ (check? #f)
+ (flags '(no-suid no-dev no-exec))
+ (options "mode=0755")
+ (create-mount-point? #t))))
(define %greetd-pam-mount-rules
`((debug (@ (enable "0")))
@@ -4107,23 +4483,23 @@ (define %base-services
(service shepherd-system-log-service-type)
(service agetty-service-type (agetty-configuration
- (extra-options '("-L")) ; no carrier detect
- (term "vt100")
- (tty #f) ; automatic
- (shepherd-requirement '(syslogd))))
+ (extra-options '("-L")) ; no carrier detect
+ (term "vt100")
+ (tty #f) ; automatic
+ (shepherd-requirement '(syslogd))))
(service mingetty-service-type (mingetty-configuration
- (tty "tty1")))
+ (tty "tty1")))
(service mingetty-service-type (mingetty-configuration
- (tty "tty2")))
+ (tty "tty2")))
(service mingetty-service-type (mingetty-configuration
- (tty "tty3")))
+ (tty "tty3")))
(service mingetty-service-type (mingetty-configuration
- (tty "tty4")))
+ (tty "tty4")))
(service mingetty-service-type (mingetty-configuration
- (tty "tty5")))
+ (tty "tty5")))
(service mingetty-service-type (mingetty-configuration
- (tty "tty6")))
+ (tty "tty6")))
(service static-networking-service-type
(list %loopback-static-networking))
@@ -4147,7 +4523,7 @@ (define %base-services
;; less critical, but handy.
(service udev-service-type
(udev-configuration
- (rules (list lvm2 fuse alsa-utils crda))))
+ (rules (list lvm2 fuse alsa-utils crda))))
(service sysctl-service-type)