From patchwork Sat Oct 23 08:55:24 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Josselin Poiret X-Patchwork-Id: 34016 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 6E4BC27BBE3; Sat, 23 Oct 2021 11:48:30 +0100 (BST) X-Spam-Checker-Version: SpamAssassin 3.4.2 (2018-09-13) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-2.8 required=5.0 tests=BAYES_00,DKIM_SIGNED, MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS,T_DKIM_INVALID, URIBL_BLOCKED autolearn=unavailable autolearn_force=no version=3.4.2 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id 0720227BBE1 for ; Sat, 23 Oct 2021 11:48:29 +0100 (BST) Received: from localhost ([::1]:33132 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1meEZf-0000hX-TQ for patchwork@mira.cbaines.net; Sat, 23 Oct 2021 06:48:27 -0400 Received: from eggs.gnu.org ([2001:470:142:3::10]:59198) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1meDeB-0001ms-6Q for guix-patches@gnu.org; Sat, 23 Oct 2021 05:49:03 -0400 Received: from debbugs.gnu.org ([209.51.188.43]:51099) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1meDeA-0004KB-Te for guix-patches@gnu.org; Sat, 23 Oct 2021 05:49:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1meDeA-0003wq-Rv for guix-patches@gnu.org; Sat, 23 Oct 2021 05:49:02 -0400 X-Loop: help-debbugs@gnu.org Subject: [bug#51346] [PATCH 1/1] gnu: system: Add support for swap dependencies and flags References: <87fsssdqg2.fsf@jpoiret.xyz> In-Reply-To: <87fsssdqg2.fsf@jpoiret.xyz> Resent-From: Josselin Poiret Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 23 Oct 2021 09:49:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 51346 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 51346@debbugs.gnu.org Received: via spool by 51346-submit@debbugs.gnu.org id=B51346.163498248915096 (code B ref 51346); Sat, 23 Oct 2021 09:49:02 +0000 Received: (at 51346) by debbugs.gnu.org; 23 Oct 2021 09:48:09 +0000 Received: from localhost ([127.0.0.1]:34408 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1meDdI-0003vP-7n for submit@debbugs.gnu.org; Sat, 23 Oct 2021 05:48:09 -0400 Received: from jpoiret.xyz ([206.189.101.64]:41422) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1meDdG-0003vH-8R for 51346@debbugs.gnu.org; Sat, 23 Oct 2021 05:48:07 -0400 Received: from authenticated-user (jpoiret.xyz [206.189.101.64]) by jpoiret.xyz (Postfix) with ESMTPA id 350ED184D67; Sat, 23 Oct 2021 09:48:05 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=jpoiret.xyz; s=dkim; t=1634982485; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:mime-version:mime-version:content-type:content-type; bh=PJPYTy6j+jb6HR295ZU2QisL1+YMzwrA0AazbZyJKvs=; b=RumFD9Bm98EJBjoEuhDfA/AJ+NSPQ3OJ3HcKcNRtrcEq1D9EibhBP9tVfzlnTtIVl3SPaE TnqNMPKU14jrTZo/45DYDidefdR5xrq5BbuavctqgZ5OCzbjDYtFA0buROr9zyRtERUJpH /GbMrWso6EGp+adB4Sh/roQ9fjPrqsWfo5Xi9PrsgrgDibD8YQddxwoirBREt0d8ohHDte GplCiMvLmtVEcYT/FQrsgiaZd4SyFb+A7frlfhwy5KE6bHpTf4649zgmpPMvxSongOROo+ DwNJ/t92fcl/DCf2Qq88GIJSOgXnFVsbnVOE0z2Md5/Pusux94o6GkCbhFdCPQ== Date: Sat, 23 Oct 2021 08:55:24 +0000 Message-ID: <87cznwdqcr.fsf@jpoiret.xyz> MIME-Version: 1.0 X-Spamd-Bar: / Authentication-Results: jpoiret.xyz; auth=pass smtp.auth=jpoiret@jpoiret.xyz smtp.mailfrom=dev@jpoiret.xyz X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-Mailman-Approved-At: Sat, 23 Oct 2021 06:48:21 -0400 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" Reply-to: Josselin Poiret X-ACL-Warn: , Josselin Poiret via Guix-patches X-Patchwork-Original-From: Josselin Poiret via Guix-patches via From: Josselin Poiret X-getmail-retrieved-from-mailbox: Patches Add new record types swap-file and swap-partition while still supporting the old style (for now). These support dependencies, as well as swapon flags. * gnu/system/file-systems.scm (swap-file, swap-partition): Add them. * gnu/system.scm (operating-system)[swap-devices]: Update comment. * gnu/services/base.scm (swap-partition->service-name, swap-file->service-name, swap-deprecated->service-name, swap->service-name): Add them. * gnu/services/base.scm (swap-service-type): Make it use the new record types and flags. * gnu/build/syscalls.scm (SWAP_FLAG_PREFER, SWAP_FLAG_PRIO_MASK, SWAP_FLAG_PRIO_SHIFT, SWAP_FLAG_DISCARD): Add flags from glibc. * gnu/build/file-systems.scm (swap-flags->bit-mask): Add it. * doc/guix.texi (Swap Space): Add new section. * doc/guix.texi (operating-system Reference): Update it. --- doc/guix.texi | 98 +++++++++++++++++++--------- gnu/build/file-systems.scm | 25 ++++++- gnu/services/base.scm | 126 ++++++++++++++++++++++++++---------- gnu/system.scm | 4 +- gnu/system/file-systems.scm | 34 +++++++++- guix/build/syscalls.scm | 12 ++++ 6 files changed, 230 insertions(+), 69 deletions(-) diff --git a/doc/guix.texi b/doc/guix.texi index 67a05a10ff..88b097b3a8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -319,6 +319,7 @@ System Configuration * operating-system Reference:: Detail of operating-system declarations. * File Systems:: Configuring file system mounts. * Mapped Devices:: Block device extra processing. +* Swap Space:: Adding swap space. * User Accounts:: Specifying user accounts. * Keyboard Layout:: How the system interprets key strokes. * Locales:: Language and cultural convention settings. @@ -13769,6 +13770,7 @@ instance to support new system services. * operating-system Reference:: Detail of operating-system declarations. * File Systems:: Configuring file system mounts. * Mapped Devices:: Block device extra processing. +* Swap Space:: Adding swap space. * User Accounts:: Specifying user accounts. * Keyboard Layout:: How the system interprets key strokes. * Locales:: Language and cultural convention settings. @@ -14135,38 +14137,11 @@ A list of mapped devices. @xref{Mapped Devices}. @item @code{file-systems} A list of file systems. @xref{File Systems}. -@cindex swap devices -@cindex swap space @item @code{swap-devices} (default: @code{'()}) -A list of UUIDs, file system labels, or strings identifying devices or -files to be used for ``swap -space'' (@pxref{Memory Concepts,,, libc, The GNU C Library Reference -Manual}). Here are some examples: - -@table @code -@item (list (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb")) -Use the swap partition with the given UUID@. You can learn the UUID of a -Linux swap partition by running @command{swaplabel @var{device}}, where -@var{device} is the @file{/dev} file name of that partition. - -@item (list (file-system-label "swap")) -Use the partition with label @code{swap}. Again, the -@command{swaplabel} command allows you to view and change the label of a -Linux swap partition. - -@item (list "/swapfile") -Use the file @file{/swapfile} as swap space. - -@item (list "/dev/sda3" "/dev/sdb2") -Use the @file{/dev/sda3} and @file{/dev/sdb2} partitions as swap space. -We recommend referring to swap devices by UUIDs or labels as shown above -instead. -@end table - -It is possible to specify a swap file in a file system on a mapped -device (under @file{/dev/mapper}), provided that the necessary device -mapping and file system are also specified. @xref{Mapped Devices} and -@ref{File Systems}. +@cindex swap devices +A list of @code{} or @code{} objects +(@pxref{Swap Space}), to be used for ``swap space'' (@pxref{Memory +Concepts,,, libc, The GNU C Library Reference Manual}). @item @code{users} (default: @code{%base-user-accounts}) @itemx @code{groups} (default: @code{%base-groups}) @@ -14788,6 +14763,67 @@ Devices @file{/dev/mapper/vg0-alpha} and @file{/dev/mapper/vg0-beta} can then be used as the @code{device} of a @code{file-system} declaration (@pxref{File Systems}). +@node Swap Space +@section Swap Space +@cindex swap space + +@deftp {Data Type} swap-partition +Objects of this type represent swap partitions. They contain the following +members: + +@table @asis +@item @code{device} +The device to use, either a UUID, a @code{file-system-label} or a string, +as in the definition of a @code{file-system} (@pxref{File Systems}). + +@item @code{dependencies} (default: @code{'()}) +A list of @code{mapped-device} objects, upon which the availability of +the device depends. + +@item @code{flags} (default: @code{'()}) +A list of flags. The supported flags are @code{'delayed} and +@code{('priority n)}, see @command{man 2 swapon} in the kernel man pages +(@code{man-pages} guix package) for more information. + +@end table +@end deftp + +@deftp {Data Type} swap-file +Objects of this type represent swap files. They contain the following +members: + +@table @asis +@item @code{path} +A string, specifying the file path of the swap file to use. + +@item @code{fs} +A @code{file-system} object representing the file system inside which the +swap file may be found. + +@item @code{flags} (default: @code{'()}) +See the @code{flags} member of @code{swap-partition}. + +@end table +@end deftp + +Here are some examples: + +@table @code +@item (swap-partition (device (uuid "4dab5feb-d176-45de-b287-9b0a6e4c01cb"))) +Use the swap partition with the given UUID@. You can learn the UUID of a +Linux swap partition by running @command{swaplabel @var{device}}, where +@var{device} is the @file{/dev} file name of that partition. + +@item (swap-partition (device (file-system-label "swap"))) +Use the partition with label @code{swap}. Again, the +@command{swaplabel} command allows you to view and change the label of a +Linux swap partition. + +@item (swap-file (path "/swapfile") (fs root-fs)) +Use the file @file{/swapfile} as swap space, which is present on the +@var{root-fs} filesystem. +@end table + @node User Accounts @section User Accounts diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index d8a5ddf1e5..e9806620fb 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -29,6 +29,8 @@ (define-module (gnu build file-systems) #:use-module (guix build bournish) #:use-module ((guix build syscalls) #:hide (file-system-type)) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (rnrs io ports) #:use-module (rnrs bytevectors) #:use-module (ice-9 match) @@ -54,7 +56,9 @@ (define-module (gnu build file-systems) mount-flags->bit-mask check-file-system - mount-file-system)) + mount-file-system + + swap-flags->bit-mask)) ;;; Commentary: ;;; @@ -227,6 +231,25 @@ (define (linux-swap-superblock-volume-name sblock) "Return the label of Linux-swap superblock SBLOCK as a string." (null-terminated-latin1->string (sub-bytevector sblock (+ 1024 4 4 4 16) 16))) + +(define (swap-flags->bit-mask flags) + "Return the number suitable for the 'flags' argument of 'mount' that +corresponds to the symbols listed in FLAGS." + (let loop ((flags flags)) + (match flags + ((('priority p) rest ...) + (if (<= 0 p SWAP_FLAG_PRIO_MASK) ; Here we take for granted that shift == 0 + (logior SWAP_FLAG_PREFER + p + (loop rest)) + (begin (warning (G_ "Given swap priority ~a is not contained +between 0 and ~a. Ignoring.~%") p SWAP_FLAG_PRIO_MASK) + (loop rest)))) + (('discard rest ...) + (logior SWAP_FLAG_DISCARD (loop rest))) + (() + 0)))) + ;;; diff --git a/gnu/services/base.scm b/gnu/services/base.scm index 50865055fe..9b70e59b6f 100644 --- a/gnu/services/base.scm +++ b/gnu/services/base.scm @@ -58,11 +58,14 @@ (define-module (gnu services base) #:use-module (gnu packages linux) #:use-module (gnu packages terminals) #:use-module ((gnu build file-systems) - #:select (mount-flags->bit-mask)) + #:select (mount-flags->bit-mask + swap-flags->bit-mask)) #:use-module (guix gexp) #:use-module (guix records) #:use-module (guix modules) #:use-module ((guix self) #:select (make-config.scm)) + #:use-module (guix diagnostics) + #:use-module (guix i18n) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (ice-9 match) @@ -2146,62 +2149,117 @@ (define* (udev-rules-service name rules #:key (groups '())) udev-service-type udev-extension)))))) (service type #f))) +(define (swap-partition->service-name spartition) + (let ((device (swap-partition-device spartition))) + (symbol-append 'swap- + (string->symbol + (cond ((uuid? device) + (uuid->string device)) + ((file-system-label? device) + (file-system-label->string device)) + (else + device)))))) + +(define (swap-file->service-name sfile) + (symbol-append 'swap- (string->symbol (swap-file-path sfile)))) + +; TODO Remove after deprecation +(define (swap-deprecated->service-name sdep) + (symbol-append 'swap- + (string->symbol + (cond ((uuid? sdep) + (string-take (uuid->string sdep) 6)) + ((file-system-label? sdep) + (file-system-label->string sdep)) + (else + sdep))))) + +(define swap->service-name + (match-lambda ((? swap-partition? spartition) + (swap-partition->service-name spartition)) + ((? swap-file? sfile) + (swap-file->service-name sfile)) + (sdep + (swap-deprecated->service-name sdep)))) + (define swap-service-type (shepherd-service-type 'swap - (lambda (device) - (define requirement - (if (and (string? device) - (string-prefix? "/dev/mapper/" device)) - (list (symbol-append 'device-mapping- - (string->symbol (basename device)))) - '())) - - (define (device-lookup device) + (lambda (swap) + (define requirements + (cond ((swap-partition? swap) + (map dependency->shepherd-service-name + (swap-partition-dependencies swap))) + ((swap-file? swap) + (list (dependency->shepherd-service-name + (swap-file-fs swap)))) + ; TODO Remove after deprecation + ((and (string? swap) (string-prefix? "/dev/mapper/" swap)) + (list (symbol-append 'device-mapping- + (string->symbol (basename swap))))) + (else + '()))) + + (define device-lookup ;; The generic 'find-partition' procedures could return a partition ;; that's not swap space, but that's unlikely. - (cond ((uuid? device) - #~(find-partition-by-uuid #$(uuid-bytevector device))) - ((file-system-label? device) + (cond ((swap-partition? swap) + (let ((device (swap-partition-device swap))) + (cond ((uuid? device) + #~(find-partition-by-uuid #$(uuid-bytevector device))) + ((file-system-label? device) + #~(find-partition-by-label + #$(file-system-label->string device))) + (else + device)))) + ((swap-file? swap) + (swap-file-path swap)) + ; TODO Remove after deprecation + ((uuid? swap) + #~(find-partition-by-uuid #$(uuid-bytevector swap))) + ((file-system-label? swap) #~(find-partition-by-label - #$(file-system-label->string device))) + #$(file-system-label->string swap))) (else - device))) - - (define service-name - (symbol-append 'swap- - (string->symbol - (cond ((uuid? device) - (string-take (uuid->string device) 6)) - ((file-system-label? device) - (file-system-label->string device)) - (else - device))))) + swap))) + + (define flags + (cond ((swap-partition? swap) + (swap-partition-flags swap)) + ((swap-file? swap) + (swap-file-flags swap)) + (else '()))) (with-imported-modules (source-module-closure '((gnu build file-systems))) (shepherd-service - (provision (list service-name)) - (requirement `(udev ,@requirement)) - (documentation "Enable the given swap device.") + (provision (list (swap->service-name swap))) + (requirement `(udev ,@requirements)) + (documentation "Enable the given swap space.") (modules `((gnu build file-systems) ,@%default-modules)) (start #~(lambda () - (let ((device #$(device-lookup device))) + (let ((device #$device-lookup)) (and device (begin - (restart-on-EINTR (swapon device)) + (restart-on-EINTR (swapon device + #$(swap-flags->bit-mask + flags))) #t))))) (stop #~(lambda _ - (let ((device #$(device-lookup device))) + (let ((device #$device-lookup)) (when device (restart-on-EINTR (swapoff device))) #f))) (respawn? #f)))) (description "Turn on the virtual memory swap area."))) -(define (swap-service device) - "Return a service that uses @var{device} as a swap device." - (service swap-service-type device)) +(define (swap-service swap) + "Return a service that uses @var{swap} as a swap space." + (unless (or (swap-partition? swap) (swap-file? swap)) + (warning (G_ "Specifying swap space without @code{swap-partition} or +@code{swap-file} is deprecated, see \"(guix) operating-system Reference\" for +more details.~%"))) + (service swap-service-type swap)) (define %default-gpm-options ;; Default options for GPM. diff --git a/gnu/system.scm b/gnu/system.scm index 58b594694a..f732840488 100644 --- a/gnu/system.scm +++ b/gnu/system.scm @@ -234,8 +234,8 @@ (define-record-type* operating-system (mapped-devices operating-system-mapped-devices ; list of (default '())) (file-systems operating-system-file-systems) ; list of fs - (swap-devices operating-system-swap-devices ; list of strings - (default '())) + (swap-devices operating-system-swap-devices ; list of string | | + (default '())) ; (users operating-system-users ; list of user accounts (default %base-user-accounts)) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index e69cfd06e6..105f1e449b 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -96,7 +96,19 @@ (define-module (gnu system file-systems) %store-mapping %network-configuration-files - %network-file-mappings)) + %network-file-mappings + + swap-file + swap-file? + swap-file-path + swap-file-fs + swap-file-flags + + swap-partition + swap-partition? + swap-partition-device + swap-partition-dependencies + swap-partition-flags)) ;;; Commentary: ;;; @@ -671,4 +683,24 @@ (define (prepend-slash/maybe s) (G_ "Use the @code{subvol} Btrfs file system option.")))))))) +;;; +;;; Swap partition and files +;;; + +(define-record-type* swap-partition make-swap-partition + swap-partition? + this-swap-partition + (device swap-partition-device) + (dependencies swap-partition-dependencies + (default '())) + (flags swap-partition-flags + (default '()))) + +(define-record-type* swap-file make-swap-file swap-file? + this-swap-file + (path swap-file-path) + (fs swap-file-fs) + (flags swap-file-flags + (default '()))) + ;;; file-systems.scm ends here diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 99a3b45004..ae52c0ec54 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -71,6 +71,11 @@ (define-module (guix build syscalls) mounts mount-points + SWAP_FLAG_PREFER + SWAP_FLAG_PRIO_MASK + SWAP_FLAG_PRIO_SHIFT + SWAP_FLAG_DISCARD + swapon swapoff @@ -677,6 +682,13 @@ (define (mount-points) "Return the mounts points for currently mounted file systems." (map mount-point (mounts))) +;; Pulled from glibc's sysdeps/unix/sysv/linux/sys/swap.h + +(define SWAP_FLAG_PREFER #x8000) ;; Set if swap priority is specified. +(define SWAP_FLAG_PRIO_MASK #x7fff) +(define SWAP_FLAG_PRIO_SHIFT 0) +(define SWAP_FLAG_DISCARD #x10000) ;; + (define swapon (let ((proc (syscall->procedure int "swapon" (list '* int)))) (lambda* (device #:optional (flags 0))