[bug#51346] [PATCH v2 1/4] gnu: system: Rework swap space support, add dependencies.

[Josselin Poiret]

* 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