From patchwork Thu Apr 24 23:03:17 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Danny Milosavljevic X-Patchwork-Id: 41989 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 0CC7927BC4B; Fri, 25 Apr 2025 00:04: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=ham 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 7F81527BC49 for ; Fri, 25 Apr 2025 00:04:23 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1u85bz-0006YN-TC; Thu, 24 Apr 2025 19:04:07 -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 1u85bv-0006Xo-80 for guix-patches@gnu.org; Thu, 24 Apr 2025 19:04:03 -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 1u85bu-0005P8-RS for guix-patches@gnu.org; Thu, 24 Apr 2025 19:04:02 -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:Subject; bh=b9JZaHh8WYtNo9effUOw1z0i4hYxXS05Bz+ZGActtGo=; b=TcWjiNeMvJa5tyKc3zaVeahECrVsK5ngLhJqIATmnseyek38IjpHA1qRHf1m7h8ZAmhNiiPX/HBN0R4pfCJtWbYJrFeqm6KmUY8aJtxivr30lg0j+pmDijt9fvMYlNrBpJxhj3v0kLImoD1mEyJlHWJtncVuHAW6O3FCaPQy36OiijnCbM+ga9zKa0LIWssMFrT90QMmw7GrE/Zsy8hJV8Y176/w4sTzywbo9Bk1usHRNb1bn18eHp5lUX1cIFDix6DMKP2mmK8GIng4X7VoXLB+vtWtysu8NCxeWbur1ubPFNwv7fptSZU8fNDvmV3jMlAWeN3qgJXWT/IJgnUJ7g==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1u85bu-0007dI-D4 for guix-patches@gnu.org; Thu, 24 Apr 2025 19:04:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#78051] [WIP] services: root-file-system: In 'stop' method, find and kill processes that are writing to our filesystems, and then umount the filesystems. Resent-From: Danny Milosavljevic Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Thu, 24 Apr 2025 23:04:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: report 78051 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: To: 78051@debbugs.gnu.org Cc: Danny Milosavljevic X-Debbugs-Original-To: guix-patches@gnu.org Received: via spool by submit@debbugs.gnu.org id=B.174553584129327 (code B ref -1); Thu, 24 Apr 2025 23:04:02 +0000 Received: (at submit) by debbugs.gnu.org; 24 Apr 2025 23:04:01 +0000 Received: from localhost ([127.0.0.1]:42700 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1u85br-0007cu-UJ for submit@debbugs.gnu.org; Thu, 24 Apr 2025 19:04:00 -0400 Received: from lists.gnu.org ([2001:470:142::17]:35720) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1u85bl-0007cW-Rm for submit@debbugs.gnu.org; Thu, 24 Apr 2025 19:03:57 -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 1u85bc-0006UL-Of for guix-patches@gnu.org; Thu, 24 Apr 2025 19:03:47 -0400 Received: from fly.ash.relay.mailchannels.net ([23.83.222.61]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1u85bZ-0005Jo-Li for guix-patches@gnu.org; Thu, 24 Apr 2025 19:03:44 -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 55A108A4167; Thu, 24 Apr 2025 23:03:37 +0000 (UTC) Received: from pdx1-sub0-mail-a239.dreamhost.com (trex-7.trex.outbound.svc.cluster.local [100.110.114.200]) (Authenticated sender: dreamhost) by relay.mailchannels.net (Postfix) with ESMTPA id D9EE78A52A5; Thu, 24 Apr 2025 23:03:36 +0000 (UTC) ARC-Seal: i=1; s=arc-2022; d=mailchannels.net; t=1745535816; a=rsa-sha256; cv=none; b=zhpv/B2lO9+LYygyE0Dlvyyj/JmhjTAnPTiAzvXOIvs2rDWNkVLT36ne5Qngl1gVM3T+sk zKLyTBb9rk5uME17Xnw2czbbBOWQVesgW7DHFJvSDjk4jDcrYdUTA5Ibf0ohurBgjjZewr xsu+NK3cYQs8G+TcXl3fYf28ieJT8+mwjxwrzqKegtcW8Y6fJiqwYqDfPwUBnO+51zLRC3 3ByYruqitwTv+vyx5lZWxapeiPEY4IkOWZ4kWZfgYxF5MDArNsmNK1/DYqz3MHkMl+dnK0 AKZJJRfsIcvq8pDzJYYJjG8vKeifZ1bN3swtnvqQqBuLWut8YeiUc0/jlMv3sA== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=mailchannels.net; s=arc-2022; t=1745535816; 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=b9JZaHh8WYtNo9effUOw1z0i4hYxXS05Bz+ZGActtGo=; b=F8rEcrRuADqZFLTzKPp8RNxeCJIjAV4elyPcRcvycSKVq1Ax2+7Qa/w7aXpDxN5Z9kJLM3 sGtnLMnpqLvgkg6qwU9MKgx4APti0a/ha2vwBS6jMBCQsjvtKhbR0yAFfVO60mbJ2UHzaC R1lZB+YAfu2lmZgw73BfD7TWbJAiWWNzvA9tYUo+2U++ybinMZN7TYz5wBuvkjqBtbOQI+ L1MgeW3pqx7H6EG/WMT9j7C5Wfoi1OR4qQNn4MtIP3rU0NwHSEOZNbYJVKpp9VaRwpVPYJ o5Jn/sTQemLMkWdVnwBcJB/jNWIjB00RAxWxBc+lBZl8etu0jexhgzUvGhtVPA== ARC-Authentication-Results: i=1; rspamd-5cfcf5665-tmdwp; 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-Gusty-Spill: 50fd026e7590ec1d_1745535817118_1762459776 X-MC-Loop-Signature: 1745535817118:1924428579 X-MC-Ingress-Time: 1745535817118 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.114.200 (trex/7.0.3); Thu, 24 Apr 2025 23:03:37 +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 4ZkBNS32Y2z9y; Thu, 24 Apr 2025 16:03:36 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=friendly-machines.com; s=dreamhost; t=1745535816; bh=b9JZaHh8WYtNo9effUOw1z0i4hYxXS05Bz+ZGActtGo=; h=From:To:Cc:Subject:Date:Content-Transfer-Encoding; b=Wagz1sKjF4+qAPudDrNl7kiHrffCeowwUd/acLEmJ+Gs8ZEUT1mYPVDK+gxO5xWUD 3PYuYC/ZfTEGJ6ht9+zU4HUT0K2VxMqbJ8WiF2W/guYBtbU5TyUoH6T/VHK7rSN+Ny 40nhlXpGqw2MeZph8IkY1BWxzMcrQ9Mb7x/ipaWPygXGbDzujunDw7awOh/6GNqVb2 b6mye7Ofvw1ny9330y8D+ypOJytm+D7dLtCtYDXazKJBcSlfHlfYtKwO4sTWzcJVlU Nff5YL3rkg+Yd3O+w5cWALzhqXMz68EA8k5Ns8qMM40Z2kUVR4O42JKOg1n0Ru5CiW YS9kEhk/cW0YQ== From: Danny Milosavljevic Date: Fri, 25 Apr 2025 01:03:17 +0200 Message-ID: <8431d7c9e15a6fadec714fcce4b34cd9cd989c8e.1745535734.git.dannym@friendly-machines.com> X-Mailer: git-send-email 2.49.0 MIME-Version: 1.0 Received-SPF: pass client-ip=23.83.222.61; envelope-from=dannym@friendly-machines.com; helo=fly.ash.relay.mailchannels.net X-Spam_score_int: 12 X-Spam_score: 1.2 X-Spam_bar: + X-Spam_report: (1.2 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_NONE=-0.0001, RCVD_IN_SBL_CSS=3.335, RCVD_IN_VALIDITY_CERTIFIED_BLOCKED=0.001, RCVD_IN_VALIDITY_RPBL_BLOCKED=0.001, SPF_HELO_NONE=0.001, SPF_PASS=-0.001 autolearn=no autolearn_force=no X-Spam_action: no action 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: If244a1594281057ee5b6163e23bcf11fab3968ff --- gnu/services/base.scm | 381 ++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 367 insertions(+), 14 deletions(-) base-commit: 85b5c2c8f66aed05730f6c7bdeabfaadf619bb8f prerequisite-patch-id: 1a4781dff5873451484bba21bc0dc4617075cb55 prerequisite-patch-id: bbe7274727aa8e1bf4beee1acafbd0a3fdc9257a 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