1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
(define-module (atlas combinators)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
#:use-module (ice-9 curried-definitions)
#:use-module (gnu system)
#:use-module ((atlas utils services) #:prefix util:)
#:use-module (gnu system file-systems)
#:use-module (gnu system mapped-devices)
#:use-module (gnu home)
#:export (->
maybe-service
if-host
&s +s
mapped-devices
file-systems
packages
services
swap-devices
users
firmware
setuid-programs
mapped-file-systems
mapped-swap-devices
lvm
hm/packages
hm/services
hm/&s hm/+s))
(define (-> system . services)
(l-> system services))
(define (l-> system services)
(fold (cut <> <>) system services))
(define ((maybe-service predicate service) system)
(if (predicate system) (service system) system))
(define (if-host host . services)
(cute l-> <>
(map
(cute maybe-service
(lambda (system)
(string= host
(operating-system-host-name system)))
<>)
services)))
(define-syntax-rule (&s service ...)
(services (util:&s service ...)))
(define-syntax-rule (+s service ...)
(services (util:+s service ...)))
(define-syntax-rule (hm/&s service ...)
(hm/services (util:&s service ...)))
(define-syntax-rule (hm/+s service ...)
(hm/services (util:+s service ...)))
(define-syntax-rule (simple-system-conser set get)
(define ((set . new) os)
(operating-system
(inherit os)
(set
(append new (get os))))))
(simple-system-conser mapped-devices operating-system-mapped-devices)
(simple-system-conser file-systems operating-system-file-systems)
(simple-system-conser swap-devices operating-system-swap-devices)
(simple-system-conser services operating-system-user-services)
(define ((mapped-file-systems . deps) . fss)
(compose
(apply mapped-devices deps)
(apply file-systems
(map (lambda (fs)
(file-system
(inherit fs)
(dependencies deps)))
fss))))
(define ((mapped-swap-devices . deps) . fss)
(compose
(apply mapped-devices deps)
(apply swap-devices
(map (lambda (fs)
(swap-space
(inherit fs)
(dependencies deps)))
fss))))
(define ((lvm pool) lv)
(mapped-device
(source pool)
(target (string-append pool "-" lv))
(type lvm-device-mapping)))
(define ((hm/services . services) home)
(home-environment
(inherit home)
(services
(append services
(home-environment-user-services home)))))