guix-home-manager/home.scm

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