~abcdw/rde

ref: 1b08f117bd6c63c4f998b743dd8741d66b77767e rde/rde/features.scm -rw-r--r-- 10.0 KiB
1b08f117Andrew Tropin rde: system: Add initrd and -modules arguments to feature-kernel 1 year, 23 days ago
                                                                                
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
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
(define-module (rde features)
  #:use-module (guix records)
  #:use-module (guix ui)
  #:use-module (gnu services)
  #:use-module (gnu system)
  #:use-module (gnu system file-systems)
  #:use-module (gnu system accounts)
  #:use-module (gnu system shadow)
  #:use-module (gnu bootloader)
  #:use-module (gnu bootloader grub)
  #:use-module (gnu home)
  #:use-module (gnu services configuration)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)

  #:use-module (ice-9 hash-table)
  #:use-module (ice-9 pretty-print)

  #:export (rde-config
	    rde-config-features
	    rde-config-home-environment
	    rde-config-operating-system
	    rde-config-home-services
	    rde-config-system-services

	    pretty-print-rde-config

	    feature
	    feature-name
	    feature-values
	    feature-home-services-getter
	    feature-system-services-getter

	    make-feature-values
	    require-value
	    get-value

	    ensure-pred
	    throw-message

	    bare-bone-os))

(define (alist? lst)
  (every pair? lst))

(define (services-getter? fn)
  (procedure? fn))

