Package: guix-patches;
Reported by: Josselin Poiret <dev <at> jpoiret.xyz>
Date: Sat, 23 Oct 2021 09:47:02 UTC
Severity: normal
Tags: patch
Done: Ludovic Courtès <ludo <at> gnu.org>
Bug is archived. No further changes may be made.
View this message in rfc822 format
From: Josselin Poiret <dev <at> jpoiret.xyz> To: 51346 <at> debbugs.gnu.org Subject: [bug#51346] [PATCH 1/1] gnu: system: Add support for swap dependencies and flags Date: Sat, 23 Oct 2021 08:55:24 +0000
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{<swap-partition>} or @code{<swap-file>} 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> operating-system
(mapped-devices operating-system-mapped-devices ; list of <mapped-device>
(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 | <swap-file> |
+ (default '())) ; <swap-partition>
(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> 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> 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))
--
2.33.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.