@@ -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.
@@ -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))
@@ -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