(define-configuration feature
  (name
   (symbol)
   "Name for feature to identify it in debug messages.")
  (values
   (alist '())
   "List of pairs avaliable to share across services.")
  (home-services-getter
   (services-getter (const '()))
   "Function taking one argument (@code{values}) and returning a list
of services.  Service can be either @code{service?} or
@code{#f}. Resulting list will be appended to home environment.")
  (system-services-getter
   (services-getter (const '()))
   "Function taking one argument (@code{values}) and returning a list
of services.  Service can be either @code{service?} or
@code{#f}. Resulting list will be appended to operating system.")
  (no-serialization))

(define-record-type* <rde-config> rde-config
  make-rde-config
  rde-config?
  this-rde-config

  (features rde-config-features
	    (default '()))

  (values
   rde-config-values
   (thunked)
   (default
     (fold-values
      (rde-config-features this-rde-config))))

  (values-alist
   rde-config-values-alist
   (thunked)
   (default
     ;; Doesn't ensure that there is no duplicates in values.  This
     ;; field is inteded for debugging/development purposes.
     (apply append
	    (map feature-values
		 (rde-config-features this-rde-config)))))

  (home-services
   rde-config-home-services
   (thunked)
   (default
     (fold-home-services
      (rde-config-features this-rde-config)
      this-rde-config)))
  (home-environment
   rde-config-home-environment
   (thunked)
   (default
     (get-home-environment this-rde-config)))

  (initial-os
   rde-config-initial-os
   (default bare-bone-os))
  (system-services
   rde-config-system-services
   (thunked)
   (default
     (fold-system-services
      (rde-config-features this-rde-config)
      this-rde-config)))
  (operating-system
   rde-config-operating-system
   (thunked)
   (default
     (get-operating-system this-rde-config))))


(define-syntax ensure-pred
  (syntax-rules ()
    ((ensure-pred pred field)
     (when (not (pred field)) 
       (raise (condition
               (&message
		(message
		 (format
		  #f (G_ "~a: The predicate '~a' is not satisfied with value '~a'.")
		  'field
		  (procedure-name pred)
		  field)))))))))

(define-syntax throw-message
  (syntax-rules ()
    ((throw-message pred msg)
     (when pred 
       (raise (condition
               (&message
		(message
		 msg))))))))

(define-syntax make-feature-values
  (syntax-rules ()
    ((provide-values field ...)
     `((field . ,field) ...))))


(define (fold-values features)
  (let ((f-values (apply append (map feature-values features))))
    (fold
     (lambda (feature acc)
       (fold
	(lambda (x acc)
	  (throw-message
	   (hash-get-handle acc (car x))
	   (format #f (G_ "Duplicate entry came from ~a feature:\n~a\n
The previous value was:\n~a\n")
		   (feature-name feature)
		   x
		   (hash-get-handle acc (car x))))
	  (hash-set! acc (car x) (cdr x))
	  acc)
	acc
	(feature-values feature))
       acc)
     (make-hash-table)
     features)))

(define (print-values features)
  (hash-for-each-handle pretty-print
			(fold-values features)))

(define (fold-some-services features config services-getter)
  (filter service?
	  (apply append
		 (map (lambda (f)
			((services-getter f) config))
		      features))))

(define (fold-home-services features config)
  "Generates a list of home-services from FEATURES by passing CONFIG
to each home-services-getter function."
  (fold-some-services features config feature-home-services-getter))

(define (fold-system-services features config)
  "Generates a list of system-services from FEATURES by passing CONFIG
to each system-services-getter function."
  (fold-some-services features config feature-system-services-getter))


(define* (get-value key config #:optional default-value)
  "Get KEY from rde-config-values."
  (let ((handle (hash-get-handle (rde-config-values config) key)))
    (if handle
	(cdr handle)
	default-value)))

(define* (require-value key config #:optional (additional-msg #f))
  (throw-message
   (not (hash-get-handle (rde-config-values config) key))
   (format
    #f "Value ~a is not provided by any feature.\n~a"
    key (or (and=> additional-msg (lambda (x) (string-append x "\n"))) ""))))

(use-modules (gnu home services)
             (gnu home services xdg)
             (gnu home services fontutils)
             (gnu home services symlink-manager)
             (gnu home-services shells))
(define (get-home-environment config)
  (home-environment
   (essential-services
    (list
     (service home-run-on-first-login-service-type)
     (service home-activation-service-type)
     (service home-environment-variables-service-type)

     (service home-symlink-manager-service-type)

     (service home-fontconfig-service-type)
     (service home-xdg-base-directories-service-type)
     (service home-shell-profile-service-type)

     (service home-service-type)
     (service home-profile-service-type '())))
   (services (rde-config-home-services config))))

(define bare-bone-os
  (operating-system
   (host-name "antelope")
   (timezone  "Europe/Paris")
   (locale  "en_US.utf8")
   (bootloader (bootloader-configuration
		(bootloader grub-efi-bootloader)
		(targets '("/boot/efi"))))
   (services '())
   (file-systems %base-file-systems)))

(define (get-operating-system config)
  (let* ((initial-os (rde-config-initial-os config))

	 (host-name        (get-value
			    'host-name config
			    (operating-system-host-name initial-os)))
	 (timezone         (get-value
			    'timezone config
			    (operating-system-timezone initial-os)))
	 (keyboard-layout  (get-value
			    'keyboard-layout config
			    (operating-system-keyboard-layout initial-os)))
	 (bootloader-cfg   (get-value
			    'bootloader-configuration config
			    (operating-system-bootloader initial-os)))
	 (bootloader       (bootloader-configuration
			    (inherit bootloader-cfg)
			    (keyboard-layout keyboard-layout)))
	 (mapped-devices   (get-value
			    'mapped-devices config
			    (operating-system-mapped-devices initial-os)))
	 (file-systems     (get-value
			    'file-systems config
			    (operating-system-file-systems initial-os)))

	 (user-name        (get-value 'user-name config))
	 (full-name        (get-value 'full-name config ""))
	 (user-groups      (get-value 'user-groups config '()))
	 (home-directory   (get-value
			    'home-directory config
			    (string-append "/home/" (or user-name "user"))))
	 (login-shell      (get-value 'login-shell config (default-shell)))
	 (user-password    (get-value 'user-initial-password-hash config #f))

	 (users            (if user-name
			       (cons
			        (user-account
			   	 (name user-name)
			   	 (comment full-name)
			   	 (password user-password)
			   	 (home-directory home-directory)
			   	 (shell login-shell)
			   	 (group "users")
			   	 (supplementary-groups
                                  (append
                                   '("wheel" "netdev" "audio" "video")
                                   ;; MAYBE: Reimplement user-account creation
                                   ;; using service, to make it possible
                                   ;; to extend it with supplimentary groups
                                   (if (get-value 'docker config)
                                       '("docker") '())
                                   user-groups)))
			        %base-user-accounts)
			       (operating-system-users initial-os)))

	 (services         (rde-config-system-services config))

	 (kernel           (get-value
			    'kernel config
			    (operating-system-kernel initial-os)))
	 (kernel-arguments (get-value
			    'kernel-arguments config
			    (operating-system-user-kernel-arguments initial-os)))
	 (kernel-modules   (get-value
			    'kernel-loadable-modules config
			    (operating-system-kernel-loadable-modules initial-os)))
	 (initrd           (get-value
			    'initrd config
			    (operating-system-initrd initial-os)))
	 (initrd-modules   (get-value
			    'initrd-modules config
			    (operating-system-initrd-modules initial-os)))
	 (firmware         (get-value
			    'firmware config
			    (operating-system-firmware initial-os))))

    (operating-system
      (inherit initial-os)
      (host-name host-name)
      (timezone timezone)
      (bootloader bootloader)
      (mapped-devices mapped-devices)
      (file-systems file-systems)
      (users users)
      (keyboard-layout keyboard-layout)
      (kernel kernel)
      (kernel-arguments kernel-arguments)
      (kernel-loadable-modules kernel-modules)
      (initrd initrd)
      (initrd-modules initrd-modules)
      (firmware firmware)
      (services services))))

(define (pretty-print-rde-config config)
  (use-modules (gnu services)
	       (ice-9 pretty-print))
  (pretty-print
   (rde-config-values-alist
    config))
  (pretty-print
   (map service-kind
	(rde-config-home-services
	 config)))
  (pretty-print
   (map service-kind
	(rde-config-system-services
	 config))))

;; (pretty-print-rde-config
;;  (rde-config
;;   (features my-features)))

;; (rde-config-home-environment my-cfg)