Package: guix-patches;
Reported by: Danny Milosavljevic <dannym <at> friendly-machines.com>
Date: Thu, 24 Apr 2025 23:04:02 UTC
Severity: normal
To reply to this bug, email your comments to 78051 AT debbugs.gnu.org.
Toggle the display of automated, internal messages from the tracker.
View this report as an mbox folder, status mbox, maintainer mbox
guix-patches <at> gnu.org:bug#78051; Package guix-patches.
(Thu, 24 Apr 2025 23:04:02 GMT) Full text and rfc822 format available.Danny Milosavljevic <dannym <at> friendly-machines.com>:guix-patches <at> gnu.org.
(Thu, 24 Apr 2025 23:04:02 GMT) Full text and rfc822 format available.Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> friendly-machines.com> To: guix-patches <at> gnu.org Cc: Danny Milosavljevic <dannym <at> friendly-machines.com> Subject: [WIP] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Date: Fri, 25 Apr 2025 01:03:17 +0200
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, find and kill processes that are writing to our filesystems, and then
umount the filesystems.
Change-Id: If244a1594281057ee5b6163e23bcf11fab3968ff
---
gnu/services/base.scm | 381 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 367 insertions(+), 14 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 8c6563c99d..de24d07b4e 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -348,10 +348,337 @@ (define %root-file-system-shepherd-service
(provision '(root-file-system))
(start #~(const #t))
(stop #~(lambda _
- ;; Return #f if successfully stopped.
+ ;;; Return #f if successfully stopped.
+
+ ;;; Beginning of inlined module (fuser)
+
+ (use-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
+
+ (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
+ (format (current-error-port) "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
+ (format (current-error-port) "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 (format #f "~a/~a/fd/~a" PROC-DIR-NAME pid fd))
+ (link-stat (safe-lstat fd-path)))
+ (and link-stat (eqv? (stat:dev link-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
+ (format (current-error-port)
+ "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)
+ (format (current-error-port) "Cycle detected~%"))
+ (let ((accumulator (cons root-mount-point accumulator)))
+ (if (= lives 0)
+ (begin
+ (format (current-error-port) "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
+ (format (current-error-port) "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)"
+ (format (current-error-port) "~%Process Found: PID ~a Command: ~s~%" pid command)
+ (format (current-error-port) "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))))
+
+ (define (clean-up . args)
+ (let* ((error-port (current-error-port))
+ (root-device (safe-get-device MOUNT-POINT))
+ (mounts (safe-find-nested-mounts MOUNT-POINT root-device))
+ (mount-devices (map safe-get-device mounts)))
+ (format error-port "Searching for processes writing to files on devices ~s (mount points ~s)...~%"
+ mount-devices 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)))
+ (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 SIGKILL)
+ (format error-port "Skipping PID ~a (~s).~%" pid command))))
+ pids))
+ (format error-port "~%Process scan complete.~%")
+ (format error-port "Searching for nested mounts of ~s...~%" MOUNT-POINT)
+ (if (null? mounts)
+ (format error-port "No nested mount points found.~%")
+ (begin
+ (format error-port "Found nested mount points that would need unmounting:~%")
+ (for-each (lambda (mp)
+ (format #t " ~s~%" mp)
+ (safe-umount mp))
+ mounts)))))
+
+ (define (call-with-mounted-filesystem source mountpoint filesystem-type options proc)
+ (mount source mountpoint file-system-type options #:update-mtab? #f)
+ (catch #t
+ (lambda ()
+ (proc)
+ (umount mountpoint))
+ (lambda args
+ (umount mountpoint))))
+
(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 proc
+ (lambda args
+ (set-current-input-port null)
+ (set-current-output-port null)
+ (set-current-error-port null)
+ (close port))))))
+ (with-mounted-filesystem (syntax-rules ()
+ ((with-mounted-filesystem source filesystem-type mountpoint options . exps)
+ (call-with-mounted-filesystem source filesystem-type mountpoint options
+ (lambda () . exps))))))
+
;; Redirect the default output ports.
(set-current-output-port null)
(set-current-error-port null)
@@ -363,21 +690,47 @@ (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))
+ (when (zero? n)
+ ;; TODO: pivot-root to /run/booted-system/initrd first--so we don't try to kill ourselves.
+ ;; But that's on /gnu/store--which we don't have anymore.
+ ;; Instead, we'll just exempt outselves (see "our-pid")--and possibly miss things.
+ (with-mounted-filesystem "none" "proc" "/proc" 0
+ (with-mounted-filesystem "none" "devtmpfs" "/dev" 0
+ (catch 'system-error
(lambda ()
- (mount #f "/" #f
- (logior MS_REMOUNT MS_RDONLY)
- #:update-mtab? #f)
- #t)
+ (mknod "/dev/tty" 'char-special #o600 (+ (* 5 256) 0)))
(const #f))
- (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)))))
+ (call-with-io-file "/dev/tty"
+ (lambda ()
+ ;; we don't have chvt :(
+ ;; (it would need to use %ioctl fd VT_ACTIVATE int on /dev/tty)
+ ;(chvt 12)
+ (clean-up)))))
+ ;; Should have been unmounted already--but we are paranoid
+ ;; (and probably 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)))))
- #f)))
- (respawn? #f)))
+ #f)))
+ (respawn? #f)))
(define root-file-system-service-type
(shepherd-service-type 'root-file-system
base-commit: 85b5c2c8f66aed05730f6c7bdeabfaadf619bb8f
prerequisite-patch-id: 1a4781dff5873451484bba21bc0dc4617075cb55
prerequisite-patch-id: bbe7274727aa8e1bf4beee1acafbd0a3fdc9257a
--
2.49.0
guix-patches <at> gnu.org:bug#78051; Package guix-patches.
(Fri, 25 Apr 2025 18:07:02 GMT) Full text and rfc822 format available.Message #8 received at 78051 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> friendly-machines.com> To: 78051 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> friendly-machines.com> Subject: [WIP v2] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Date: Fri, 25 Apr 2025 19:58:40 +0200
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, find and kill processes that are writing to our filesystems, and then
umount the filesystems.
Change-Id: I358eb6d131e74018be939075ebf226a2d5457bfb
---
gnu/services/base.scm | 2844 +++++++++++++++++++++++------------------
1 file changed, 1610 insertions(+), 1234 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 8c6563c99d..23b9181b51 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -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)
base-commit: 55d9b6ff118e777d3e56e5544e51d1c998619727
--
2.49.0
guix-patches <at> gnu.org:bug#78051; Package guix-patches.
(Fri, 25 Apr 2025 18:10:03 GMT) Full text and rfc822 format available.Message #11 received at 78051 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> friendly-machines.com> To: 78051 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> friendly-machines.com> Subject: [WIP v3] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Date: Fri, 25 Apr 2025 20:09:11 +0200
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, find and kill processes that are writing to our filesystems, and then
umount the filesystems.
Change-Id: I358eb6d131e74018be939075ebf226a2d5457bfb
---
gnu/services/base.scm | 2844 +++++++++++++++++++++++------------------
1 file changed, 1610 insertions(+), 1234 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 8c6563c99d..23b9181b51 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -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)))
guix-patches <at> gnu.org:bug#78051; Package guix-patches.
(Fri, 25 Apr 2025 18:38:02 GMT) Full text and rfc822 format available.Message #14 received at 78051 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> friendly-machines.com> To: 78051 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> friendly-machines.com> Subject: [WIP v4] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Date: Fri, 25 Apr 2025 20:36:55 +0200
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, find and kill processes that are writing to our filesystems, and then
umount the filesystems.
Change-Id: I358eb6d131e74018be939075ebf226a2d5457bfb
---
gnu/services/base.scm | 2844 +++++++++++++++++++++++------------------
1 file changed, 1610 insertions(+), 1234 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 8c6563c99d..21697e2cd4 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -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 (log)
+ 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)
+ ((mount-id-str parent-id-str major-minor root mount-point rest ...)
+ ;; Attempt to parse IDs, skip line on error
+ (catch 'invalid-argument
+ (lambda ()
+ (let ((mount-id (string->number mount-id-str))
+ (parent-id (string->number parent-id-str)))
+ ;; Add successfully parsed entry to list
+ (set! entries (cons (list mount-id parent-id mount-point)
+ entries))
+ (loop))) ; Continue to next line
+ (lambda args
+ ((log)
+ "Warning: Skipping mountinfo line due to parse error: ~s (~a)~%"
+ line args)
+ (loop))))
+ (x (begin
+ ((log) "Warning: Skipping mountinfo line: %s" x)
+ (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 '(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)
+ ((log) "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)))
guix-patches <at> gnu.org:bug#78051; Package guix-patches.
(Fri, 25 Apr 2025 21:36:02 GMT) Full text and rfc822 format available.Message #17 received at 78051 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> friendly-machines.com> To: 78051 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> friendly-machines.com> Subject: [WIP v5] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Date: Fri, 25 Apr 2025 23:34:50 +0200
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, find and kill processes that are writing to our filesystems, and then
umount the filesystems.
Change-Id: I358eb6d131e74018be939075ebf226a2d5457bfb
---
gnu/services/base.scm | 2857 ++++++++++++++++++++++-----------------
guix/build/syscalls.scm | 23 +
2 files changed, 1646 insertions(+), 1234 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 8c6563c99d..1d1942a6c7 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -346,12 +346,368 @@ (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
+ ; TODO (guix build syscalls)
(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 (log)
+ 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) ; TODO: UMOUNT_NOFOLLOW ?
+ "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) ; TODO: lstat? Is that safe?
+ 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)
+ ((mount-id-str parent-id-str major-minor root mount-point rest ...)
+ ;; Attempt to parse IDs, skip line on error
+ (catch 'invalid-argument
+ (lambda ()
+ (let ((mount-id (string->number mount-id-str))
+ (parent-id (string->number parent-id-str)))
+ ;; Add successfully parsed entry to list
+ (set! entries (cons (list mount-id parent-id mount-point)
+ entries))
+ (loop)))
+ (lambda args
+ ((log)
+ "Warning: Skipping mountinfo line due to parse error: ~s (~a)~%"
+ line args)
+ (loop))))
+ (x (begin
+ ((log) "Warning: Skipping mountinfo line: %s" x)
+ (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 '(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 *root-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 flags options exp ...)
+ (call-with-mounted-filesystem source mountpoint file-system-type flags options
+ (lambda () (begin exp ...)))))))
+
+ (define (call-with-logging thunk)
+ (with-mounted-filesystem "none" "/proc" "proc" 0 #f ; TODO: MS_NODEV, MS_NOEXEC, MS_NOSUID
+ (with-mounted-filesystem "none" "/dev" "devtmpfs" 0 #f ; TODO: MS_NOEXEC, MS_NOSUID
+ (catch 'system-error
+ (lambda ()
+ (mknod "/dev/console" 'char-special #o600 (+ (* 5 256) 1)))
+ (const #f))
+ (catch 'system-error
+ (lambda ()
+ (mknod "/dev/tty12" 'char-special #o600 (+ (* 4 256) 12)))
+ (const #f))
+ (call-with-io-file "/dev/tty12"
+ (lambda ()
+ (vt-activate (fileno (current-input-file)) 12)
+ (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 *root-mount-point*))
+ (mounts (safe-find-nested-mounts *root-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 flags options proc)
+ (mount source mountpoint file-system-type flags options #:update-mtab? #f)
+ (catch #t
+ (lambda ()
+ (proc)
+ (umount mountpoint))
+ (lambda args
+ (umount mountpoint))))
+
+ ;; This will also 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 ()
+ (parameterize ((log (lambda args
+ (apply format (current-error-port) args))))
+ (let ((error-port (current-error-port)))
+ (format error-port "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 +719,51 @@ (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)
+ ((@ (fibers) sleep) 5) ; just in case
+ #t)
+ (lambda args
+ ((log) "failed to remount / ro %s %~" args)
+ (let loopity ((q 0))
+ ((log) "user, do something!~%")
+ ((@ (fibers) sleep) 1)
+ (loopity))))))
(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)))
diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index cf09cae3a4..0fe37429ac 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -201,6 +201,7 @@ (define-module (guix build syscalls)
terminal-columns
terminal-rows
terminal-string-width
+ vt-activate
openpty
login-tty
@@ -1664,6 +1665,10 @@ (define SIOCDELRT
(if (string-contains %host-type "linux")
#x890C ;GNU/Linux
-1)) ;FIXME: GNU/Hurd?
+(define VT_ACTIVATE
+ (if (string-contains %host-type "linux")
+ #x5606 ;GNU/Linux
+ -1)) ;FIXME: GNU/Hurd?
;; Flags and constants from <net/if.h>.
@@ -1820,6 +1825,10 @@ (define %ioctl
;; The most terrible interface, live from Scheme.
(syscall->procedure int "ioctl" (list int unsigned-long '*)))
+(define %ioctl-direct
+ ;; If you thought the interface above was terrible, you ain't seen nothing yet.
+ (syscall->procedure int "ioctl" (list int unsigned-long uintptr_t)))
+
(define (bytes->string bytes)
"Read BYTES, a list of bytes, and return the null-terminated string decoded
from there, or #f if that would be an empty string."
@@ -1842,6 +1851,20 @@ (define (bytevector->string-list bv stride len)
(loop (drop bytes stride)
(cons (bytes->string bytes) result))))))
+(define* (vt-activate tty terminal-number)
+ "Switch to the console given by TERMINAL-NUMBER, given a TTY file.
+If in doubt, use the file /dev/tty0 as TTY.
+/dev/tty doesn't always work (if it's a virtual terminal, it won't work)."""
+ (let-values (((ret err)
+ (%ioctl-direct (fileno tty) VT_ACTIVATE
+ terminal-number)))
+ (if (zero? ret)
+ #t
+ (throw 'system-error "vt-activate"
+ "vt-activate: ~A"
+ (list (strerror err))
+ (list err)))))
+
(define* (network-interface-names #:optional sock)
"Return the names of existing network interfaces. This is typically limited
to interfaces that are currently up."
base-commit: 0d3bc50b0cffeae05beb12d0c270c6599186c0d7
--
2.49.0
guix-patches <at> gnu.org:bug#78051; Package guix-patches.
(Sat, 26 Apr 2025 10:06:01 GMT) Full text and rfc822 format available.Message #20 received at 78051 <at> debbugs.gnu.org (full text, mbox):
From: Danny Milosavljevic <dannym <at> friendly-machines.com> To: 78051 <at> debbugs.gnu.org Cc: Danny Milosavljevic <dannym <at> friendly-machines.com> Subject: [WIP v6] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Date: Sat, 26 Apr 2025 12:05:24 +0200
* gnu/services/base.scm (%root-file-system-shepherd-service): In 'stop'
method, find and kill processes that are writing to our filesystems, and then
umount the filesystems.
Change-Id: Ib0ffff2257dca5fff3df99fea2d5de81a9612336
---
gnu/services/base.scm | 2860 +++++++++++++++++++++++------------------
1 file changed, 1627 insertions(+), 1233 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 8c6563c..22168a3 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -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,373 @@ (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
+ (ice-9 rdelim)
+ (srfi srfi-1) ; filter, for-each, find.
+ (srfi srfi-26) ; cut
+ (ice-9 exceptions))) ; guard
+ ; TODO (guix build syscalls)
(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 (log)
+ 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) ; TODO: UMOUNT_NOFOLLOW ?
+ "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) ; TODO: lstat? Is that safe?
+ 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)
+ ((mount-id-str parent-id-str major-minor root mount-point rest ...)
+ ;; Attempt to parse IDs, skip line on error
+ (catch 'invalid-argument
+ (lambda ()
+ (let ((mount-id (string->number mount-id-str))
+ (parent-id (string->number parent-id-str)))
+ ;; Add successfully parsed entry to list
+ (set! entries (cons (list mount-id parent-id mount-point)
+ entries))
+ (loop)))
+ (lambda args
+ ((log)
+ "Warning: Skipping mountinfo line due to parse error: ~s (~a)~%"
+ line args)
+ (loop))))
+ (x (begin
+ ((log) "Warning: Skipping mountinfo line: %s" x)
+ (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 '(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 *root-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 (kill-process? pid command)
+ "Return whether to kill process with id PID (and command COMMAND)"
+ ((log) "~%Process Found: PID ~a Command: ~s~%" pid command)
+ #t
+ ;((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 flags options exp ...)
+ (call-with-mounted-filesystem source mountpoint file-system-type flags options
+ (lambda () (begin exp ...)))))))
+
+ (define (call-with-logging thunk)
+ (mkdir-p "/proc")
+ (mkdir-p "/dev")
+ (with-mounted-filesystem "none" "/proc" "proc" 0 #f ; TODO: MS_NODEV, MS_NOEXEC, MS_NOSUID
+ (with-mounted-filesystem "none" "/dev" "devtmpfs" 0 #f ; TODO: MS_NOEXEC, MS_NOSUID
+ (catch 'system-error
+ (lambda ()
+ (mknod "/dev/console" 'char-special #o600 (+ (* 5 256) 1)))
+ (const #f))
+ (catch 'system-error
+ (lambda ()
+ (mknod "/dev/tty0" 'char-special #o600 (+ (* 4 256) 0)))
+ (const #f))
+ (call-with-io-file "/dev/console" ; TODO: /dev/console after we set it up using vt-set-as-console at boot or something (see plymouth).
+ (lambda ()
+ ;(vt-activate (current-input-port) 12)
+ (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 *root-mount-point*))
+ (mounts (safe-find-nested-mounts *root-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 flags options proc)
+ (mount source mountpoint file-system-type flags options #:update-mtab? #f)
+ (catch #t
+ (lambda ()
+ (proc)
+ (umount mountpoint))
+ (lambda args
+ (umount mountpoint))))
+
+ ;; This will also 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 ()
+ (parameterize ((log (lambda args
+ (apply format (current-error-port) args))))
+ (let ((error-port (current-error-port)))
+ (format error-port "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 (kill-process? 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,12 +724,45 @@ (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)
+ ((@ (fibers) sleep) 5) ; just in case
+ #t)
+ (lambda args
+ ((log) "failed to remount / ro %s %~" args)
+ (let loopity ((q 0))
+ ((log) "user, do something!~%")
+ ((@ (fibers) sleep) 1)
+ (loopity (+ q 1)))))))
(unless (zero? n)
;; Yield to the other fibers. That gives logging fibers
;; an opportunity to close log files so the 'mount' call
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.