[bug#78051,WIP,v3] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems.
Commit Message
* 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(-)
@@ -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)))