projects/guix·blob ruby-team · refs

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