projects/guix·blob mpd-fix-groups · refs

791 lines · 30.2 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;;;
12;;; This file is part of GNU Guix.
13;;;
14;;; GNU Guix is free software; you can redistribute it and/or modify it
15;;; under the terms of the GNU General Public License as published by
16;;; the Free Software Foundation; either version 3 of the License, or (at
17;;; your option) any later version.
18;;;
19;;; GNU Guix is distributed in the hope that it will be useful, but
20;;; WITHOUT ANY WARRANTY; without even the implied warranty of
21;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
22;;; GNU General Public License for more details.
23;;;
24;;; You should have received a copy of the GNU General Public License
25;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
26
27(define-module (gnu services linux)
28 #:use-module (guix diagnostics)
29 #:use-module (guix gexp)
30 #:use-module (guix records)
31 #:use-module (guix modules)
32 #:use-module (guix i18n)
33 #:use-module (guix ui)
34 #:use-module (gnu services)
35 #:use-module (gnu services admin)
36 #:use-module (gnu services base)
37 #:use-module (gnu services configuration)
38 #:use-module (gnu services shepherd)
39 #:use-module (gnu packages linux)
40 #:use-module (gnu packages file-systems)
41 #:use-module (srfi srfi-1)
42 #:use-module (srfi srfi-26)
43 #:use-module (srfi srfi-34)
44 #:use-module (srfi srfi-35)
45 #:use-module (srfi srfi-171)
46 #:use-module (ice-9 format)
47 #:use-module (ice-9 match)
48 #:export (earlyoom-configuration
49 earlyoom-configuration?
50 earlyoom-configuration-earlyoom
51 earlyoom-configuration-minimum-available-memory
52 earlyoom-configuration-minimum-free-swap
53 earlyoom-configuration-prefer-regexp
54 earlyoom-configuration-avoid-regexp
55 earlyoom-configuration-memory-report-interval
56 earlyoom-configuration-ignore-positive-oom-score-adj?
57 earlyoom-configuration-show-debug-messages?
58 earlyoom-configuration-send-notification-command
59 earlyoom-service-type
60
61 fstrim-configuration
62 fstrim-configuration?
63 fstrim-configuration-package
64 fstrim-configuration-schedule
65 fstrim-configuration-listed-in
66 fstrim-configuration-verbose?
67 fstrim-configuration-quiet-unsupported?
68 fstrim-configuration-extra-arguments
69 fstrim-service-type
70
71 kernel-module-loader-service-type
72
73 cachefilesd-configuration
74 cachefilesd-configuration?
75 cachefilesd-configuration-cachefilesd
76 cachefilesd-configuration-debug-output?
77 cachefilesd-configuration-use-syslog?
78 cachefilesd-configuration-scan?
79 cachefilesd-configuration-cache-directory
80 cachefilesd-configuration-cache-name
81 cachefilesd-configuration-security-context
82 cachefilesd-configuration-pause-culling-for-block-percentage
83 cachefilesd-configuration-pause-culling-for-file-percentage
84 cachefilesd-configuration-resume-culling-for-block-percentage
85 cachefilesd-configuration-resume-culling-for-file-percentage
86 cachefilesd-configuration-pause-caching-for-block-percentage
87 cachefilesd-configuration-pause-caching-for-file-percentage
88 cachefilesd-configuration-log2-table-size
89 cachefilesd-configuration-cull?
90 cachefilesd-configuration-trace-function-entry-in-kernel-module
91 cachefilesd-configuration-trace-function-exit-in-kernel-module
92 cachefilesd-configuration-trace-internal-checkpoints-in-kernel-module
93 cachefilesd-service-type
94
95 rasdaemon-configuration
96 rasdaemon-configuration?
97 rasdaemon-configuration-record?
98 rasdaemon-service-type
99
100 zram-device-configuration
101 zram-device-configuration?
102 zram-device-configuration-size
103 zram-device-configuration-compression-algorithm
104 zram-device-configuration-memory-limit
105 zram-device-configuration-priority
106 zram-device-service-type
107
108 vfs-mapping-service-type
109 vfs-mapping-configuration
110 vfs-mapping))
111
112
113;;;
114;;; Early OOM daemon.
115;;;
116
117(define-record-type* <earlyoom-configuration>
118 earlyoom-configuration make-earlyoom-configuration
119 earlyoom-configuration?
120 (earlyoom earlyoom-configuration-earlyoom
121 (default earlyoom))
122 (minimum-available-memory earlyoom-configuration-minimum-available-memory
123 (default 10)) ; in percent
124 (minimum-free-swap earlyoom-configuration-minimum-free-swap
125 (default 10)) ; in percent
126 (prefer-regexp earlyoom-configuration-prefer-regexp ; <string>
127 (default #f))
128 (avoid-regexp earlyoom-configuration-avoid-regexp ; <string>
129 (default #f))
130 (memory-report-interval earlyoom-configuration-memory-report-interval
131 (default 0)) ; in seconds; 0 means disabled
132 (ignore-positive-oom-score-adj?
133 earlyoom-configuration-ignore-positive-oom-score-adj? (default #f))
134 (run-with-higher-priority? earlyoom-configuration-run-with-higher-priority?
135 (default #f))
136 (show-debug-messages? earlyoom-configuration-show-debug-messages?
137 (default #f))
138 (send-notification-command
139 earlyoom-configuration-send-notification-command ; <string>
140 (default #f)))
141
142(define (earlyoom-configuration->command-line-args config)
143 "Translate a <earlyoom-configuration> object to its command line arguments
144representation."
145 (match config
146 (($ <earlyoom-configuration> earlyoom minimum-available-memory
147 minimum-free-swap prefer-regexp avoid-regexp
148 memory-report-interval
149 ignore-positive-oom-score-adj?
150 run-with-higher-priority? show-debug-messages?
151 send-notification-command)
152 `(,(file-append earlyoom "/bin/earlyoom")
153 ,@(if minimum-available-memory
154 (list "-m" (format #f "~s" minimum-available-memory))
155 '())
156 ,@(if minimum-free-swap
157 (list "-s" (format #f "~s" minimum-free-swap))
158 '())
159 ,@(if prefer-regexp
160 (list "--prefer" prefer-regexp)
161 '())
162 ,@(if avoid-regexp
163 (list "--avoid" avoid-regexp)
164 '())
165 "-r" ,(format #f "~s" memory-report-interval)
166 ,@(if ignore-positive-oom-score-adj?
167 (list "-i")
168 '())
169 ,@(if run-with-higher-priority?
170 (list "-p")
171 '())
172 ,@(if show-debug-messages?
173 (list "-d")
174 '())
175 ,@(if send-notification-command
176 (list "-N" send-notification-command)
177 '())))))
178
179(define (earlyoom-shepherd-service config)
180 (shepherd-service
181 (documentation "Run the Early OOM daemon.")
182 (provision '(earlyoom))
183 (requirement '(user-processes))
184 (start #~(make-forkexec-constructor
185 '#$(earlyoom-configuration->command-line-args config)
186 #:log-file "/var/log/earlyoom.log"))
187 (stop #~(make-kill-destructor))))
188
189(define earlyoom-service-type
190 (service-type
191 (name 'earlyoom)
192 (default-value (earlyoom-configuration))
193 (extensions
194 (list (service-extension shepherd-root-service-type
195 (compose list earlyoom-shepherd-service))))
196 (description "Run @command{earlyoom}, a daemon that quickly responds to
197@acronym{OOM, out-of-memory} conditions by terminating relevant processes.")))
198
199
200;;;
201;;; fstrim
202;;;
203
204(define (shepherd-calendar-event? x)
205 (or (string? x) (gexp? x)))
206
207(define-maybe list-of-strings (prefix fstrim-))
208
209(define (fstrim-serialize-boolean field-name value)
210 (list (format #f "~:[~;--~a~]" value
211 ;; Drop trailing '?' character.
212 (string-drop-right (symbol->string field-name) 1))))
213
214(define (fstrim-serialize-list-of-strings field-name value)
215 (list (string-append "--" (symbol->string field-name))
216 #~(string-join '#$value ":")))
217
218(define-configuration fstrim-configuration
219 (package
220 (file-like util-linux)
221 "The package providing the @command{fstrim} command."
222 empty-serializer)
223 (schedule
224 (shepherd-calendar-event "0 0 * * 0")
225 "Schedule for launching @command{fstrim}, expressed as a string in
226traditional cron syntax or as a gexp evaluating to a Shepherd calendar
227event (@pxref{Timers,,, shepherd, The GNU Shepherd Manual}). By default this
228is set to run weekly on Sunday at 00:00."
229 empty-serializer)
230 ;; The following are fstrim-related options.
231 (listed-in
232 (maybe-list-of-strings '("/etc/fstab" "/proc/self/mountinfo"))
233 ;; Note: documentation sourced from the fstrim manpage.
234 "List of files in fstab or kernel mountinfo format. All missing or
235empty files are silently ignored. The evaluation of the list @emph{stops}
236after the first non-empty file. File systems with @code{X-fstrim.notrim} mount
237option in fstab are skipped.")
238 (verbose?
239 (boolean #t)
240 "Verbose execution.")
241 (quiet-unsupported?
242 (boolean #t)
243 "Suppress error messages if trim operation (ioctl) is unsupported.")
244 (extra-arguments
245 maybe-list-of-strings
246 "Extra options to append to @command{fstrim} (run @samp{man fstrim} for
247more information)."
248 (serializer
249 (lambda (_ value)
250 (if (maybe-value-set? value)
251 value '()))))
252 (prefix fstrim-))
253
254(define (serialize-fstrim-configuration config)
255 (list-transduce (compose (base-transducer config) tconcatenate)
256 rcons
257 fstrim-configuration-fields))
258
259(define (fstrim-shepherd-services config)
260 (match-record config <fstrim-configuration>
261 (package schedule)
262 (list (shepherd-service
263 (provision '(fstrim))
264 (requirement '(user-processes))
265 (modules '((shepherd service timer)))
266 (start #~(make-timer-constructor
267 #$(if (string? schedule)
268 #~(cron-string->calendar-event #$schedule)
269 schedule)
270 (command
271 (list #$(file-append package "/sbin/fstrim")
272 #$@(serialize-fstrim-configuration config)))
273 #:wait-for-termination? #t))
274 (stop #~(make-timer-destructor))
275 (documentation "Periodically run the 'fstrim' command.")
276 (actions (list shepherd-trigger-action))))))
277
278(define fstrim-service-type
279 (service-type
280 (name 'fstrim)
281 (extensions
282 (list (service-extension shepherd-root-service-type
283 fstrim-shepherd-services)))
284 (description "Discard unused blocks from file systems.")
285 (default-value (fstrim-configuration))))
286
287
288;;;
289;;; Kernel module loader.
290;;;
291
292(define kernel-module-loader-shepherd-service
293 (match-lambda
294 ((and (? list? kernel-modules) ((? string?) ...))
295 (shepherd-service
296 (documentation "Load kernel modules.")
297 (provision '(kernel-module-loader))
298 (requirement '(udev))
299 (one-shot? #t)
300 (modules `((srfi srfi-1)
301 (srfi srfi-34)
302 (srfi srfi-35)
303 (rnrs io ports)
304 ,@%default-modules))
305 (start
306 #~(lambda _
307 (cond
308 ((null? '#$kernel-modules) #t)
309 ((file-exists? "/proc/sys/kernel/modprobe")
310 (let ((modprobe (call-with-input-file
311 "/proc/sys/kernel/modprobe" get-line)))
312 (guard (c ((message-condition? c)
313 (format (current-error-port) "~a~%"
314 (condition-message c))
315 #f))
316 (every (lambda (module)
317 (invoke/quiet modprobe "--" module))
318 '#$kernel-modules))))
319 (else
320 (format (current-error-port) "error: ~a~%"
321 "Kernel is missing loadable module support.")
322 #f))))))))
323
324(define kernel-module-loader-service-type
325 (service-type
326 (name 'kernel-module-loader)
327 (description "Load kernel modules.")
328 (extensions
329 (list (service-extension shepherd-root-service-type
330 (compose list kernel-module-loader-shepherd-service))))
331 (compose concatenate)
332 (extend append)
333 (default-value '())))
334
335
336;;;
337;;; Cachefilesd, an FS-Cache daemon
338;;;
339
340(define (serialize-string variable-symbol value)
341 #~(format #f "~a ~a~%" #$(symbol->string variable-symbol) #$value))
342
343(define-maybe string)
344
345(define (non-negative-integer? val)
346 (and (exact-integer? val) (not (negative? val))))
347
348(define (serialize-non-negative-integer variable-symbol value)
349 #~(format #f "~a ~d~%" #$(symbol->string variable-symbol) #$value))
350
351(define-maybe non-negative-integer)
352
353(define (make-option-serializer option-symbol)
354 (lambda (variable-symbol text)
355 (if (maybe-value-set? text)
356 #~(format #f "~a ~a~%" #$(symbol->string option-symbol) #$text)
357 "")))
358
359(define (make-percentage-threshold-serializer threshold-symbol)
360 (lambda (variable-symbol percentage)
361 (if (maybe-value-set? percentage)
362 #~(format #f "~a ~a%~%" #$(symbol->string threshold-symbol) #$percentage)
363 "")))
364
365(define-configuration cachefilesd-configuration
366 (cachefilesd
367 (file-like cachefilesd)
368 "The cachefilesd package to use."
369 (serializer empty-serializer))
370
371 ;; command-line options
372 (debug-output?
373 (boolean #f)
374 "Print debugging output to stderr."
375 (serializer empty-serializer))
376
377 (use-syslog?
378 (boolean #t)
379 "Log to syslog facility instead of stdout."
380 (serializer empty-serializer))
381
382 ;; culling is part of the configuration file
383 ;; despite the name of the command-line option
384 (scan?
385 (boolean #t)
386 "Scan for cacheable objects."
387 (serializer empty-serializer))
388
389 ;; sole required field in the configuration file
390 (cache-directory
391 maybe-string
392 "Location of the cache directory."
393 (serializer (make-option-serializer 'dir)))
394
395 (cache-name
396 (maybe-string "CacheFiles")
397 "Name of cache (keep unique)."
398 (serializer (make-option-serializer 'tag)))
399
400 (security-context
401 maybe-string
402 "SELinux security context."
403 (serializer (make-option-serializer 'secctx)))
404
405 ;; percentage thresholds in the configuration file
406 (pause-culling-for-block-percentage
407 (maybe-non-negative-integer 7)
408 "Pause culling when available blocks exceed this percentage."
409 (serializer (make-percentage-threshold-serializer 'brun)))
410
411 (pause-culling-for-file-percentage
412 (maybe-non-negative-integer 7)
413 "Pause culling when available files exceed this percentage."
414 (serializer (make-percentage-threshold-serializer 'frun)))
415
416 (resume-culling-for-block-percentage
417 (maybe-non-negative-integer 5)
418 "Start culling when available blocks drop below this percentage."
419 (serializer (make-percentage-threshold-serializer 'bcull)))
420
421 (resume-culling-for-file-percentage
422 (maybe-non-negative-integer 5)
423 "Start culling when available files drop below this percentage."
424 (serializer (make-percentage-threshold-serializer 'fcull)))
425
426 (pause-caching-for-block-percentage
427 (maybe-non-negative-integer 1)
428 "Pause further allocations when available blocks drop below this percentage."
429 (serializer (make-percentage-threshold-serializer 'bstop)))
430
431 (pause-caching-for-file-percentage
432 (maybe-non-negative-integer 1)
433 "Pause further allocations when available files drop below this percentage."
434 (serializer (make-percentage-threshold-serializer 'fstop)))
435
436 ;; run time optimizations in the configuration file
437 (log2-table-size
438 (maybe-non-negative-integer 12)
439 "Size of tables holding cullable objects in logarithm of base 2."
440 (serializer (make-option-serializer 'culltable)))
441
442 (cull?
443 (boolean #t)
444 "Create free space by culling (consumes system load)."
445 (serializer
446 (lambda (variable-symbol value)
447 (if value "" "nocull\n"))))
448
449 ;; kernel module debugging in the configuration file
450 (trace-function-entry-in-kernel-module?
451 (boolean #f)
452 "Trace function entry in the kernel module (for debugging)."
453 (serializer empty-serializer))
454
455 (trace-function-exit-in-kernel-module?
456 (boolean #f)
457 "Trace function exit in the kernel module (for debugging)."
458 (serializer empty-serializer))
459
460 (trace-internal-checkpoints-in-kernel-module?
461 (boolean #f)
462 "Trace internal checkpoints in the kernel module (for debugging)."
463 (serializer empty-serializer)))
464
465(define (serialize-cachefilesd-configuration configuration)
466 (mixed-text-file
467 "cachefilesd.conf"
468 (serialize-configuration configuration cachefilesd-configuration-fields)))
469
470(define (cachefilesd-shepherd-service config)
471 "Return a list of <shepherd-service> for cachefilesd for CONFIG."
472 (match-record
473 config <cachefilesd-configuration> (cachefilesd
474 debug-output?
475 use-syslog?
476 scan?
477 cache-directory)
478 (let ((configuration-file (serialize-cachefilesd-configuration config)))
479 (shepherd-service
480 (documentation "Run the cachefilesd daemon for FS-Cache.")
481 (provision '(cachefilesd))
482 (requirement (append '(user-processes file-systems)
483 (if use-syslog? '(syslogd) '())))
484 (start #~(begin
485 (and=> #$(maybe-value cache-directory) mkdir-p)
486 (make-forkexec-constructor
487 `(#$(file-append cachefilesd "/sbin/cachefilesd")
488 ;; do not detach
489 "-n"
490 #$@(if debug-output? '("-d") '())
491 #$@(if use-syslog? '() '("-s"))
492 #$@(if scan? '() '("-N"))
493 "-f" #$configuration-file))))
494 (stop #~(make-kill-destructor))))))
495
496(define cachefilesd-service-type
497 (service-type
498 (name 'cachefilesd)
499 (description
500 "Run the file system cache daemon @command{cachefilesd}, which relies on
501the Linux @code{cachefiles} module.")
502 (extensions
503 (list (service-extension kernel-module-loader-service-type
504 (const '("cachefiles")))
505 (service-extension shepherd-root-service-type
506 (compose list cachefilesd-shepherd-service))))
507 (default-value (cachefilesd-configuration))))
508
509
510;;;
511;;; Reliability, Availability, and Serviceability (RAS) daemon
512;;;
513
514(define-record-type* <rasdaemon-configuration>
515 rasdaemon-configuration make-rasdaemon-configuration
516 rasdaemon-configuration?
517 (record? rasdaemon-configuration-record? (default #f)))
518
519(define (rasdaemon-configuration->command-line-args config)
520 "Translate <rasdaemon-configuration> to its command line arguments
521 representation"
522 (let ((record? (rasdaemon-configuration-record? config)))
523 `(,(file-append rasdaemon "/sbin/rasdaemon")
524 "--foreground" ,@(if record? '("--record") '()))))
525
526(define (rasdaemon-activation config)
527 (let ((record? (rasdaemon-configuration-record? config))
528 (rasdaemon-dir "/var/lib/rasdaemon"))
529 (with-imported-modules '((guix build utils))
530 #~(if #$record? (mkdir-p #$rasdaemon-dir)))))
531
532(define (rasdaemon-shepherd-service config)
533 (shepherd-service
534 (documentation "Run rasdaemon")
535 (provision '(rasdaemon))
536 (requirement '(user-processes syslogd))
537 (start #~(make-forkexec-constructor
538 '#$(rasdaemon-configuration->command-line-args config)))
539 (stop #~(make-kill-destructor))))
540
541(define rasdaemon-service-type
542 (service-type
543 (name 'rasdaemon)
544 (default-value (rasdaemon-configuration))
545 (extensions
546 (list (service-extension shepherd-root-service-type
547 (compose list rasdaemon-shepherd-service))
548 (service-extension activation-service-type rasdaemon-activation)))
549 (compose concatenate)
550 (description "Run @command{rasdaemon}, the RAS monitor")))
551
552
553;;;
554;;; Zram device
555;;;
556(define-record-type* <zram-device-configuration>
557 zram-device-configuration make-zram-device-configuration
558 zram-device-configuration?
559 (size zram-device-configuration-size
560 (default "1G")) ; string or integer
561 (compression-algorithm zram-device-configuration-compression-algorithm
562 (default 'lzo)) ; symbol
563 (memory-limit zram-device-configuration-memory-limit
564 (default 0)) ; string or integer
565 (priority zram-device-configuration-priority
566 (default #f) ; integer | #f
567 (delayed) ; to avoid printing the deprecation
568 ; warning multiple times
569 (sanitize warn-zram-priority-change)))
570
571(define-with-syntax-properties
572 (warn-zram-priority-change (priority properties))
573 (if (eqv? priority -1)
574 (begin
575 (warning (source-properties->location properties)
576 (G_ "using -1 for zram priority is deprecated~%"))
577 (display-hint (G_ "Use #f or leave as default instead (@pxref{Linux \
578Services})."))
579 #f)
580 priority))
581
582(define (zram-device-configuration->udev-string config)
583 "Translate a <zram-device-configuration> into a string which can be
584placed in a udev rules file."
585 (match config
586 (($ <zram-device-configuration> size compression-algorithm memory-limit priority)
587 (string-append
588 "KERNEL==\"zram0\", "
589 "ATTR{comp_algorithm}=\"" (symbol->string compression-algorithm) "\" "
590 (if (not (or (equal? "0" size)
591 (equal? 0 size)))
592 (string-append "ATTR{disksize}=\"" (if (number? size)
593 (number->string size)
594 size)
595 "\" ")
596 "")
597 (if (not (or (equal? "0" memory-limit)
598 (equal? 0 memory-limit)))
599 (string-append "ATTR{mem_limit}=\"" (if (number? memory-limit)
600 (number->string memory-limit)
601 memory-limit)
602 "\" ")
603 "")
604 "RUN+=\"/run/current-system/profile/sbin/mkswap /dev/zram0\" "
605 "RUN+=\"/run/current-system/profile/sbin/swapon "
606 ;; TODO: Revert to simply use 'priority' after removing the deprecation
607 ;; warning and the delayed property of the field.
608 (let ((priority* (force priority)))
609 (if priority*
610 (format #f "--priority ~a " priority*)
611 ""))
612 "/dev/zram0\"\n"))))
613
614(define %zram-device-config
615 `("modprobe.d/zram.conf"
616 ,(plain-file "zram.conf"
617 "options zram num_devices=1")))
618
619(define (zram-device-udev-rule config)
620 (file->udev-rule "99-zram.rules"
621 (plain-file "99-zram.rules"
622 (zram-device-configuration->udev-string config))))
623
624(define zram-device-service-type
625 (service-type
626 (name 'zram)
627 (default-value (zram-device-configuration))
628 (extensions
629 (list (service-extension kernel-module-loader-service-type
630 (const (list "zram")))
631 (service-extension etc-service-type
632 (const (list %zram-device-config)))
633 (service-extension udev-service-type
634 (compose list zram-device-udev-rule))))
635 (description "Creates a zram swap device.")))
636
637
638;;;
639;;; VFS Mapping.
640;;;
641
642(define-record-type* <vfs-mapping>
643 vfs-mapping make-vfs-mapping
644 vfs-mapping?
645 (source vfs-mapping-source)
646 (destination vfs-mapping-destination)
647 (policy vfs-mapping-policy
648 (default 'translate))
649 (user vfs-mapping-user
650 (default #f))
651 (group vfs-mapping-group
652 (default "users"))
653 (name vfs-mapping-name
654 (default (format #f "~a-on-~a"
655 (vfs-mapping-policy this-record)
656 (vfs-mapping-destination this-record)))
657 (thunked))
658 (requirement vfs-mapping-requirement
659 (default '(file-systems user-homes))))
660
661(define (vfs-mapping-policy? x)
662 (and (symbol? x)
663 (or (memq x '(bind translate overlay)))))
664
665(define (path-like? x)
666 (or (string? x)
667 (file-like? x)
668 (gexp? x)))
669
670(define (valid-vfs-mapping? x)
671 ;; User must be set iff we are going to use it
672 (and (vfs-mapping? x)
673 (path-like? (vfs-mapping-source x))
674 (path-like? (vfs-mapping-destination x))
675 (string? (vfs-mapping-name x))
676 (vfs-mapping-policy? (vfs-mapping-policy x))
677 (cond
678 ((eq? (vfs-mapping-policy x) 'bind)
679 (not (vfs-mapping-user x)))
680 (#t
681 (and (string? (vfs-mapping-user x))
682 (string? (vfs-mapping-group x)))))))
683
684(define list-of-vfs-mapping? (list-of valid-vfs-mapping?))
685
686(define-configuration/no-serialization vfs-mapping-configuration
687 (bindfs (gexp #~(string-append #$bindfs "/bin/bindfs"))
688 "The bindfs command to use.")
689 (fusermount (gexp #~(string-append #$fuse-2 "/bin/fusermount"))
690 "The fusermount command to use.")
691 (umount (gexp #~(string-append #$util-linux+udev "/bin/umount"))
692 "The umount command to use.")
693 (bindings (list-of-vfs-mapping '())
694 "The list of bindings to mount"))
695
696(define vfs-mapping-shepherd-services
697 (match-record-lambda <vfs-mapping-configuration>
698 (fusermount bindfs umount bindings)
699 (map
700 (match-record-lambda <vfs-mapping>
701 (source destination policy user group name requirement)
702 (shepherd-service
703 ;; Each binding has its own service
704 (provision (list (string->symbol name)))
705 ;; Make sure the homes are already present
706 (requirement requirement)
707 (modules `((ice-9 match)
708 ,@%default-modules))
709 (stop
710 #~(lambda args
711 (match (quote #$policy)
712 ('bind (invoke #$umount #$destination))
713 ('translate (invoke #$fusermount "-u" #$destination))
714 ('overlay (begin
715 ;; First the bindfs
716 (invoke #$fusermount "-u" #$destination)
717 ;; then the overlay
718 (invoke #$umount #$destination))))
719 #f))
720 (start
721 #~(lambda args
722 (define (mkdir-recursively dir user group)
723 ;; Like mkdir-p, but chown all created directories to the
724 ;; specified user.
725 (unless (eq? dir "/")
726 (when (not (file-exists? dir))
727 (mkdir-recursively (dirname dir) user group)
728 (mkdir dir)
729 (let* ((pw (getpw user))
730 (uid (passwd:uid pw))
731 (gid (passwd:gid pw)))
732 (chown dir uid gid)))))
733 (mkdir-recursively #$destination #$user #$group)
734 (let* ((stat (stat #$source))
735 (uid (stat:uid stat))
736 (gid (stat:gid stat))
737 (source-user (passwd:name (getpwuid uid)))
738 (source-group (group:name (getgrgid gid))))
739 (match (quote #$policy)
740 ('bind
741 (mount #$source #$destination
742 #f ;type
743 MS_BIND)) ;flags (bind mount)
744 ('translate
745 (invoke
746 #$bindfs
747 (string-append "--create-for-group=" source-group)
748 (string-append "--create-for-user=" source-user)
749 (string-append "--force-user=" #$user)
750 (string-append "--force-group=" #$group)
751 "-o" "nonempty"
752 #$source #$destination))
753 ('overlay
754 (let ((overlay (string-append #$destination "-overlay"))
755 (workdir (string-append #$destination "-workdir")))
756 (mkdir-recursively overlay #$user #$group)
757 (mkdir-recursively workdir #$user #$group)
758 (mount "overlay" ;source
759 #$destination
760 "overlay" ;type
761 0 ;flags
762 (string-append ;options
763 "lowerdir=" #$source ","
764 "upperdir=" overlay ","
765 "workdir=" workdir))
766 ;; Remount the target over itself to make it appear as if
767 ;; owned by user-name and user-group.
768 (invoke
769 #$bindfs
770 (string-append "--create-for-group=" source-group)
771 (string-append "--create-for-user=" source-user)
772 (string-append "--force-user=" #$user)
773 (string-append "--force-group=" #$group)
774 #$destination #$destination)))))
775 #t))))
776 bindings)))
777
778(define vfs-mapping-service-type
779 (service-type
780 (name 'vfs-mapping)
781 (extensions (list
782 (service-extension shepherd-root-service-type
783 vfs-mapping-shepherd-services)))
784 (compose concatenate)
785 (extend (lambda (original extensions)
786 (vfs-mapping-configuration
787 (inherit original)
788 (bindings (append (vfs-mapping-configuration-bindings original)
789 extensions)))))
790 (default-value (vfs-mapping-configuration))
791 (description "Share or expose a file name under a different name.")))