[bug#51346] [PATCH 1/1] gnu: system: Add support for swap dependencies and flags

[Josselin Poiret]

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