futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

system: Rework swap space support, add dependencies.

Browse Source 
* 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.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Josselin Poiret 2021-11-15 20:26:27 +00:00 committed by Ludovic Courtès
parent c984076a7d
commit 133a61ae26
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
3 changed files with 84 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
gnu/services/base.scm
View File

@ -63,6 +63,8 @@
#: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 @@ instance."
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))))
'()))
(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 device)
(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.

4
gnu/system.scm
View File

@ -233,8 +233,8 @@
(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))

18
gnu/system/file-systems.scm
View File

@ -97,7 +97,12 @@
%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 @@ subvolume name is unknown."))
(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