unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: Josselin Poiret via Guix-patches via <guix-patches@gnu.org>
To: "Ludovic Courtès" <ludo@gnu.org>
Cc: Josselin Poiret <dev@jpoiret.xyz>,
	Tobias Geerinckx-Rice <me@tobias.gr>,
	51346@debbugs.gnu.org
Subject: [bug#51346] [PATCH v3 1/5] gnu: system: Rework swap space support, add dependencies.
Date: Mon, 15 Nov 2021 20:26:27 +0000	[thread overview]
Message-ID: <20211115202631.6032-2-dev@jpoiret.xyz> (raw)
In-Reply-To: <20211115202631.6032-1-dev@jpoiret.xyz>

* 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       | 98 +++++++++++++++++++++++++------------
 gnu/system.scm              |  4 +-
 gnu/system/file-systems.scm | 18 ++++++-
 3 files changed, 85 insertions(+), 35 deletions(-)

diff --git a/gnu/services/base.scm b/gnu/services/base.scm
index 50865055fe..35f38c7e09 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,94 @@ (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."
+  (service swap-service-type swap))
 
 (define %default-gpm-options
   ;; Default options for GPM.
diff --git a/gnu/system.scm b/gnu/system.scm
index 17653682c5..fd556e1e7c 100644
--- a/gnu/system.scm
+++ b/gnu/system.scm
@@ -233,8 +233,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-space>
+                (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 c6c1b96d16..027df7e966 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -97,7 +97,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:
 ;;;
@@ -712,4 +717,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





  reply	other threads:[~2021-11-15 20:28 UTC|newest]

Thread overview: 21+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2021-10-23  9:46 [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Josselin Poiret via Guix-patches via
2021-10-23  8:55 ` [bug#51346] [PATCH 1/1] gnu: system: Add support for swap " Josselin Poiret via Guix-patches via
2021-10-24 13:58   ` Tobias Geerinckx-Rice via Guix-patches via
2021-10-27 15:09     ` [bug#51346] [PATCH v2 0/4] Rework swap, add flags and dependencies Josselin Poiret via Guix-patches via
2021-10-27 15:09       ` [bug#51346] [PATCH v2 1/4] gnu: system: Rework swap space support, add dependencies Josselin Poiret via Guix-patches via
2021-11-15 10:56         ` [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-11-15 11:04         ` Ludovic Courtès
2021-11-15 20:26           ` [bug#51346] [PATCH v3 0/5] " Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` Josselin Poiret via Guix-patches via [this message]
2021-11-15 20:26             ` [bug#51346] [PATCH v3 2/5] gnu: system: Warn about swap-devices format change Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 3/5] gnu: system: Add swap flags Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 4/5] gnu: system: Filter out boot dependencies from swap-space Josselin Poiret via Guix-patches via
2021-11-15 20:26             ` [bug#51346] [PATCH v3 5/5] doc: Add new Swap Space section Josselin Poiret via Guix-patches via
2021-11-23  9:23             ` bug#51346: [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-10-27 15:09       ` [bug#51346] [PATCH v2 2/4] gnu: system: Add swap flags Josselin Poiret via Guix-patches via
2021-11-15 10:59         ` [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-10-27 15:09       ` [bug#51346] [PATCH v2 3/4] gnu: system: Filter out boot dependencies from swap-space Josselin Poiret via Guix-patches via
2021-10-27 15:09       ` [bug#51346] [PATCH v2 4/4] doc: Add new Swap Space section Josselin Poiret via Guix-patches via
2021-11-15 11:01         ` [bug#51346] [PATCH 0/1 core-updates-frozen] Rework swap device to add dependencies and flags Ludovic Courtès
2021-10-24  2:05 ` Tobias Geerinckx-Rice via Guix-patches via
2021-10-25 14:17   ` Josselin Poiret via Guix-patches via

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20211115202631.6032-2-dev@jpoiret.xyz \
    --to=guix-patches@gnu.org \
    --cc=51346@debbugs.gnu.org \
    --cc=dev@jpoiret.xyz \
    --cc=ludo@gnu.org \
    --cc=me@tobias.gr \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).