home.scm
1 | ;;; Guix Home Manager. |
2 | ;;; |
3 | ;;; Copyright © 2019 Julien Lepiller <julien@lepiller.eu> |
4 | ;;; |
5 | ;;; This program is free software: you can redistribute it and/or modify |
6 | ;;; it under the terms of the GNU General Public License as published by |
7 | ;;; the Free Software Foundation, either version 3 of the License, or |
8 | ;;; (at your option) any later version. |
9 | ;;; |
10 | ;;; This program is distributed in the hope that it will be useful, |
11 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
12 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
13 | ;;; GNU General Public License for more details. |
14 | ;;; |
15 | ;;; You should have received a copy of the GNU General Public License |
16 | ;;; along with this program. If not, see <http://www.gnu.org/licenses/>. |
17 | |
18 | (define-module (home) |
19 | #:use-module (guix build union) |
20 | #:use-module (guix build utils) |
21 | #:use-module (guix build-system trivial) |
22 | #:use-module (guix gexp) |
23 | #:use-module (guix licenses) |
24 | #:use-module (guix packages) |
25 | #:use-module (guix records) |
26 | #:use-module (guix ui) |
27 | #:use-module (guix utils) |
28 | #:use-module (ice-9 match) |
29 | #:use-module (ice-9 vlist) |
30 | #:use-module (home build utils) |
31 | #:use-module (srfi srfi-1) |
32 | #:use-module (srfi srfi-9) |
33 | #:use-module (srfi srfi-35) |
34 | #:export (use-home-modules |
35 | home |
36 | home? |
37 | home-data-directory |
38 | home-configurations |
39 | home-location |
40 | home-guix-symlink |
41 | home-guix-config-symlink |
42 | home-local-symlink |
43 | home-cache-symlink |
44 | home->derivation |
45 | |
46 | user-home |
47 | user-home-type |
48 | user-home-value |
49 | |
50 | home-type |
51 | home-type? |
52 | home-type-name |
53 | home-type-extensions |
54 | home-type-extension-points |
55 | home-type-default-value |
56 | home-type-description |
57 | home-type-location |
58 | |
59 | home-extension |
60 | home-extension? |
61 | home-extension-target |
62 | home-extension-target-point |
63 | home-extension-compute |
64 | |
65 | home-extension-point |
66 | home-extension-point? |
67 | home-extension-point-name |
68 | home-extension-point-compose |
69 | home-extension-point-extend |
70 | |
71 | root-home-type)) |
72 | |
73 | ;;; |
74 | ;;; Service-like home configuration mechanism |
75 | ;;; |
76 | |
77 | (define &no-default-value |
78 | '(no default value)) |
79 | |
80 | (define-record-type* <home-extension> home-extension make-home-extension |
81 | home-extension? |
82 | (target home-extension-target ; home-type |
83 | (default #f)) |
84 | (point home-extension-target-point ; symbol |
85 | (default #f)) |
86 | ;; A function that takes the user-home value as parameter and returns the |
87 | ;; value to be passed to the extension point. |
88 | (compute home-extension-compute)) |
89 | |
90 | (define-record-type* <home-extension-point> home-extension-point |
91 | make-home-extension-point home-extension-point? |
92 | (name home-extension-point-name ; symbol |
93 | (default #f)) |
94 | ;; A function that composes extensions. It is passed a list of extension values |
95 | ;; and returns one extension value |
96 | (compose home-extension-point-compose) |
97 | ;; A function that extends the original service value with the result of |
98 | ;; the composition. It is passed two arguments: the user-home value and the |
99 | ;; result of the composition. It returns a new user-home value. |
100 | (extend home-extension-point-extend)) ; any(value) -> any(compose) -> any(value) |
101 | |
102 | (define-record-type* <home-type> home-type make-home-type |
103 | home-type? |
104 | (name home-type-name) ; symbol |
105 | (extensions home-type-extensions ; list home-extension |
106 | (default #f)) |
107 | (extension-points home-type-extension-points ; list home-extension-point |
108 | (default #f)) |
109 | (default-value home-type-default-value ; any |
110 | (default &no-default-value)) |
111 | (description home-type-description ; string |
112 | (default #f)) |
113 | (location home-type-location |
114 | (default (and=> (current-source-location) |
115 | source-properties->location)) |
116 | (innate))) |
117 | |
118 | (define-record-type <user-home> |
119 | (make-user-home type value) |
120 | user-home? |
121 | (type user-home-type) |
122 | (value user-home-value)) |
123 | |
124 | (define-syntax user-home |
125 | (syntax-rules () |
126 | "Return a user-home instance of TYPE. The user-home value is VALUE or, if |
127 | omitted, TYPE's default value." |
128 | ((_ type value) |
129 | (make-user-home type value)) |
130 | ((_ type) |
131 | (%user-home-with-default-value (current-source-location) |
132 | type)))) |
133 | |
134 | (define (%user-home-with-default-value location type) |
135 | "Return an instance of user-home type TYPE with its default value, if any. If |
136 | TYPE does not have a default value, an error is raised." |
137 | ;; TODO: Currently this is a run-time error but with a little bit macrology |
138 | ;; we could turn it into an expansion-time error. |
139 | (let ((default (home-type-default-value type))) |
140 | (if (eq? default &no-default-value) |
141 | (let ((location (source-properties->location location))) |
142 | (raise |
143 | (condition |
144 | (&missing-value-home-error (type type) (location location)) |
145 | (&message |
146 | (message (format #f (G_ "~a: no value specified \ |
147 | for home configuration of type '~a'") |
148 | (location->string location) |
149 | (home-type-name type))))))) |
150 | (make-user-home type default)))) |
151 | |
152 | (define-condition-type &home-error &error |
153 | home-error?) |
154 | |
155 | (define-condition-type &missing-value-home-error &home-error |
156 | missing-value-home-error? |
157 | (type missing-value-home-error-type) |
158 | (location missing-value-home-error-location)) |
159 | |
160 | (define-condition-type &missing-target-home-error &home-error |
161 | missing-target-home-error? |
162 | (home missing-target-home-error-home) |
163 | (target-type missing-target-home-error-target-type)) |
164 | |
165 | (define-condition-type &ambiguous-target-home-error &home-error |
166 | ambiguous-target-home-error? |
167 | (home missing-target-home-error-home) |
168 | (target-type missing-target-home-error-target-type)) |
169 | |
170 | (define root-home-type |
171 | (home-type |
172 | (name 'root) |
173 | (extension-points |
174 | (list (home-extension-point |
175 | (compose (lambda (l) (apply append l))) |
176 | (extend (lambda (v l) (apply append v l)))))) |
177 | (default-value '()) |
178 | (description "The root home type"))) |
179 | |
180 | ;;; |
181 | ;;; Home composition |
182 | ;;; |
183 | |
184 | (define (missing-target-error home target-type) |
185 | (raise |
186 | (condition (&missing-target-home-error |
187 | (home home) |
188 | (target-type target-type)) |
189 | (&message |
190 | (message |
191 | (format #f (G_ "no target of type '~a' for home configuration '~a'") |
192 | (home-type-name target-type) |
193 | (home-type-name |
194 | (user-home-type home)))))))) |
195 | |
196 | (define (home-back-edges homes) |
197 | "Return a procedure which, when passed a user-home from HOMES, returns the |
198 | list of <user-home> that extend it." |
199 | (define (add-edges home edges) |
200 | (define (add-edge extension edges) |
201 | (define (add-extension-edge target edges) |
202 | (vhash-consq target home edges)) |
203 | (let ((target-type (home-extension-target extension)) |
204 | (target-point (home-extension-target-point extension))) |
205 | (match (filter |
206 | (lambda (home) |
207 | (if target-type |
208 | (eq? (user-home-type home) target-type) |
209 | (and target-point |
210 | (not (null? (filter |
211 | (lambda (extension-point) |
212 | (eq? |
213 | (home-extension-point-name extension-point) |
214 | target-point)) |
215 | (home-type-extension-points |
216 | (user-home-type home)))))))) |
217 | homes) |
218 | ((target ...) |
219 | (fold add-extension-edge edges target)) |
220 | (() |
221 | (missing-target-error home target-type))))) |
222 | (let ((extensions (home-type-extensions (user-home-type home)))) |
223 | (if extensions |
224 | (fold add-edge edges (home-type-extensions (user-home-type home))) |
225 | edges))) |
226 | |
227 | (let ((edges (fold add-edges vlist-null homes))) |
228 | (lambda (node) |
229 | (reverse (vhash-foldq* cons '() node edges))))) |
230 | |
231 | (define (instantiate-missing-user-homes homes) |
232 | "Return HOMES, a list of user-home, augmented with any user-home targeted by |
233 | extensions and missing from HOMES. Only home types with a default value can |
234 | be instantiated; other missing user-homes lead to a '&missing-target-home-error'." |
235 | (let loop ((homes homes)) |
236 | (define (not-present? target) |
237 | (let ((target-type (home-extension-target target))) |
238 | (and target-type |
239 | (null? (filter (lambda (home) |
240 | (eq? (user-home-type home) target-type)) |
241 | homes))))) |
242 | (define additions |
243 | (append-map |
244 | (lambda (home) |
245 | (let ((extensions (home-type-extensions (user-home-type home)))) |
246 | (if extensions |
247 | (map (lambda (extension) (home-extension-target extension)) |
248 | (filter not-present? extensions)) |
249 | '()))) |
250 | homes)) |
251 | |
252 | (define (uniq lst) |
253 | (let loop ((types lst) (result '())) |
254 | (match types |
255 | ((type types ...) |
256 | (if (member type types) |
257 | (loop types result) |
258 | (loop types (cons type result)))) |
259 | (() result)))) |
260 | |
261 | (define generated |
262 | (map |
263 | (lambda (type) |
264 | (let ((default (home-type-default-value type))) |
265 | (if (eq? default &no-default-value) |
266 | (missing-target-error #f target-type) |
267 | (make-user-home type default)))) |
268 | (uniq additions))) |
269 | |
270 | (if (null? generated) |
271 | homes |
272 | (loop (append homes generated))))) |
273 | |
274 | (define (fold-home target-type homes) |
275 | "fold HOMES by successively resolving extension points, until we get only |
276 | one user-home of type TARGET-TYPE." |
277 | (define dependents |
278 | (home-back-edges homes)) |
279 | |
280 | (define (apply-extension target) |
281 | (define (update-extension extensions point home) |
282 | (let* ((point-name (home-extension-point-name point)) |
283 | (matched-extensions |
284 | (filter (lambda (extension) |
285 | (if point-name |
286 | (eq? (home-extension-target-point extension) |
287 | point-name) |
288 | (eq? (home-extension-target extension) |
289 | (user-home-type target)))) |
290 | (home-type-extensions (user-home-type home))))) |
291 | (if (null? matched-extensions) |
292 | extensions |
293 | (append |
294 | (map |
295 | (lambda (extension) |
296 | `(,point-name ,((home-extension-compute extension) |
297 | (user-home-value home)))) |
298 | matched-extensions) |
299 | extensions)))) |
300 | (lambda (home) |
301 | (let loop ((extensions '()) (points (home-type-extension-points |
302 | (user-home-type target)))) |
303 | (match points |
304 | (() extensions) |
305 | ((point points ...) |
306 | (loop |
307 | (update-extension extensions point home) |
308 | points)))))) |
309 | |
310 | (define (merge-extensions points extensions) |
311 | (let loop ((points points) (extensions extensions)) |
312 | (match points |
313 | (() extensions) |
314 | (((point value) points ...) |
315 | (loop points (acons point |
316 | (let ((v (assoc-ref extensions point))) |
317 | (if v (cons value v) (list value))) |
318 | extensions)))))) |
319 | |
320 | (define (compose-extension target) |
321 | (lambda (extension) |
322 | (match extension |
323 | ((point-name values ...) |
324 | (match (filter |
325 | (lambda (extension-point) |
326 | (eq? (home-extension-point-name extension-point) point-name)) |
327 | (home-type-extension-points (user-home-type target))) |
328 | ((point) |
329 | (list |
330 | point-name |
331 | ((home-extension-point-compose point) |
332 | values)))))))) |
333 | |
334 | (match (filter (lambda (home) |
335 | (eq? (user-home-type home) target-type)) |
336 | homes) |
337 | ((sink) |
338 | (let loop ((sink sink)) |
339 | (let* ((dependents (map loop (dependents sink))) |
340 | (extensions (map (apply-extension sink) dependents)) |
341 | (extensions (fold merge-extensions '() extensions)) |
342 | (extensions (map (compose-extension sink) extensions))) |
343 | (user-home |
344 | (user-home-type sink) |
345 | (let ((extension-points (home-type-extension-points (user-home-type sink)))) |
346 | (if extension-points |
347 | (fold (lambda (extension-point value) |
348 | (let* ((extend (home-extension-point-extend extension-point)) |
349 | (name (home-extension-point-name extension-point)) |
350 | (extension-value (assoc-ref extensions name))) |
351 | (if extension-value |
352 | (extend value extension-value) |
353 | value))) |
354 | (user-home-value sink) |
355 | (home-type-extension-points (user-home-type sink))) |
356 | (user-home-value sink))))))) |
357 | (() |
358 | (raise |
359 | (condition (&missing-target-home-error |
360 | (home #f) |
361 | (target-type target-type)) |
362 | (&message |
363 | (message (format #f (G_ "home configuration of type '~a' not found") |
364 | (home-type-name target-type))))))) |
365 | (x |
366 | (raise |
367 | (condition (&ambiguous-target-home-error |
368 | (home #f) |
369 | (target-type target-type)) |
370 | (&message |
371 | (message (format #f (G_ "home configuration of type '~a' not found") |
372 | (home-type-name target-type))))))))) |
373 | |
374 | ;;; |
375 | ;;; Home generation |
376 | ;;; |
377 | |
378 | (define-syntax use-home-modules |
379 | (syntax-rules () |
380 | ((_ modules ...) |
381 | (use-modules (home modules) ...)))) |
382 | |
383 | (define-record-type* <home> home |
384 | make-home |
385 | home? |
386 | (data-directory home-data-directory) |
387 | (base-configuration home-base-configuration (thunked) |
388 | (default |
389 | (base-home-configuration |
390 | (guix-symlink |
391 | (string-append (home-data-directory this-record) "/.guix-profile")) |
392 | (guix-config-symlink |
393 | (string-append (home-data-directory this-record) "/.config/guix")) |
394 | (local-symlink |
395 | (string-append (home-data-directory this-record) "/.local")) |
396 | (cache-symlink |
397 | (string-append (home-data-directory this-record) "/.cache"))))) |
398 | (configurations home-configurations |
399 | (default (list (user-home root-home-type)))) |
400 | (location home-location |
401 | (default (and=> (current-source-location) |
402 | source-properties->location)) |
403 | (innate))) |
404 | |
405 | (define-record-type* <base-home-configuration> base-home-configuration |
406 | make-base-home-configuration |
407 | base-home-configuration? |
408 | (guix-symlink base-home-configuration-guix-symlink) |
409 | (guix-config-symlink base-home-configuration-guix-config-symlink) |
410 | (local-symlink base-home-configuration-local-symlink) |
411 | (cache-symlink base-home-configuration-cache-symlink)) |
412 | |
413 | (define base-home-type |
414 | (home-type |
415 | (name 'guix) |
416 | (extensions |
417 | (list |
418 | (home-extension |
419 | (target root-home-type) |
420 | (compute (lambda (config) |
421 | `((".guix-profile" |
422 | ,(base-home-configuration-guix-symlink config)) |
423 | (".config/guix" |
424 | ,(base-home-configuration-guix-config-symlink config)) |
425 | (".local" |
426 | ,(base-home-configuration-local-symlink config)) |
427 | (".cache" |
428 | ,(base-home-configuration-cache-symlink config)))))))))) |
429 | |
430 | (define (home->derivation home) |
431 | (define builder |
432 | (with-imported-modules |
433 | '((guix build utils) (home build utils) (ice-9 match)) |
434 | #~(begin |
435 | (use-modules (guix build utils) (home build utils) (ice-9 match)) |
436 | #$(let* ((homes (instantiate-missing-user-homes |
437 | (cons |
438 | (user-home base-home-type (home-base-configuration home)) |
439 | (home-configurations home)))) |
440 | (root (fold-home root-home-type homes)) |
441 | (configs (user-home-value root))) |
442 | #~(for-each |
443 | (lambda (config) |
444 | (match config |
445 | ((home-name target) |
446 | (mkdir-p (dirname (home-file #$output home-name))) |
447 | (symlink target (home-file #$output home-name))))) |
448 | '(#$@configs)))))) |
449 | (gexp->derivation "home" builder |
450 | #:substitutable? #f |
451 | #:local-build? #t)) |
452 |