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.
Message #32 received at 51346 <at> debbugs.gnu.org (full text, mbox):
From: Josselin Poiret <dev <at> jpoiret.xyz> To: Tobias Geerinckx-Rice <me <at> tobias.gr> Cc: Josselin Poiret <dev <at> jpoiret.xyz>, 51346 <at> debbugs.gnu.org Subject: [PATCH v2 1/4] gnu: system: Rework swap space support, add dependencies. Date: Wed, 27 Oct 2021 15:09:10 +0000
* gnu/system/file-systems.scm (swap-space): Add it.
* gnu/system.scm (operating-system)[swap-devices]: Update comment.
* gnu/services/base.scm (swap-space->shepherd-service-name,
swap-deprecated->shepherd-service-name, swap->shepherd-service-name):
Add them.
* gnu/services/base.scm (swap-service-type, swap-service): Use the new
records.
---
gnu/services/base.scm | 102 +++++++++++++++++++++++++-----------
gnu/system.scm | 2 +-
gnu/system/file-systems.scm | 18 ++++++-
3 files changed, 88 insertions(+), 34 deletions(-)
diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 50865055fe..c816381198 100644
--- a/gnu/services/base.scm
+++ b/gnu/services/base.scm
@@ -63,6 +63,8 @@ (define-module (gnu services base)
#: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 +2148,98 @@ (define* (udev-rules-service name rules #:key (groups '()))
udev-service-type udev-extension))))))
(service type #f)))
+(define (swap-space->shepherd-service-name space)
+ (let ((target (swap-space-target space)))
+ (symbol-append 'swap-
+ (string->symbol
+ (cond ((uuid? target)
+ (uuid->string target))
+ ((file-system-label? target)
+ (file-system-label->string target))
+ (else
+ target))))))
+
+; TODO Remove after deprecation
+(define (swap-deprecated->shepherd-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->shepherd-service-name
+ (match-lambda ((? swap-space? space)
+ (swap-space->shepherd-service-name space))
+ (sdep
+ (swap-deprecated->shepherd-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-space? swap)
+ (map dependency->shepherd-service-name
+ (swap-space-dependencies 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-space? swap)
+ (let ((target (swap-space-target swap)))
+ (cond ((uuid? target)
+ #~(find-partition-by-uuid #$(uuid-bytevector target)))
+ ((file-system-label? target)
+ #~(find-partition-by-label
+ #$(file-system-label->string target)))
+ (else
+ target))))
+ ; 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)))
(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->shepherd-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))
#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 (swap-space? swap)
+ (warning (G_ "Specifying swap space without @code{swap-space}
+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..2797c07e36 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -234,7 +234,7 @@ (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
+ (swap-devices operating-system-swap-devices ; list of string | <swap-space>
(default '()))
(users operating-system-users ; list of user accounts
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index e69cfd06e6..7aa19069a1 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -96,7 +96,12 @@ (define-module (gnu system file-systems)
%store-mapping
%network-configuration-files
- %network-file-mappings))
+ %network-file-mappings
+
+ swap-space
+ swap-space?
+ swap-space-target
+ swap-space-dependencies))
;;; Commentary:
;;;
@@ -671,4 +676,15 @@ (define (prepend-slash/maybe s)
(G_ "Use the @code{subvol} Btrfs file system option."))))))))
+;;;
+;;; Swap space
+;;;
+
+(define-record-type* <swap-space> swap-space make-swap-space
+ swap-space?
+ this-swap-space
+ (target swap-space-target)
+ (dependencies swap-space-dependencies
+ (default '())))
+
;;; file-systems.scm ends here
--
2.33.1
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.