projects/guix·blob master · refs

1377 lines · 52.0 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2020 Maxim Cournoyer <[email protected]>
3;;; Copyright © 2020 Brice Waegeneire <[email protected]>
4;;; Copyright © 2020, 2023 Efraim Flashner <[email protected]>
5;;; Copyright © 2021 raid5atemyhomework <[email protected]>
6;;; Copyright © 2021 B. Wilson <[email protected]>
7;;; Copyright © 2022 Josselin Poiret <[email protected]>
8;;; Copyright © 2023 Bruno Victal <[email protected]>
9;;; Copyright © 2023 Felix Lechner <[email protected]>
10;;; Copyright © 2025 Edouard Klein <[email protected]>
11;;; Copyright © 2026 Giacomo Leidi <[email protected]>
12;;; Copyright © 2026 Joan Vilardaga Castro <[email protected]>
13;;; Copyright © 2026 Arjan Adriaanse <[email protected]>
14;;;
15;;; This file is part of GNU Guix.
16;;;
17;;; GNU Guix is free software; you can redistribute it and/or modify it
18;;; under the terms of the GNU General Public License as published by
19;;; the Free Software Foundation; either version 3 of the License, or (at
20;;; your option) any later version.
21;;;
22;;; GNU Guix is distributed in the hope that it will be useful, but
23;;; WITHOUT ANY WARRANTY; without even the implied warranty of
24;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
25;;; GNU General Public License for more details.
26;;;
27;;; You should have received a copy of the GNU General Public License
28;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
29
30(define-module (gnu services linux)
31 #:use-module (guix diagnostics)
32 #:use-module (guix gexp)
33 #:use-module (guix records)
34 #:use-module (guix modules)
35 #:use-module (guix i18n)
36 #:use-module (guix packages)
37 #:use-module (guix ui)
38 #:use-module (gnu services)
39 #:use-module (gnu services admin)
40 #:use-module (gnu services base)
41 #:use-module (gnu services configuration)
42 #:use-module (gnu services dbus)
43 #:use-module (gnu services shepherd)
44 #:use-module (gnu system file-systems)
45 #:use-module (gnu packages base)
46 #:use-module (gnu packages linux)
47 #:use-module (gnu packages power)
48 #:use-module (gnu packages file-systems)
49 #:use-module (srfi srfi-1)
50 #:use-module (srfi srfi-26)
51 #:use-module (srfi srfi-34)
52 #:use-module (srfi srfi-35)
53 #:use-module (srfi srfi-171)
54 #:use-module (ice-9 format)
55 #:use-module (ice-9 match)
56 #:use-module (ice-9 string-fun)
57 #:export (btrfs-scrub-configuration
58 btrfs-scrub-service-type
59
60 earlyoom-configuration
61 earlyoom-configuration?
62 earlyoom-configuration-earlyoom
63 earlyoom-configuration-minimum-available-memory
64 earlyoom-configuration-minimum-free-swap
65 earlyoom-configuration-prefer-regexp
66 earlyoom-configuration-avoid-regexp
67 earlyoom-configuration-memory-report-interval
68 earlyoom-configuration-ignore-positive-oom-score-adj?
69 earlyoom-configuration-show-debug-messages?
70 earlyoom-configuration-send-notification-command
71 earlyoom-service-type
72
73 fstrim-configuration
74 fstrim-configuration?
75 fstrim-configuration-package
76 fstrim-configuration-schedule
77 fstrim-configuration-listed-in
78 fstrim-configuration-verbose?
79 fstrim-configuration-quiet-unsupported?
80 fstrim-configuration-extra-arguments
81 fstrim-service-type
82
83 kernel-module-loader-service-type
84
85 cachefilesd-configuration
86 cachefilesd-configuration?
87 cachefilesd-configuration-cachefilesd
88 cachefilesd-configuration-debug-output?
89 cachefilesd-configuration-use-syslog?
90 cachefilesd-configuration-scan?
91 cachefilesd-configuration-cache-directory
92 cachefilesd-configuration-cache-name
93 cachefilesd-configuration-security-context
94 cachefilesd-configuration-pause-culling-for-block-percentage
95 cachefilesd-configuration-pause-culling-for-file-percentage
96 cachefilesd-configuration-resume-culling-for-block-percentage
97 cachefilesd-configuration-resume-culling-for-file-percentage
98 cachefilesd-configuration-pause-caching-for-block-percentage
99 cachefilesd-configuration-pause-caching-for-file-percentage
100 cachefilesd-configuration-log2-table-size
101 cachefilesd-configuration-cull?
102 cachefilesd-configuration-trace-function-entry-in-kernel-module
103 cachefilesd-configuration-trace-function-exit-in-kernel-module
104 cachefilesd-configuration-trace-internal-checkpoints-in-kernel-module
105 cachefilesd-service-type
106
107 rasdaemon-configuration
108 rasdaemon-configuration?
109 rasdaemon-configuration-record?
110 rasdaemon-service-type
111
112 %default-tuned-configuration-recommend.conf
113 %default-tuned-ppd-settings-battery
114 %default-tuned-ppd-settings-profiles
115
116 tuned-configuration
117 tuned-configuration?
118 tuned-configuration-fields
119 tuned-configuration-tuned
120 tuned-configuration-auto-start?
121 tuned-configuration-power-profiles-daemon-support?
122 tuned-configuration-profiles
123 tuned-configuration-settings
124 tuned-configuration-ppd-settings
125 tuned-configuration-recommend.conf
126
127 tuned-settings
128 tuned-settings?
129 tuned-settings-fields
130 tuned-settings-daemon?
131 tuned-settings-dynamic-tuning?
132 tuned-settings-default-instance-priority
133 tuned-settings-recommend-command?
134 tuned-settings-sleep-interval
135 tuned-settings-update-interval
136 tuned-settings-profile-dirs
137 tuned-settings-extra-content
138
139 tuned-ppd-settings
140 tuned-ppd-settings?
141 tuned-ppd-settings-fields
142 tuned-ppd-settings-default
143 tuned-ppd-settings-battery-detection?
144 tuned-ppd-settings-sysfs-acpi-monitor?
145 tuned-ppd-settings-profiles
146 tuned-ppd-settings-battery
147 tuned-ppd-settings-extra-content
148
149 tuned-file-systems
150 tuned-activation
151 tuned-shepherd-services
152
153 tuned-service-type
154
155 zram-device-configuration
156 zram-device-configuration?
157 zram-device-configuration-size
158 zram-device-configuration-compression-algorithm
159 zram-device-configuration-memory-limit
160 zram-device-configuration-priority
161 zram-device-service-type
162
163 vfs-mapping-service-type
164 vfs-mapping-configuration
165 vfs-mapping))
166
167
168;;;
169;;; BTRFS scrub.
170;;;
171
172(define (btrfs-scrub-shepherd-calendar-event? x)
173 (or (string? x) (gexp? x)))
174
175(define-maybe string (prefix btrfs-scrub-))
176
177(define-maybe list-of-strings (prefix btrfs-scrub-))
178
179(define (btrfs-scrub-serialize-string field-name value)
180 (if (maybe-value-set? value)
181 (list value) '()))
182
183(define (btrfs-scrub-serialize-list-of-strings field-name value)
184 (if (maybe-value-set? value)
185 value '()))
186
187(define-configuration btrfs-scrub-configuration
188 (package
189 (file-like btrfs-progs)
190 "The package providing the @command{btrfs} command." empty-serializer)
191 (schedule (btrfs-scrub-shepherd-calendar-event "0 0 1-7 * 0")
192 "Schedule for launching @command{btrfs-scrub}, expressed as a string in
193traditional cron syntax or as a gexp evaluating to a Shepherd calendar
194event (@pxref{Timers,,, shepherd, The GNU Shepherd Manual}). By default this
195is set to run the 1st Sunday of the month, at 00:00."
196 empty-serializer)
197 ;; The following are btrfs-scrub-related options.
198 (to-scrub (maybe-string "/")
199 "Device to scrub. It will scrub the root (\"/\") if not given.")
200 (extra-arguments maybe-list-of-strings
201 "Extra options to append to @command{btrfs scrub start}
202 (run @samp{man btrfs-scrub} for more information). Keep in mind that,
203 by default, this service uses the @option{-B} flag (do not background and
204 print scrub statistics when finished).")
205 (prefix btrfs-scrub-))
206
207(define (serialize-btrfs-scrub-configuration config)
208 (list-transduce (compose (base-transducer config) tconcatenate)
209 rcons
210 btrfs-scrub-configuration-fields))
211
212
213(define (btrfs-scrub-template-action-procedure btrfs-bin cmd-args to-scrub)
214 "Template procedure to call the btrfs command, print it's outputs and return
215it's exit code. Taken from
216https://www.gnu.org/software/guile/manual/html_node/Processes.html#index-spawn"
217 #~(lambda (_ . args)
218 (let* ((stdout-in-out (pipe)) (stderr-in-out (pipe))
219 (argv (append (list #$btrfs-bin) '#$cmd-args '(#$to-scrub)))
220 (pid (spawn #$btrfs-bin argv
221 #:output (cdr stdout-in-out)
222 #:error (cdr stderr-in-out))))
223 (close-port (cdr stdout-in-out))
224 (close-port (cdr stderr-in-out))
225 (display (get-string-all (car stdout-in-out)))
226 ;; Redirect stderr to stdout to make it printable for "herd"
227 (display (get-string-all (car stderr-in-out)))
228 (close-port (car stdout-in-out))
229 (close-port (car stderr-in-out))
230 (let* ((status (waitpid pid)) (exit-val (status:exit-val (cdr status))))
231 (= EXIT_SUCCESS exit-val)))))
232
233
234(define (btrfs-scrub-status-action-procedure btrfs-bin to-scrub)
235 "Return a procedure to check the status of the current BTRFS scrub."
236 (btrfs-scrub-template-action-procedure btrfs-bin '("scrub" "status") to-scrub))
237
238(define (btrfs-scrub-cancel-action-procedure btrfs-bin to-scrub)
239 "Return a procedure to always cancel the current BTRFS scrub."
240 (btrfs-scrub-template-action-procedure btrfs-bin '("scrub" "cancel") to-scrub))
241
242(define (btrfs-scrub-extra-actions btrfs-bin to-scrub)
243 (list shepherd-trigger-action
244 (shepherd-action (name 'scrub-status)
245 (documentation
246 "Print the status of the scrubing process.")
247 (procedure (btrfs-scrub-status-action-procedure
248 btrfs-bin
249 to-scrub)))
250 (shepherd-action (name 'cancel)
251 (documentation
252 "Cancel the current scrub (it's an alias for stop).")
253 (procedure (btrfs-scrub-cancel-action-procedure
254 btrfs-bin
255 to-scrub)))))
256
257
258(define (btrfs-scrub-shepherd-services config)
259 (match-record config <btrfs-scrub-configuration>
260 (package schedule to-scrub)
261 (let ((btrfs-bin (file-append package "/bin/btrfs")))
262 (list (shepherd-service
263 (provision (list (string->symbol (string-append "btrfs-scrub-" to-scrub))))
264 (requirement '(user-processes))
265 (modules '((shepherd service timer)
266 (ice-9 popen)
267 (ice-9 textual-ports)))
268 (start #~(make-timer-constructor
269 #$(if (string? schedule)
270 #~(cron-string->calendar-event #$schedule)
271 schedule)
272 (command (list #$btrfs-bin
273 "scrub"
274 "start"
275 "-B"
276 #$@(serialize-btrfs-scrub-configuration config)))
277 #:wait-for-termination? #t))
278 (stop (btrfs-scrub-cancel-action-procedure btrfs-bin to-scrub))
279 (documentation "Periodically run the 'btrfs-scrub' command.")
280 (actions (btrfs-scrub-extra-actions btrfs-bin to-scrub)))))))
281
282
283(define btrfs-scrub-service-type
284 (service-type (name 'btrfs-scrub)
285 (extensions (list (service-extension
286 shepherd-root-service-type
287 btrfs-scrub-shepherd-services)))
288 (description
289 "Verify the block checksums of a BTRFS filesystem.")
290 (default-value (btrfs-scrub-configuration))))
291
292
293;;;
294;;; Early OOM daemon.
295;;;
296
297(define-record-type* <earlyoom-configuration>
298 earlyoom-configuration make-earlyoom-configuration
299 earlyoom-configuration?
300 (earlyoom earlyoom-configuration-earlyoom
301 (default earlyoom))
302 (minimum-available-memory earlyoom-configuration-minimum-available-memory
303 (default 10)) ; in percent
304 (minimum-free-swap earlyoom-configuration-minimum-free-swap
305 (default 10)) ; in percent
306 (prefer-regexp earlyoom-configuration-prefer-regexp ; <string>
307 (default #f))
308 (avoid-regexp earlyoom-configuration-avoid-regexp ; <string>
309 (default #f))
310 (memory-report-interval earlyoom-configuration-memory-report-interval
311 (default 0)) ; in seconds; 0 means disabled
312 (ignore-positive-oom-score-adj?
313 earlyoom-configuration-ignore-positive-oom-score-adj? (default #f))
314 (run-with-higher-priority? earlyoom-configuration-run-with-higher-priority?
315 (default #f))
316 (show-debug-messages? earlyoom-configuration-show-debug-messages?
317 (default #f))
318 (send-notification-command
319 earlyoom-configuration-send-notification-command ; <string>
320 (default #f)))
321
322(define (earlyoom-configuration->command-line-args config)
323 "Translate a <earlyoom-configuration> object to its command line arguments
324representation."
325 (match config
326 (($ <earlyoom-configuration> earlyoom minimum-available-memory
327 minimum-free-swap prefer-regexp avoid-regexp
328 memory-report-interval
329 ignore-positive-oom-score-adj?
330 run-with-higher-priority? show-debug-messages?
331 send-notification-command)
332 `(,(file-append earlyoom "/bin/earlyoom")
333 ,@(if minimum-available-memory
334 (list "-m" (format #f "~s" minimum-available-memory))
335 '())
336 ,@(if minimum-free-swap
337 (list "-s" (format #f "~s" minimum-free-swap))
338 '())
339 ,@(if prefer-regexp
340 (list "--prefer" prefer-regexp)
341 '())
342 ,@(if avoid-regexp
343 (list "--avoid" avoid-regexp)
344 '())
345 "-r" ,(format #f "~s" memory-report-interval)
346 ,@(if ignore-positive-oom-score-adj?
347 (list "-i")
348 '())
349 ,@(if run-with-higher-priority?
350 (list "-p")
351 '())
352 ,@(if show-debug-messages?
353 (list "-d")
354 '())
355 ,@(if send-notification-command
356 (list "-N" send-notification-command)
357 '())))))
358
359(define (earlyoom-shepherd-service config)
360 (shepherd-service
361 (documentation "Run the Early OOM daemon.")
362 (provision '(earlyoom))
363 (requirement '(user-processes))
364 (start #~(make-forkexec-constructor
365 '#$(earlyoom-configuration->command-line-args config)
366 #:log-file "/var/log/earlyoom.log"))
367 (stop #~(make-kill-destructor))))
368
369(define earlyoom-service-type
370 (service-type
371 (name 'earlyoom)
372 (default-value (earlyoom-configuration))
373 (extensions
374 (list (service-extension shepherd-root-service-type
375 (compose list earlyoom-shepherd-service))))
376 (description "Run @command{earlyoom}, a daemon that quickly responds to
377@acronym{OOM, out-of-memory} conditions by terminating relevant processes.")))
378
379
380;;;
381;;; fstrim
382;;;
383
384(define (fstrim-shepherd-calendar-event? x)
385 (or (string? x) (gexp? x)))
386
387(define-maybe list-of-strings (prefix fstrim-))
388
389(define (fstrim-serialize-boolean field-name value)
390 (list (format #f "~:[~;--~a~]" value
391 ;; Drop trailing '?' character.
392 (string-drop-right (symbol->string field-name) 1))))
393
394(define (fstrim-serialize-list-of-strings field-name value)
395 (list (string-append "--" (symbol->string field-name))
396 #~(string-join '#$value ":")))
397
398(define-configuration fstrim-configuration
399 (package
400 (file-like util-linux)
401 "The package providing the @command{fstrim} command."
402 empty-serializer)
403 (schedule
404 (fstrim-shepherd-calendar-event "0 0 * * 0")
405 "Schedule for launching @command{fstrim}, expressed as a string in
406traditional cron syntax or as a gexp evaluating to a Shepherd calendar
407event (@pxref{Timers,,, shepherd, The GNU Shepherd Manual}). By default this
408is set to run weekly on Sunday at 00:00."
409 empty-serializer)
410 ;; The following are fstrim-related options.
411 (listed-in
412 (maybe-list-of-strings '("/etc/fstab" "/proc/self/mountinfo"))
413 ;; Note: documentation sourced from the fstrim manpage.
414 "List of files in fstab or kernel mountinfo format. All missing or
415empty files are silently ignored. The evaluation of the list @emph{stops}
416after the first non-empty file. File systems with @code{X-fstrim.notrim} mount
417option in fstab are skipped.")
418 (verbose?
419 (boolean #t)
420 "Verbose execution.")
421 (quiet-unsupported?
422 (boolean #t)
423 "Suppress error messages if trim operation (ioctl) is unsupported.")
424 (extra-arguments
425 maybe-list-of-strings
426 "Extra options to append to @command{fstrim} (run @samp{man fstrim} for
427more information)."
428 (serializer
429 (lambda (_ value)
430 (if (maybe-value-set? value)
431 value '()))))
432 (prefix fstrim-))
433
434(define (serialize-fstrim-configuration config)
435 (list-transduce (compose (base-transducer config) tconcatenate)
436 rcons
437 fstrim-configuration-fields))
438
439(define (fstrim-shepherd-services config)
440 (match-record config <fstrim-configuration>
441 (package schedule)
442 (list (shepherd-service
443 (provision '(fstrim))
444 (requirement '(user-processes))
445 (modules '((shepherd service timer)))
446 (start #~(make-timer-constructor
447 #$(if (string? schedule)
448 #~(cron-string->calendar-event #$schedule)
449 schedule)
450 (command
451 (list #$(file-append package "/sbin/fstrim")
452 #$@(serialize-fstrim-configuration config)))
453 #:wait-for-termination? #t))
454 (stop #~(make-timer-destructor))
455 (documentation "Periodically run the 'fstrim' command.")
456 (actions (list shepherd-trigger-action))))))
457
458(define fstrim-service-type
459 (service-type
460 (name 'fstrim)
461 (extensions
462 (list (service-extension shepherd-root-service-type
463 fstrim-shepherd-services)))
464 (description "Discard unused blocks from file systems.")
465 (default-value (fstrim-configuration))))
466
467
468;;;
469;;; Kernel module loader.
470;;;
471
472(define kernel-module-loader-shepherd-service
473 (match-lambda
474 ((and (? list? kernel-modules) ((? string?) ...))
475 (shepherd-service
476 (documentation "Load kernel modules.")
477 (provision '(kernel-module-loader))
478 (requirement '(udev))
479 (one-shot? #t)
480 (modules `((srfi srfi-1)
481 (srfi srfi-34)
482 (srfi srfi-35)
483 (rnrs io ports)
484 ,@%default-modules))
485 (start
486 #~(lambda _
487 (cond
488 ((null? '#$kernel-modules) #t)
489 ((file-exists? "/proc/sys/kernel/modprobe")
490 (let ((modprobe (call-with-input-file
491 "/proc/sys/kernel/modprobe" get-line)))
492 (guard (c ((message-condition? c)
493 (format (current-error-port) "~a~%"
494 (condition-message c))
495 #f))
496 (every (lambda (module)
497 (invoke/quiet modprobe "--" module))
498 '#$kernel-modules))))
499 (else
500 (format (current-error-port) "error: ~a~%"
501 "Kernel is missing loadable module support.")
502 #f))))))))
503
504(define kernel-module-loader-service-type
505 (service-type
506 (name 'kernel-module-loader)
507 (description "Load kernel modules.")
508 (extensions
509 (list (service-extension shepherd-root-service-type
510 (compose list kernel-module-loader-shepherd-service))))
511 (compose concatenate)
512 (extend append)
513 (default-value '())))
514
515
516;;;
517;;; Cachefilesd, an FS-Cache daemon
518;;;
519
520(define (serialize-string variable-symbol value)
521 #~(format #f "~a ~a~%" #$(symbol->string variable-symbol) #$value))
522
523(define-maybe string)
524
525(define (non-negative-integer? val)
526 (and (exact-integer? val) (not (negative? val))))
527
528(define (serialize-non-negative-integer variable-symbol value)
529 #~(format #f "~a ~d~%" #$(symbol->string variable-symbol) #$value))
530
531(define-maybe non-negative-integer)
532
533(define (make-option-serializer option-symbol)
534 (lambda (variable-symbol text)
535 (if (maybe-value-set? text)
536 #~(format #f "~a ~a~%" #$(symbol->string option-symbol) #$text)
537 "")))
538
539(define (make-percentage-threshold-serializer threshold-symbol)
540 (lambda (variable-symbol percentage)
541 (if (maybe-value-set? percentage)
542 #~(format #f "~a ~a%~%" #$(symbol->string threshold-symbol) #$percentage)
543 "")))
544
545(define-configuration cachefilesd-configuration
546 (cachefilesd
547 (file-like cachefilesd)
548 "The cachefilesd package to use."
549 (serializer empty-serializer))
550
551 ;; command-line options
552 (debug-output?
553 (boolean #f)
554 "Print debugging output to stderr."
555 (serializer empty-serializer))
556
557 (use-syslog?
558 (boolean #t)
559 "Log to syslog facility instead of stdout."
560 (serializer empty-serializer))
561
562 ;; culling is part of the configuration file
563 ;; despite the name of the command-line option
564 (scan?
565 (boolean #t)
566 "Scan for cacheable objects."
567 (serializer empty-serializer))
568
569 ;; sole required field in the configuration file
570 (cache-directory
571 maybe-string
572 "Location of the cache directory."
573 (serializer (make-option-serializer 'dir)))
574
575 (cache-name
576 (maybe-string "CacheFiles")
577 "Name of cache (keep unique)."
578 (serializer (make-option-serializer 'tag)))
579
580 (security-context
581 maybe-string
582 "SELinux security context."
583 (serializer (make-option-serializer 'secctx)))
584
585 ;; percentage thresholds in the configuration file
586 (pause-culling-for-block-percentage
587 (maybe-non-negative-integer 7)
588 "Pause culling when available blocks exceed this percentage."
589 (serializer (make-percentage-threshold-serializer 'brun)))
590
591 (pause-culling-for-file-percentage
592 (maybe-non-negative-integer 7)
593 "Pause culling when available files exceed this percentage."
594 (serializer (make-percentage-threshold-serializer 'frun)))
595
596 (resume-culling-for-block-percentage
597 (maybe-non-negative-integer 5)
598 "Start culling when available blocks drop below this percentage."
599 (serializer (make-percentage-threshold-serializer 'bcull)))
600
601 (resume-culling-for-file-percentage
602 (maybe-non-negative-integer 5)
603 "Start culling when available files drop below this percentage."
604 (serializer (make-percentage-threshold-serializer 'fcull)))
605
606 (pause-caching-for-block-percentage
607 (maybe-non-negative-integer 1)
608 "Pause further allocations when available blocks drop below this percentage."
609 (serializer (make-percentage-threshold-serializer 'bstop)))
610
611 (pause-caching-for-file-percentage
612 (maybe-non-negative-integer 1)
613 "Pause further allocations when available files drop below this percentage."
614 (serializer (make-percentage-threshold-serializer 'fstop)))
615
616 ;; run time optimizations in the configuration file
617 (log2-table-size
618 (maybe-non-negative-integer 12)
619 "Size of tables holding cullable objects in logarithm of base 2."
620 (serializer (make-option-serializer 'culltable)))
621
622 (cull?
623 (boolean #t)
624 "Create free space by culling (consumes system load)."
625 (serializer
626 (lambda (variable-symbol value)
627 (if value "" "nocull\n"))))
628
629 ;; kernel module debugging in the configuration file
630 (trace-function-entry-in-kernel-module?
631 (boolean #f)
632 "Trace function entry in the kernel module (for debugging)."
633 (serializer empty-serializer))
634
635 (trace-function-exit-in-kernel-module?
636 (boolean #f)
637 "Trace function exit in the kernel module (for debugging)."
638 (serializer empty-serializer))
639
640 (trace-internal-checkpoints-in-kernel-module?
641 (boolean #f)
642 "Trace internal checkpoints in the kernel module (for debugging)."
643 (serializer empty-serializer)))
644
645(define (serialize-cachefilesd-configuration configuration)
646 (mixed-text-file
647 "cachefilesd.conf"
648 (serialize-configuration configuration cachefilesd-configuration-fields)))
649
650(define (cachefilesd-shepherd-service config)
651 "Return a list of <shepherd-service> for cachefilesd for CONFIG."
652 (match-record
653 config <cachefilesd-configuration> (cachefilesd
654 debug-output?
655 use-syslog?
656 scan?
657 cache-directory)
658 (let ((configuration-file (serialize-cachefilesd-configuration config)))
659 (shepherd-service
660 (documentation "Run the cachefilesd daemon for FS-Cache.")
661 (provision '(cachefilesd))
662 (requirement (append '(user-processes file-systems)
663 (if use-syslog? '(syslogd) '())))
664 (start #~(begin
665 (and=> #$(maybe-value cache-directory) mkdir-p)
666 (make-forkexec-constructor
667 `(#$(file-append cachefilesd "/sbin/cachefilesd")
668 ;; do not detach
669 "-n"
670 #$@(if debug-output? '("-d") '())
671 #$@(if use-syslog? '() '("-s"))
672 #$@(if scan? '() '("-N"))
673 "-f" #$configuration-file))))
674 (stop #~(make-kill-destructor))))))
675
676(define cachefilesd-service-type
677 (service-type
678 (name 'cachefilesd)
679 (description
680 "Run the file system cache daemon @command{cachefilesd}, which relies on
681the Linux @code{cachefiles} module.")
682 (extensions
683 (list (service-extension kernel-module-loader-service-type
684 (const '("cachefiles")))
685 (service-extension shepherd-root-service-type
686 (compose list cachefilesd-shepherd-service))))
687 (default-value (cachefilesd-configuration))))
688
689
690;;;
691;;; Reliability, Availability, and Serviceability (RAS) daemon
692;;;
693
694(define-record-type* <rasdaemon-configuration>
695 rasdaemon-configuration make-rasdaemon-configuration
696 rasdaemon-configuration?
697 (record? rasdaemon-configuration-record? (default #f)))
698
699(define (rasdaemon-configuration->command-line-args config)
700 "Translate <rasdaemon-configuration> to its command line arguments
701 representation"
702 (let ((record? (rasdaemon-configuration-record? config)))
703 `(,(file-append rasdaemon "/sbin/rasdaemon")
704 "--foreground" ,@(if record? '("--record") '()))))
705
706(define (rasdaemon-activation config)
707 (let ((record? (rasdaemon-configuration-record? config))
708 (rasdaemon-dir "/var/lib/rasdaemon"))
709 (with-imported-modules '((guix build utils))
710 #~(if #$record? (mkdir-p #$rasdaemon-dir)))))
711
712(define (rasdaemon-shepherd-service config)
713 (shepherd-service
714 (documentation "Run rasdaemon")
715 (provision '(rasdaemon))
716 (requirement '(user-processes syslogd))
717 (start #~(make-forkexec-constructor
718 '#$(rasdaemon-configuration->command-line-args config)))
719 (stop #~(make-kill-destructor))))
720
721(define rasdaemon-service-type
722 (service-type
723 (name 'rasdaemon)
724 (default-value (rasdaemon-configuration))
725 (extensions
726 (list (service-extension shepherd-root-service-type
727 (compose list rasdaemon-shepherd-service))
728 (service-extension activation-service-type rasdaemon-activation)))
729 (compose concatenate)
730 (description "Run @command{rasdaemon}, the RAS monitor")))
731
732
733;;;
734;;; TuneD.
735;;;
736
737(define (uglify-snake-case field-name)
738 "Serializes FIELD-NAME, a field name from @code{(gnu services configuration)},
739to a snake case string representation of the field name. Trailing @code{?} in
740the name are dropped and @code{-} get replaced by @code{_}.
741
742For example the procedure would convert @code{'A-Field?} to @code{\"a_field\"}."
743 (define str (symbol->string field-name))
744 (string-downcase
745 (string-replace-substring
746 (if (string-suffix? "?" str)
747 (string-drop-right str 1)
748 str)
749 "-" "_")))
750
751(define* (tuned-serialize-pair pair #:key (separator "="))
752 (define (valid? member)
753 (or (string? member)
754 (gexp? member)
755 (file-like? member)))
756 (match pair
757 (((? valid? key) . (? valid? value))
758 #~(string-append #$key #$separator #$value))
759 (_
760 (raise
761 (formatted-message
762 (G_ "pair members must contain only strings, gexps or file-like objects
763but ~a was found")
764 pair)))))
765
766(define* (tuned-ppd-serialize-mixed-list name value #:key (separator " = "))
767 (if (zero? (length value))
768 ""
769 #~(string-append "\n[" #$(uglify-snake-case name) "]\n"
770 (string-join
771 (list #$@(map tuned-serialize-pair value)) "\n")
772 "\n")))
773
774(define (mixed-list? value)
775 ;; Expected spec format:
776 ;; '(("name" . "value") "name=value")
777 (for-each
778 (lambda (el)
779 (cond ((string? el) el)
780 ((pair? el) (tuned-serialize-pair el))
781 (else
782 (raise
783 (formatted-message
784 (G_ "members must be either strings or pairs but ~a was
785found!")
786 el)))))
787 value)
788 #t)
789
790(define (tuned-ppd-serialize-string name value)
791 (format #f "~a=~a" (uglify-snake-case name) value))
792
793(define (tuned-ppd-serialize-boolean name value)
794 (format #f "~a=~a" (uglify-snake-case name) (if value "true" "false")))
795
796(define %default-tuned-ppd-settings-profiles
797 '(("power-saver" . "powersave")
798 ("balanced" . "balanced")
799 ("performance" . "throughput-performance")))
800
801(define %default-tuned-ppd-settings-battery
802 '(("balanced" . "balanced-battery")))
803
804(define-configuration tuned-ppd-settings
805 (default
806 (string "balanced")
807 "Default PPD profile.")
808 (battery-detection?
809 (boolean #t)
810 "Whether to enable battery detection.")
811 (sysfs-acpi-monitor?
812 (boolean #t)
813 "Whether to react to changes of ACPI platform profile done via function keys
814(e.g., Fn-L). This is marked upstream as an experimental feature.")
815 (profiles
816 (mixed-list %default-tuned-ppd-settings-profiles)
817 "Map of PPD profiles states to TuneD profiles. It's supposed to be a list of
818pairs, pair members are supposed to be string. It defaults to
819@code{%default-tuned-ppd-settings-profiles}:
820
821@lisp
822'((\"power-saver\" . \"powersave\")
823 (\"balanced\" . \"balanced\")
824 (\"performance\" . \"throughput-performance\"))
825@end lisp
826
827Elements can be pairs or strings. Pair members can be either strings, gexps or
828file like objects. Strings are directly passed to the serializer. This can be
829an escape hatch in case the underlying syntax of the output file changes
830slightly and the Scheme API is not adequated in time. This way there is always
831a way to work around Scheme records.")
832 (battery
833 (mixed-list %default-tuned-ppd-settings-battery)
834 "Map of PPD battery states to TuneD profiles. It's supposed to be a list of
835pairs, pair members are supposed to be string. It defaults to
836@code{%default-tuned-ppd-settings-battery}:
837
838@lisp
839'((\"balanced\" . \"balanced-battery\"))
840@end lisp
841
842Elements can be pairs or strings. Pair members can be either strings, gexps or
843file like objects. Strings are directly passed to the serializer. This can be
844an escape hatch in case the underlying syntax of the output file changes
845slightly and the Scheme API is not adequated in time. This way there is always
846a way to work around Scheme records.")
847 (extra-content
848 (text-config
849 (list (plain-file "tuned-ppd-settings-extra-content" "")))
850 "A list of file-like objects that are appended to the configuration file."
851 (serializer serialize-text-config))
852 (prefix tuned-ppd-))
853
854(define (serialize-tuned-ppd-settings config)
855 (define fields
856 (filter-configuration-fields
857 tuned-ppd-settings-fields
858 '(default battery-detection? sysfs-acpi-monitor? profiles battery
859 extra-content)))
860 (define getters
861 (map configuration-field-getter fields))
862 (define names
863 (map configuration-field-name fields))
864 (define serializers
865 (map configuration-field-serializer fields))
866 (define values
867 (map (match-lambda ((serializer name getter)
868 (serializer name (getter config))))
869 (zip serializers names getters)))
870
871 (match values
872 ((default battery-detection? sysfs-acpi-monitor? profiles battery
873 extra-content)
874
875 (mixed-text-file "ppd.conf"
876 "[main]\n"
877 (string-append default "\n")
878 (string-append battery-detection? "\n")
879 (string-append sysfs-acpi-monitor? "\n")
880 "\n"
881 profiles
882 battery
883 extra-content
884 "\n"))))
885
886(define (serialize-list-of-profile-dirs name value)
887 (if (zero? (length value))
888 ""
889 #~(string-append
890 #$(uglify-snake-case name) " = " (string-join (list #$@value) ","))))
891
892(define (list-of-profile-dirs? value)
893 (for-each
894 (lambda (el)
895 (unless (or (string? el) (file-like? el))
896 (raise
897 (formatted-message
898 (G_ "tuned-settings profile-dirs members must be either a string
899or a file-like object but ~a was found!")
900 el))))
901 value)
902 #t)
903
904(define tuned-serialize-boolean tuned-ppd-serialize-boolean)
905(define tuned-serialize-integer tuned-ppd-serialize-string)
906
907(define-configuration tuned-settings
908 (daemon?
909 (boolean #t)
910 "Whether to use daemon. Without daemon TuneD just applies tuning.")
911 (dynamic-tuning?
912 (boolean #f)
913 "Dynamically tune devices, if disabled only static tuning will be used.")
914 (default-instance-priority
915 (integer 0)
916 "Default priority assigned to instances.")
917 (recommend-command?
918 (boolean #t)
919 "Recommend functionality, if disabled @code{recommend} command will be not
920available in CLI, daemon will not parse @file{recommend.conf} but will return
921one hardcoded profile (by default @code{balanced}).")
922 (sleep-interval
923 (integer 1)
924 "How long to sleep before checking for events (in seconds),
925higher number means lower overhead but longer response time.")
926 (update-interval
927 (integer 10)
928 "Update interval for dynamic tunings (in seconds). It must be a multiple of
929the @code{sleep-interval}.")
930 (profile-dirs
931 (list-of-profile-dirs
932 (list (file-append tuned "/lib/tuned/profiles") "/etc/tuned/profiles"))
933 "List of strings or gexps representing directories to search for
934profiles. In case of collisions in profile names, the latter directory takes
935precedence."
936 (serializer serialize-list-of-profile-dirs))
937 (extra-content
938 (text-config
939 (list (plain-file "tuned-settings-extra-content" "")))
940 "A list of file-like objects that are appended to the configuration file."
941 (serializer serialize-text-config))
942 (prefix tuned-))
943
944(define (serialize-tuned-settings config)
945 (define fields
946 (filter-configuration-fields
947 tuned-settings-fields
948 '(daemon? dynamic-tuning? default-instance-priority
949 recommend-command? sleep-interval update-interval profile-dirs
950 extra-content)))
951 (define getters
952 (map configuration-field-getter fields))
953 (define names
954 (map configuration-field-name fields))
955 (define serializers
956 (map configuration-field-serializer fields))
957 (define values
958 (map (match-lambda ((serializer name getter)
959 (serializer name (getter config))))
960 (zip serializers names getters)))
961
962 (match values
963 ((daemon? dynamic-tuning? default-instance-priority
964 recommend-command? sleep-interval update-interval profile-dirs
965 extra-content)
966 (mixed-text-file
967 "tuned-main.conf"
968 (string-append daemon? "\n\n")
969 (string-append dynamic-tuning? "\n\n")
970 (string-append default-instance-priority "\n\n")
971 (string-append recommend-command? "\n\n")
972 (string-append sleep-interval "\n\n")
973 (string-append update-interval "\n\n")
974 profile-dirs
975 extra-content
976 "\n"))))
977
978(define (tuned-plugin? value)
979 (if (and (= 2 (length value))
980 (string? (first value))
981 (file-like? (second value)))
982 #t
983 (raise
984 (formatted-message
985 (G_ "tuned-configuration profiles members must be lists with two
986elements, the first being a string and the second a file-like object, but ~a was
987found!")
988 value))))
989
990(define (list-of-tuned-plugins? value)
991 (list-of tuned-plugin?))
992
993(define %default-tuned-configuration-recommend.conf
994 (file-append tuned "/lib/tuned/recommend.d/50-tuned.conf"))
995
996(define-configuration/no-serialization tuned-configuration
997 (tuned
998 (package tuned)
999 "The TuneD package.")
1000 (auto-start?
1001 (boolean #t)
1002 "Whether this service should be started automatically by the Shepherd. If it
1003is @code{#f} the service has to be started manually with @command{herd start}.")
1004 (power-profiles-daemon-support?
1005 (boolean #f)
1006 "Whether the power-profiles-daemon emulation layer should be
1007enabled.")
1008 (profiles
1009 (list-of-tuned-plugins '())
1010 "User provided profiles for TuneD. Each element of the list is supposed to be
1011a list where the first element is the name of the directory where plugin files
1012will be placed under @file{/etc/tuned/profiles} and the second a file like
1013object containing the plugin files:
1014
1015@lisp
1016(list
1017 (list \"plugin-name\"
1018 (plain-file \"plugin.conf\" \"content\"))
1019 (list \"other-plugin\"
1020 (file-union \"plugin-data\"
1021 (list (list \"other-plugin.conf\"
1022 (plain-file \"other-plugin.conf\" \"content\"))
1023 (list \"other-plugin.scm\"
1024 (program-file \"other-plugin.scm\"
1025 #~(display \"content\")))))))
1026@end lisp")
1027 (settings
1028 (tuned-settings (tuned-settings))
1029 "Configuration for TuneD.")
1030 (ppd-settings
1031 (tuned-ppd-settings (tuned-ppd-settings))
1032 "Configuration for the @code{power-profiles-daemon} compatibility layer of
1033TuneD.")
1034 (recommend.conf
1035 (file-like %default-tuned-configuration-recommend.conf)
1036 "File like object containing the recommended profile configuration. Defaults
1037to @code{%default-tuned-configuration-recommend.conf}."))
1038
1039(define (tuned-file-systems config)
1040 (list
1041 (file-system
1042 (device "none")
1043 (mount-point "/run/tuned")
1044 (type "ramfs")
1045 (check? #f))))
1046
1047(define (tuned-activation config)
1048 (match-record config <tuned-configuration>
1049 (profiles settings ppd-settings recommend.conf)
1050 #~(begin
1051 (use-modules (guix build utils))
1052 (let ((data-directory "/var/lib/tuned")
1053 (config-directory "/etc/tuned"))
1054 ;; Setup TuneD directories.
1055 (for-each
1056 (lambda (dir)
1057 (mkdir-p dir)
1058 (chmod dir #o755))
1059 (list data-directory config-directory
1060 ;; the directory where TuneD will look for kernel modules for
1061 ;; plugins.
1062 "/etc/tuned/modprobe.d"))
1063 ;; Create plugins kernel modules configuration.
1064 (invoke #$(file-append coreutils-minimal "/bin/touch")
1065 "/etc/tuned/modprobe.d/tuned.conf")
1066 ;; Generate and activate TuneD configuration files.
1067 ;; TuneD needs to write in /etc/tuned, special-files-service-type
1068 ;; creates a file union, so /etc/tuned is read-only and TuneD crashes.
1069 ;; activate-special-files creates a single symlink to the store for
1070 ;; each file so TuneD doesn't notice and runs successfully.
1071 (activate-special-files
1072 '(("/etc/tuned/recommend.conf" #$recommend.conf)
1073 ("/etc/tuned/profiles"
1074 #$(file-union "tuned-profiles" profiles))
1075 ("/etc/tuned/tuned-main.conf"
1076 #$(serialize-tuned-settings settings))
1077 ("/etc/tuned/ppd.conf"
1078 #$(serialize-tuned-ppd-settings ppd-settings))))))))
1079
1080(define (tuned-shepherd-services config)
1081 (match-record config <tuned-configuration>
1082 (tuned auto-start? power-profiles-daemon-support?)
1083 (append
1084 (list
1085 (shepherd-service
1086 (documentation "TuneD daemon")
1087 (provision '(tuned))
1088 (requirement '(dbus-system user-processes udev))
1089 (start #~(make-forkexec-constructor
1090 '(#$(file-append tuned "/sbin/tuned"))
1091 #:log-file "/var/log/tuned/tuned.log"))
1092 (stop #~(make-kill-destructor))
1093 (auto-start? auto-start?)))
1094 (if power-profiles-daemon-support?
1095 (list (shepherd-service
1096 (documentation "TuneD power-profiles-daemon emulation daemon")
1097 (provision '(tuned-ppd power-profiles-daemon))
1098 (requirement '(dbus-system user-processes udev tuned))
1099 (start
1100 #~(make-forkexec-constructor
1101 '(#$(file-append tuned "/sbin/tuned-ppd"))
1102 #:log-file "/var/log/tuned/tuned-ppd.log"))
1103 (stop #~(make-kill-destructor))
1104 (auto-start? auto-start?)))
1105 '()))))
1106
1107(define tuned-service-type
1108 (let ((config->package
1109 (compose list tuned-configuration-tuned)))
1110 (service-type
1111 (name 'tuned)
1112 (extensions (list
1113 (service-extension shepherd-root-service-type
1114 tuned-shepherd-services)
1115 (service-extension dbus-root-service-type
1116 config->package)
1117 (service-extension polkit-service-type
1118 config->package)
1119 (service-extension profile-service-type
1120 config->package)
1121 (service-extension file-system-service-type
1122 tuned-file-systems)
1123 (service-extension activation-service-type
1124 tuned-activation)))
1125 (default-value (tuned-configuration))
1126 (description "Run the TuneD daemon. It is daemon that tunes system settings
1127dynamically. It does so by monitoring the usage of several system components
1128periodically."))))
1129
1130
1131;;;
1132;;; Zram device
1133;;;
1134(define-record-type* <zram-device-configuration>
1135 zram-device-configuration make-zram-device-configuration
1136 zram-device-configuration?
1137 (size zram-device-configuration-size
1138 (default "1G")) ; string or integer
1139 (compression-algorithm zram-device-configuration-compression-algorithm
1140 (default 'lzo)) ; symbol
1141 (memory-limit zram-device-configuration-memory-limit
1142 (default 0)) ; string or integer
1143 (priority zram-device-configuration-priority
1144 (default #f) ; integer | #f
1145 (delayed) ; to avoid printing the deprecation
1146 ; warning multiple times
1147 (sanitize warn-zram-priority-change)))
1148
1149(define-with-syntax-properties
1150 (warn-zram-priority-change (priority properties))
1151 (if (eqv? priority -1)
1152 (begin
1153 (warning (source-properties->location properties)
1154 (G_ "using -1 for zram priority is deprecated~%"))
1155 (display-hint (G_ "Use #f or leave as default instead (@pxref{Linux \
1156Services})."))
1157 #f)
1158 priority))
1159
1160(define (zram-device-configuration->udev-string config)
1161 "Translate a <zram-device-configuration> into a string which can be
1162placed in a udev rules file."
1163 (match config
1164 (($ <zram-device-configuration> size compression-algorithm memory-limit priority)
1165 (string-append
1166 "KERNEL==\"zram0\", "
1167 "ATTR{comp_algorithm}=\"" (symbol->string compression-algorithm) "\" "
1168 (if (not (or (equal? "0" size)
1169 (equal? 0 size)))
1170 (string-append "ATTR{disksize}=\"" (if (number? size)
1171 (number->string size)
1172 size)
1173 "\" ")
1174 "")
1175 (if (not (or (equal? "0" memory-limit)
1176 (equal? 0 memory-limit)))
1177 (string-append "ATTR{mem_limit}=\"" (if (number? memory-limit)
1178 (number->string memory-limit)
1179 memory-limit)
1180 "\" ")
1181 "")
1182 "RUN+=\"/run/current-system/profile/sbin/mkswap /dev/zram0\" "
1183 "RUN+=\"/run/current-system/profile/sbin/swapon "
1184 ;; TODO: Revert to simply use 'priority' after removing the deprecation
1185 ;; warning and the delayed property of the field.
1186 (let ((priority* (force priority)))
1187 (if priority*
1188 (format #f "--priority ~a " priority*)
1189 ""))
1190 "/dev/zram0\"\n"))))
1191
1192(define %zram-device-config
1193 `("modprobe.d/zram.conf"
1194 ,(plain-file "zram.conf"
1195 "options zram num_devices=1")))
1196
1197(define (zram-device-udev-rule config)
1198 (file->udev-rule "99-zram.rules"
1199 (plain-file "99-zram.rules"
1200 (zram-device-configuration->udev-string config))))
1201
1202(define zram-device-service-type
1203 (service-type
1204 (name 'zram)
1205 (default-value (zram-device-configuration))
1206 (extensions
1207 (list (service-extension kernel-module-loader-service-type
1208 (const (list "zram")))
1209 (service-extension etc-service-type
1210 (const (list %zram-device-config)))
1211 (service-extension udev-service-type
1212 (compose list zram-device-udev-rule))))
1213 (description "Creates a zram swap device.")))
1214
1215
1216;;;
1217;;; VFS Mapping.
1218;;;
1219
1220(define-record-type* <vfs-mapping>
1221 vfs-mapping make-vfs-mapping
1222 vfs-mapping?
1223 (source vfs-mapping-source)
1224 (destination vfs-mapping-destination)
1225 (policy vfs-mapping-policy
1226 (default 'translate))
1227 (user vfs-mapping-user
1228 (default #f))
1229 (group vfs-mapping-group
1230 (default "users"))
1231 (name vfs-mapping-name
1232 (default (format #f "~a-on-~a"
1233 (vfs-mapping-policy this-record)
1234 (vfs-mapping-destination this-record)))
1235 (thunked))
1236 (requirement vfs-mapping-requirement
1237 (default '(file-systems user-homes))))
1238
1239(define (vfs-mapping-policy? x)
1240 (and (symbol? x)
1241 (or (memq x '(bind translate overlay)))))
1242
1243(define (path-like? x)
1244 (or (string? x)
1245 (file-like? x)
1246 (gexp? x)))
1247
1248(define (valid-vfs-mapping? x)
1249 ;; User must be set iff we are going to use it
1250 (and (vfs-mapping? x)
1251 (path-like? (vfs-mapping-source x))
1252 (path-like? (vfs-mapping-destination x))
1253 (string? (vfs-mapping-name x))
1254 (vfs-mapping-policy? (vfs-mapping-policy x))
1255 (cond
1256 ((eq? (vfs-mapping-policy x) 'bind)
1257 (not (vfs-mapping-user x)))
1258 (#t
1259 (and (string? (vfs-mapping-user x))
1260 (string? (vfs-mapping-group x)))))))
1261
1262(define list-of-vfs-mapping? (list-of valid-vfs-mapping?))
1263
1264(define-configuration/no-serialization vfs-mapping-configuration
1265 (bindfs (gexp #~(string-append #$bindfs "/bin/bindfs"))
1266 "The bindfs command to use.")
1267 (fusermount (gexp #~(string-append #$fuse-2 "/bin/fusermount"))
1268 "The fusermount command to use.")
1269 (umount (gexp #~(string-append #$util-linux+udev "/bin/umount"))
1270 "The umount command to use.")
1271 (bindings (list-of-vfs-mapping '())
1272 "The list of bindings to mount"))
1273
1274(define vfs-mapping-shepherd-services
1275 (match-record-lambda <vfs-mapping-configuration>
1276 (fusermount bindfs umount bindings)
1277 (map
1278 (match-record-lambda <vfs-mapping>
1279 (source destination policy user group name requirement)
1280 (shepherd-service
1281 ;; Each binding has its own service
1282 (provision (list (string->symbol name)))
1283 ;; Make sure the homes are already present
1284 (requirement requirement)
1285 (modules `((ice-9 match)
1286 ,@%default-modules))
1287 (stop
1288 #~(lambda args
1289 (match (quote #$policy)
1290 ('bind (invoke #$umount #$destination))
1291 ('translate (invoke #$fusermount "-u" #$destination))
1292 ('overlay (begin
1293 ;; First the bindfs
1294 (invoke #$fusermount "-u" #$destination)
1295 ;; then the overlay
1296 (invoke #$umount #$destination))))
1297 #f))
1298 (start
1299 #~(lambda args
1300 (define (mkdir-recursively dir user group)
1301 ;; Like mkdir-p, but chown all created directories to the
1302 ;; specified user.
1303 (unless (eq? dir "/")
1304 (when (not (file-exists? dir))
1305 (mkdir-recursively (dirname dir) user group)
1306 (mkdir dir)
1307 (let* ((pw (getpw user))
1308 (uid (passwd:uid pw))
1309 (gid (passwd:gid pw)))
1310 (chown dir uid gid)))))
1311 (mkdir-recursively #$destination #$user #$group)
1312 (let* ((stat (stat #$source))
1313 (uid (stat:uid stat))
1314 (gid (stat:gid stat))
1315 (source-user
1316 (catch #t
1317 (lambda () (passwd:name (getpwuid uid)))
1318 ;; In case user does not exist failover to plain uid.
1319 (const (number->string uid))))
1320 (source-group
1321 (catch #t
1322 (lambda () (group:name (getgrgid gid)))
1323 ;; In case group does not exist failover to plain gid.
1324 (const (number->string gid)))))
1325 (match (quote #$policy)
1326 ('bind
1327 (mount #$source #$destination
1328 #f ;type
1329 MS_BIND)) ;flags (bind mount)
1330 ('translate
1331 (invoke
1332 #$bindfs
1333 (string-append "--create-for-group=" source-group)
1334 (string-append "--create-for-user=" source-user)
1335 (string-append "--force-user=" #$user)
1336 (string-append "--force-group=" #$group)
1337 "-o" "nonempty"
1338 #$source #$destination))
1339 ('overlay
1340 (let ((overlay (string-append #$destination "-overlay"))
1341 (workdir (string-append #$destination "-workdir")))
1342 (mkdir-recursively overlay #$user #$group)
1343 (mkdir-recursively workdir #$user #$group)
1344 (mount "overlay" ;source
1345 #$destination
1346 "overlay" ;type
1347 0 ;flags
1348 (string-append ;options
1349 "lowerdir=" #$source ","
1350 "upperdir=" overlay ","
1351 "workdir=" workdir))
1352 ;; Remount the target over itself to make it appear as if
1353 ;; owned by user-name and user-group.
1354 (invoke
1355 #$bindfs
1356 (string-append "--create-for-group=" source-group)
1357 (string-append "--create-for-user=" source-user)
1358 (string-append "--force-user=" #$user)
1359 (string-append "--force-group=" #$group)
1360 #$destination #$destination)))))
1361 #t))))
1362 bindings)))
1363
1364(define vfs-mapping-service-type
1365 (service-type
1366 (name 'vfs-mapping)
1367 (extensions (list
1368 (service-extension shepherd-root-service-type
1369 vfs-mapping-shepherd-services)))
1370 (compose concatenate)
1371 (extend (lambda (original extensions)
1372 (vfs-mapping-configuration
1373 (inherit original)
1374 (bindings (append (vfs-mapping-configuration-bindings original)
1375 extensions)))))
1376 (default-value (vfs-mapping-configuration))
1377 (description "Share or expose a file name under a different name.")))