From patchwork Fri Apr 25 17:58:40 2025 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Danny Milosavljevic X-Patchwork-Id: 42008 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 BFD7827BC4C; Fri, 25 Apr 2025 19:07:23 +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 6933727BC49 for ; Fri, 25 Apr 2025 19:07:21 +0100 (BST) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1u8NSB-0002hI-PY; Fri, 25 Apr 2025 14:07:13 -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 1u8NS4-0002fM-DX for guix-patches@gnu.org; Fri, 25 Apr 2025 14:07:05 -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 1u8NS3-0001I2-Jk for guix-patches@gnu.org; Fri, 25 Apr 2025 14:07: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=NJ5lZgyF77BztdRBLk+wFqQ+UR7Th48RbWRPCmEK/aM=; b=XxOR0H6nrxMK/fQzYIoAZT2uO/br+BaEwoJm9fIKRaq723lkUvuWbCowiYY+0p7ed/J6qqWR0ufCiJq94FdnieJjMPHYsM/W9zyUWvDdAXKbguy0ztpPT6OD1G82/taf9U22uHd9xF5q7kD6U4jbNlLe6bYhFpw61KIEbypUDDLUnby5BGzMunEmRZ+9Rt3R+/JN/7DCXvST8X5yoc2zga0yblgOFuf1dFCvKeSpCdgVO5gl8QH96IR0SGU3NF4u3AnpDHDkcpSOM8NG/97hO8MOMXziDz0jtcg6+pOG0tFi+4hMYOxOnreMiwYWzsgYJGoqV3YqxKgEkWUGgJJGPA==; Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1u8NS2-0003i5-CT for guix-patches@gnu.org; Fri, 25 Apr 2025 14:07:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#78051] [WIP v2] 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:07: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.174560438414191 (code B ref 78051); Fri, 25 Apr 2025 18:07:02 +0000 Received: (at 78051) by debbugs.gnu.org; 25 Apr 2025 18:06:24 +0000 Received: from localhost ([127.0.0.1]:52620 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1u8NRQ-0003gp-MO for submit@debbugs.gnu.org; Fri, 25 Apr 2025 14:06:24 -0400 Received: from shrimp.cherry.relay.mailchannels.net ([23.83.223.164]:28625) by debbugs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.84_2) (envelope-from ) id 1u8NRN-0003gd-Qi for 78051@debbugs.gnu.org; Fri, 25 Apr 2025 14:06:22 -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 24FE7233EE; Fri, 25 Apr 2025 18:06:19 +0000 (UTC) Received: from pdx1-sub0-mail-a239.dreamhost.com (trex-6.trex.outbound.svc.cluster.local [100.106.221.95]) (Authenticated sender: dreamhost) by relay.mailchannels.net (Postfix) with ESMTPA id CCCF821959; Fri, 25 Apr 2025 18:06:18 +0000 (UTC) ARC-Seal: i=1; s=arc-2022; d=mailchannels.net; t=1745604378; a=rsa-sha256; cv=none; b=fpi2KWMfHYHYz7la0BD+LrmWdDcIrcBYtpyAJBPrpmjviSkpcz4++vHOSRitm6jHpHZ0ja r+y1MrMPSL3InjMIcnScmoVeTClrRpDjbfvOAs0/d2S27O2AkvJOyIEd/n4nK2Ss1gTDxR nlLd8ssxeMxrmJVfW5Zgf9Z1RKvlKbZ/1VfLDy7OswkPUZ6dUEB+1BMFhbCKMdlQzwRWsz L/ivFr6rH/1FoGCDN9a6DcvRfhgr2u6nrFqM1K+g1MXuJ5ghnB33otZlVryqhtmWP6GriY 6WMvTMSCpJvmg0XUDenkuUiRhAEePbsNYLca6H8kZE1vNASSHMn3ZwtyPIvAiA== ARC-Message-Signature: i=1; a=rsa-sha256; c=relaxed/relaxed; d=mailchannels.net; s=arc-2022; t=1745604378; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version:content-type:content-type: content-transfer-encoding:content-transfer-encoding:dkim-signature; bh=NJ5lZgyF77BztdRBLk+wFqQ+UR7Th48RbWRPCmEK/aM=; b=5pUGz0tglggtspPkq6Z9u51w+iWPy6FcApL0rQqYNO09btGBMXEtVsUGFHjmjKcsh1aPlz ML/YQcmoF90WCKuBPShhWMm+2+Y+TJ7JmkRblhU6MCCG1fi8tpFre+HemfKYLfmpXOn9if J3mpWsSbF8pXPbR26tSVa72gIkG1mpfQ3t4wAlZ3d+eFKuw0KSxs5d6R4FCELaAqaji9By FDUj5yUSqk8UoVSJG0kqKcHG+4KUWpK5MmfwmPz29BhrjnSISlanaeWQQERK09oKG2EWvN zTnlw6GofNGf4vT1OcKOUH15kBEsRN69XtKf8gl4/YgzwQxiUi8DHb31wU311A== ARC-Authentication-Results: i=1; rspamd-5b7d88665-gzg6v; 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-MC-Copy: stored-urls X-MailChannels-SenderId: dreamhost|x-authsender|dannym@friendly-machines.com X-MailChannels-Auth-Id: dreamhost X-Skirt-Trail: 617f04d431741ef1_1745604379083_3783456684 X-MC-Loop-Signature: 1745604379083:2740420051 X-MC-Ingress-Time: 1745604379083 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.106.221.95 (trex/7.0.3); Fri, 25 Apr 2025 18:06:19 +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 4Zkgkx4PJzzHl; Fri, 25 Apr 2025 11:06:17 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=friendly-machines.com; s=dreamhost; t=1745604378; bh=NJ5lZgyF77BztdRBLk+wFqQ+UR7Th48RbWRPCmEK/aM=; h=From:To:Cc:Subject:Date:Content-Type:Content-Transfer-Encoding; b=BzIz+R+qQEMS9WnMfR04K9LiA0Jt0D+owomhfNNF8dgJxdQ97Cgd+aHSbbcfLBIye SWBwjlf0Q3ll0Ac3rw/jN09GuU/SsGSzDTKoK4GckyiMK+72RRvuoBLayDFyLuXWt5 YZH17M0Wa58BYGXJXElOQ5xJW3+X3dwKwP8lFcKcdvOSVilOQJZtLkijLmCj6yP+ot opZPXqgy5xb32SWrWU2J/4AC1Dp/EimTKythoYHRnPpV5U/Z0MFLM27dbSlNplY6K2 3KbrYWTDS+MLOSUGiZEXxYsKsYxrLq1BHWcQgWtgoSo7X8kv/YO2LAKcu9jG8SIFVO KcKw3Str7YZ8A== From: Danny Milosavljevic Date: Fri, 25 Apr 2025 19:58:40 +0200 Message-ID: <0897a8b611d92a673e23d4b0b15142f652fc5248.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(-) base-commit: 55d9b6ff118e777d3e56e5544e51d1c998619727 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* (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 (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* (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 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 (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 make-nscd-cache nscd-cache? @@ -1388,7 +1764,7 @@ (define-record-type* 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{} object." (define (cache->config cache) (match-record 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 - (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 - (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 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 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 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 - ;; . - (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 + ;; . + (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 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 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 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 . - (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 . + (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 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* (define (gpm-shepherd-service config) (match-record config - (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 - (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 - (($ 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 + (($ 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 - (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 - (($ 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 + (($ 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 - (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/ 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/ 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 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 - (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 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 (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 (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 make-greetd-gtkgreet-sway-session @@ -3899,26 +4275,26 @@ (define-record-type* (define (make-greetd-gtkgreet-sway-session-sway-config session) (match-record 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 ) system target) (match-record 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 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)