From patchwork Fri Apr 25 18:09:11 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Danny Milosavljevic X-Patchwork-Id: 42009 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id C394127BC49; Fri, 25 Apr 2025 19:10:25 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.1 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_DNSWL_BLOCKED,RCVD_IN_SBL_CSS, RCVD_IN_VALIDITY_CERTIFIED,RCVD_IN_VALIDITY_RPBL,RCVD_IN_VALIDITY_SAFE, SPF_HELO_PASS,URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 1183427BC4A for ; Fri, 25 Apr 2025 19:10:23 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1u8NV0-00044d-0f; Fri, 25 Apr 2025 14:10:06 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1u8NUy-00042K-1P for guix-patches@gnu.org; Fri, 25 Apr 2025 14:10:04 -0400 Received: from debbugs.gnu.org ([2001:470:142:5::43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1u8NUx-0001hK-D2 for guix-patches@gnu.org; Fri, 25 Apr 2025 14:10:03 -0400 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=debbugs.gnu.org; s=debbugs-gnu-org; h=MIME-Version:Date:From:To:In-Reply-To:References:Subject; bh=FJ2JKycURu1IcyZbbpT1Dz3e6a34eI1ohsV9vZnOIgQ=; b=OnHfxRcBWqcAD2/cCjH6gRqZ1nnrlrVgjRk3Tb+u2dcc/fRdrpZEyab6v4dr4Dq7cOgW6eASF+oWlgVAulxzjDIStnou+8o/nOEOik7aBXqMxbZjtFrTWdnMOAO0RoCweMmeiQpLQ5+Io/JK9kfyvjT/VGjJAg1DkZIyf42uukAO6EpcGLiwgICY9VapQERPWYNx3KEkbSB2dv26QEoNFaSh645R+z2iTFeUye5wDLEaelbilikHutV/BlnoNZ/hTgus4Om5vGpadol60gOIRJvDuzE/nWNKGAVQfdOPm7uRY/yhixVXhzzMd+HVvQ/bWB0Yr66GRMCNvBxVfa6p6g==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1u8NUx-0003yr-5l for guix-patches@gnu.org; Fri, 25 Apr 2025 14:10:03 -0400 X-Loop: help-debbugs@gnu.org Subject: [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. References: <8431d7c9e15a6fadec714fcce4b34cd9cd989c8e.1745535734.git.dannym@friendly-machines.com> In-Reply-To: <8431d7c9e15a6fadec714fcce4b34cd9cd989c8e.1745535734.git.dannym@friendly-machines.com> Resent-From: Danny Milosavljevic Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Fri, 25 Apr 2025 18:10:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 78051 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 78051@debbugs.gnu.org Cc: Danny Milosavljevic Received: via spool by 78051-submit@debbugs.gnu.org id=B78051.174560456515155 (code B ref 78051); Fri, 25 Apr 2025 18:10:02 +0000 Received: (at 78051) by debbugs.gnu.org; 25 Apr 2025 18:09:25 +0000 Received: from localhost ([127.0.0.1]:52638 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1u8NUK-0003wM-BR for submit@debbugs.gnu.org; Fri, 25 Apr 2025 14:09:25 -0400 Received: from cyan.elm.relay.mailchannels.net ([23.83.212.47]:38553) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1u8NUG-0003w4-4f for 78051@debbugs.gnu.org; Fri, 25 Apr 2025 14:09:21 -0400 X-Sender-Id: dreamhost|x-authsender|dannym@friendly-machines.com Received: from relay.mailchannels.net (localhost [127.0.0.1]) by relay.mailchannels.net (Postfix) with ESMTP id 21AC81A3C7F; Fri, 25 Apr 2025 18:09:18 +0000 (UTC) Received: from pdx1-sub0-mail-a239.dreamhost.com (trex-5.trex.outbound.svc.cluster.local [100.110.177.8]) (Authenticated sender: dreamhost) by relay.mailchannels.net (Postfix) with ESMTPA id C2A2E1A3C00; Fri, 25 Apr 2025 18:09:17 +0000 (UTC) ARC-Seal: i=1; s=arc-2022; d=mailchannels.net; t=1745604557; a=rsa-sha256; cv=none; b=MengapnpEFJBfAIz0CmyCPjsMvFyuOwle9fSk1c2A4Crju3keriZCNIhrz8MeE8/er8jBw lpDymUDFc+NCU2yFhe5iFKoVtjlmhEO1wLlmhLISTX7W73ZUT8ftdLp0Ch3nacCaGZOlNN mQHMq2wSclm3VsZW1PFiMPGHn2Im3xHnvFW/5hx7Hg/YwGPEEThT/M7aBxmHwuxhvPKMSS qFSGlIOFJGp+4Ozqljmqdp1ckbIIMAnWlX/F1nnCSlg2YLd6lFbe95P8RsZraI521xokCR mfDGg9903um3bBIHlVgtUvV51GNILDMfCszCanF3i+W3E1htZpTkaRc5u5miHw== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=mailchannels.net; s=arc-2022; t=1745604557; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding:dkim-signature; bh=FJ2JKycURu1IcyZbbpT1Dz3e6a34eI1ohsV9vZnOIgQ=; b=vC8an+OuFKMcIpG3FYxe2nhf+OgCAimQY72BLiufyNaAGMCBKNqV0CrH4dFZy+9SrHaE3/ ECBzvDgfPBmskU7lbk3YEfyKW1JOFUmCrVPM+pohfGW6tn30t7wGygAP3WoAELTWQLx5bY 1otqNNaRz2GIIIgmWXjIQXd+3wFdu7C/pHwNegkX45/tKbbFXnjl5CFpqVkgpcmSQqQHX5 nkL/gASP3m/8ksxoBhJIZrz1QZJi94x3T3KuNmjRIntTNQ9hS4dP9gVrqWVBQxt+bYf/na Gwgjbi7pYioHgYgg01kp3ef5p1tK4uPr4GHSDOu3Xa9Q0Yf4U3K1kdQj58Vd/A== ARC-Authentication-Results: i=1; rspamd-df67f78bd-tpg6h; auth=pass smtp.auth=dreamhost smtp.mailfrom=dannym@friendly-machines.com X-Sender-Id: dreamhost|x-authsender|dannym@friendly-machines.com X-MC-Relay: Neutral X-MailChannels-SenderId: dreamhost|x-authsender|dannym@friendly-machines.com X-MailChannels-Auth-Id: dreamhost X-Broad-Irritate: 6acfd2976b595867_1745604558020_2977242968 X-MC-Loop-Signature: 1745604558020:574370441 X-MC-Ingress-Time: 1745604558019 Received: from pdx1-sub0-mail-a239.dreamhost.com (pop.dreamhost.com [64.90.62.162]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384) by 100.110.177.8 (trex/7.0.3); Fri, 25 Apr 2025 18:09:18 +0000 Received: from localhost (84-115-226-251.cable.dynamic.surfer.at [84.115.226.251]) (using TLSv1.3 with cipher TLS_AES_256_GCM_SHA384 (256/256 bits) key-exchange ECDHE (P-256) server-signature RSA-PSS (2048 bits) server-digest SHA256) (No client certificate requested) (Authenticated sender: dannym@friendly-machines.com) by pdx1-sub0-mail-a239.dreamhost.com (Postfix) with ESMTPSA id 4ZkgpP1FzZzHn; Fri, 25 Apr 2025 11:09:16 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=friendly-machines.com; s=dreamhost; t=1745604557; bh=FJ2JKycURu1IcyZbbpT1Dz3e6a34eI1ohsV9vZnOIgQ=; h=From:To:Cc:Subject:Date:Content-Transfer-Encoding; b=aBWqEys2bwZV2sE2HwI3aR3aFU/ht6We39PeelFr0NGrKL3kG1Rd8vs0Lp0yHHDYi PAqfgxTcsbLJM69EYj0x2lsuQwCDDjOFpOEgTIVR2X7PeAxv06njWi3kMDhELUKdn2 +IL6ZSkNy7mBKeqM7tbmvjzToC3AGDYdARl2O/EkRAQI9dWUc+DToe+K5L2Zm6Cm9F JDeKgBb94nEthLp6fjjk4AuacgPFMTv6SRoIFwPsvbov97idbpmONkzgjxIPAo0Cg9 VDBEN7IQQix+vtSV6kU1eEZCsiV8SfzJ7p9wBAFMsTk0AOXeOQUgt/+mbSM7gTM2Cf xy3JwA7Ygpl3w== From: Danny Milosavljevic Date: Fri, 25 Apr 2025 20:09:11 +0200 Message-ID: <0898a8b611d92a673e23d4b0b15142f652fc5248.1745603890.git.dannym@friendly-machines.com> X-Mailer: git-send-email 2.49.0 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches * 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)))