home: Add fold-home.

Julien LepillerThu Sep 19 14:03:44+0200 2019

2896a00

home: Add fold-home. * home.scm (fold-home): New procedure. (user-home, home-type, home-extension, home-extension-point) (base-home-configuration): New data types. (root-home-type): New variable. * doc: Update every document to the new home-type syntax. * home/hexchat.scm (hexchat-home-type): New variable. * home/keepassxc.scm (keepassxc-home-type): New variable. * home/openbox.scm (openbox-home-type): New variable. * home/ssh.scm (ssh-home-type): New variable. * home/utils.scm (simple-file-home, symlink-file-home): Return a user-home.

doc/README.md

3939 
(home
4040 
  (data-directory "/data/alice")
4141 
  (configurations
42-
    (list (something-home ...)
43-
          (something-else-home ...)
44-
          (other-stuff-home ...)
45-
          (yet-another-config-home ...)
46-
          ...)))
42+
    (list
43+
      (user-home something-home-type ...)
44+
      (user-home something-else-home-type ...)
45+
      (user-home other-stuff-home-type ...)
46+
      (user-home yet-another-config-home-type ...)
47+
      ...)))
4748 
```
4849 
4950 
#### Desktop and Window Managers
doc/general.md
2222 
(simple-file-home (local-file "gitconfig") ".gitconfig")
2323 
```
2424 
25-
**Scheme Procedure**: (symlink-file-home from to)
25+
**Scheme Procedure**: (symlink-file-home to from)
2626 
2727 
Create a symlink from the user home at _from_ that points to _to_. For instance,
2828 
if you want to create a symlink to a file that can change over time, you can
doc/hexchat.md
1111 
------------------
1212 
1313 
The main configuration is not complete compared to the configuration possibilities
14-
of the client. It currently only implements a very minimal set of configurations
14+
of the client.  It currently only implements a very minimal set of configurations
1515 
that are required for it to work properly.
1616 
17-
**Scheme Procedure**: (hexchat-home config)
17+
**Scheme Variable**: hexchat-home-type
1818 
19-
Generates configuration files for hexchat, according to config, an
20-
hexchat-configuration object.
19+
The type of the service that generates configuration files for hexchat.  Its
20+
value is an hexchat-configuration object.
2121 
2222 
**Data Type**: hexchat-configuration
2323 
…
3333 
-------
3434 
3535 
```scheme
36-
(hexchat-home
37-
	(hexchat-configuration
38-
	  (servlist
39-
	    (list
40-
	      (hexchat-server
41-
	        (name "R??zosup")
42-
	        (servers '("irc.rezosup.org/6697"))
43-
	        (flags '(cycle global honor-proxy ssl favorite
44-
	                 allow-invalid-certificates)))))
45-
	  (log-dir "/data/alice/.local/share/hexchat/logs")
46-
	  (scrollback-dir "/data/alice/.local/share/hexchat/scrollback")))
36+
(user-home
37+
  hexchat-home-type
38+
  (hexchat-configuration
39+
    (servlist
40+
      (list
41+
        (hexchat-server
42+
          (name "R??zosup")
43+
          (servers '("irc.rezosup.org/6697"))
44+
          (flags '(cycle global honor-proxy ssl favorite
45+
                   allow-invalid-certificates)))))
46+
    (log-dir "/data/alice/.local/share/hexchat/logs")
47+
    (scrollback-dir "/data/alice/.local/share/hexchat/scrollback")))
4748 
```
4849 
4950 
…
7475 
  automatically connect to this network when hexchat is started, _honor-proxy_
7576 
  to honor system-wide proxy configuration, _allow-invalid-certificates_ to
7677 
  allow invalid certificates (self-signed, expired, ...) and _favorite_ to add
77-
  it to the list of favorite networks.
77>
780>
\ No newline at end of file
78+
  it to the list of favorite networks.
doc/home.md
3232 
             (home hexchat))
3333 
```
3434 
35-
**Scheme Procedure**: (home basedir inputs #:guix-symlink #:guix-config-symlink #:local-symlink #:cache-symlink))
35+
**Data Type**: home
3636 
37-
Create a package that can then be installed with `guix package -f` from _inputs_
38-
and essential configuration. _inputs_ must be a list of inputs, namely a list
39-
of file-like objects. The resulting package is a union of all the inputs, with
40-
the addition of a few essential symlinks.
37+
This data type represents the configuration of a home directory.  It is the
38+
type of the data a home configuration file must return.  It is composed of
39+
the following fields:
4140 
42-
By default, when no input is given, and no keyword argument is used, these
43-
symlinks are created:
41+
* **data-directory**: The read-write directory that contains the user files.
42+
* **base-configuration** (default: a base-home-configuration object that takes
43+
    the data-directory value into account, see below): A base-home-configuration
44+
    object that contains configuration for required parts of the home configuration.
45+
* **configurations** (default: '()): A list of additional configurations.
46+
47+
By default, when no base-configuration is given, the configuration contains
48+
instructions for these symlinks to be created:
4449 
4550 
* `~/.guix-profile` ??? `${basedir}/.guix-profile`
4651 
* `~/.config/guix` ??? `${basedir}/.config/guix`
4752 
* `~/.local` ??? `${basedir}/.local`
4853 
* `~/.cache` ??? `${basedir}/.cache`
4954 
50-
When the corresponding keyword argument is used, the associated path is used as
51-
the target of the symbolic link.
51>
520>
\ No newline at end of file
55+
**Data Type**: base-home-configuration
56+
57+
This is the type of a basic home directory configuration that contains information
58+
for basic required configurations.  It contains the following fields:
59+
60+
* **guix-symlink**: The path to the default guix profile, in a read-write directory.
61+
* **guix-config-symlink**: The path to the configuration directory of guix.
62+
* **local-symlink**: The path to a read-write directory that corresponds to the
63+
    .local directory.
64+
* **cache-symlink**: The path to a read-write directory that corresponds to the
65+
    .cache directory.
66+
67+
**Scheme Variable**: root-home-type
68+
69+
The type of the root service, to which every service is folded.  Its value
70+
is an association list that associates paths relative to the home directory
71+
with a path in the filesystem or a file-like object.
72+
73+
It also contains a default extension point, whose value must be an association
74+
list that is concatenated to the already configured association list.
doc/keepassxc.md
1313 
of keepassxc.  It currently implemets most of the configuration, but excludes
1414 
a few difficult parts.
1515 
16-
**Scheme Procedure**: (keepassxc-home config)
16+
**Scheme Variable**: keepassxc-home-type
1717 
18-
Generates a configuration file for keepassxc, according to config, a
19-
keepassxc-configuration object.
18+
The type of the service that generates a configuration file for keepassxc.  Its
19+
value is a keepassxc-configuration object.
2020 
2121 
**Data Type**: keepassxc-configuration
2222 
…
5555 
-------
5656 
5757 
```scheme
58-
(keepassxc-home
58+
(user-home
59+
  keepassxc-home-type
5960 
  (keepassxc-configuration
6061 
    (last-databases '("/data/alice/pass.kbdx"))
6162 
    (last-dir "/data/alice")
doc/openbox.md
88 
Main Configuration
99 
------------------
1010 
11-
Openbox is configured by using the `openbox-home` procedure.
11+
Openbox is configured by using the `openbox-home-type` service type.
1212 
13-
**Scheme Procedure**: (openbox-home config)
13+
**Scheme Procedure**: openbox-home-type
1414 
15-
Generates configuration files for openbox, according to config, an
16-
openbox-configuration object.
15+
The type of service that generates configuration files for openbox.  Its value
16+
is an openbox-configuration object.
1717 
1818 
**Data Type**: openbox-configuration
1919 
…
3434 
---------------------
3535 
3636 
```scheme
37-
(openbox-home
37+
(user-home
38+
  openbox-home-type
3839 
  (openbox-configuration
3940 
    (autostart (local-file "files/autostart"))
4041 
    (menus
…
9798 
* **label**: a label shown in the parent menu that executes this element
9899 
* **command**: the command to execute when the user clicks on this menu element.
99100 
  It can be a string or a g-expression, as seen in the first example.
100-
* **notify?** (default #t): whether to use startupnotify
100>
1010>
\ No newline at end of file
101+
* **notify?** (default #t): whether to use startupnotify
doc/ssh.md
88 
------------------
99 
1010 
The main configuration is not complete compared to the configuration possibilities
11-
of the client. It however implements a big part of the possibilities.
11+
of the client.  It however implements a big part of the possibilities.
1212 
13-
**Scheme Procedure**: (ssh-home config)
13+
**Scheme Variable**: ssh-home-type
1414 
15-
Generates configuration files for OpenSSH, according to config, an
16-
ssh-configuration object.
15+
The type of service that generates configuration files for OpenSSH.  Its value
16+
is an ssh-configuration object.
1717 
1818 
**Data Type**: ssh-configuration
1919 
…
3636 
-------
3737 
3838 
```scheme
39-
(ssh-home
39+
(user-home
40+
  ssh-home-type
4041 
  (ssh-configuration
4142 
    (authorized-keys '("ssh-rsa ... alice@computilo"))
4243 
    (known-hosts
home.scm
2323 
  #:use-module (guix licenses)
2424 
  #:use-module (guix packages)
2525 
  #:use-module (guix records)
26+
  #:use-module (guix ui)
27+
  #:use-module (guix utils)
2628 
  #:use-module (ice-9 match)
29+
  #:use-module (ice-9 vlist)
2730 
  #:use-module (home build utils)
31+
  #:use-module (srfi srfi-1)
32+
  #:use-module (srfi srfi-9)
33+
  #:use-module (srfi srfi-35)
2834 
  #:export (use-home-modules
2935 
            home
3036 
            home?
…
3339 
            home-guix-config-symlink
3440 
            home-local-symlink
3541 
            home-cache-symlink
36-
            home->derivation))
42+
            home->derivation
43+
            
44+
            user-home
45+
            user-home-type
46+
            user-home-value
47+
            
48+
            home-type
49+
            home-type?
50+
            home-type-name
51+
            home-type-extensions
52+
            home-type-extension-points
53+
            home-type-default-value
54+
            home-type-description
55+
            home-type-location
56+
            
57+
            home-extension
58+
            home-extension?
59+
            home-extension-target
60+
            home-extension-target-point
61+
            home-extension-compute
62+
            
63+
            home-extension-point
64+
            home-extension-point?
65+
            home-extension-point-name
66+
            home-extension-point-compose
67+
            home-extension-point-extend
68+
            
69+
            root-home-type))
70+
71+
;;;
72+
;;; Service-like home configuration mechanism
73+
;;;
74+
75+
(define &no-default-value
76+
  '(no default value))
77+
78+
(define-record-type* <home-extension> home-extension make-home-extension
79+
  home-extension?
80+
  (target home-extension-target ; home-type
81+
          (default #f))
82+
  (point  home-extension-target-point ; symbol
83+
          (default #f))
84+
  ;; A function that takes the user-home value as parameter and returns the
85+
  ;; value to be passed to the extension point.
86+
  (compute  home-extension-compute))
87+
88+
(define-record-type* <home-extension-point> home-extension-point
89+
  make-home-extension-point home-extension-point?
90+
  (name home-extension-point-name ; symbol
91+
        (default #f))
92+
  ;; A function that composes extensions. It is passed a list of extension values
93+
  ;; and returns one extension value
94+
  (compose home-extension-point-compose)
95+
  ;; A function that extends the original service value with the result of
96+
  ;; the composition.  It is passed two arguments: the user-home value and the
97+
  ;; result of the composition.  It returns a new user-home value.
98+
  (extend home-extension-point-extend)) ; any(value) -> any(compose) -> any(value)
99+
100+
(define-record-type* <home-type> home-type make-home-type
101+
  home-type?
102+
  (name             home-type-name) ; symbol
103+
  (extensions       home-type-extensions ; list home-extension
104+
                    (default #f))
105+
  (extension-points home-type-extension-points ; list home-extension-point
106+
                    (default #f))
107+
  (default-value    home-type-default-value ; any
108+
                    (default &no-default-value))
109+
  (description      home-type-description ; string
110+
                    (default #f))
111+
  (location         home-type-location
112+
                    (default (and=> (current-source-location)
113+
                                    source-properties->location))
114+
                    (innate)))
115+
116+
(define-record-type <user-home>
117+
  (make-user-home type value)
118+
  user-home?
119+
  (type  user-home-type)
120+
  (value user-home-value))
121+
122+
(define-syntax user-home
123+
  (syntax-rules ()
124+
    "Return a user-home instance of TYPE.  The user-home value is VALUE or, if
125+
omitted, TYPE's default value."
126+
    ((_ type value)
127+
     (make-user-home type value))
128+
    ((_ type)
129+
     (%user-home-with-default-value (current-source-location)
130+
                                    type))))
131+
132+
(define (%user-home-with-default-value location type)
133+
  "Return an instance of user-home type TYPE with its default value, if any.  If
134+
TYPE does not have a default value, an error is raised."
135+
  ;; TODO: Currently this is a run-time error but with a little bit macrology
136+
  ;; we could turn it into an expansion-time error.
137+
  (let ((default (home-type-default-value type)))
138+
    (if (eq? default &no-default-value)
139+
        (let ((location (source-properties->location location)))
140+
          (raise
141+
           (condition
142+
            (&missing-value-home-error (type type) (location location))
143+
            (&message
144+
             (message (format #f (G_ "~a: no value specified \
145+
for home configuration of type '~a'")
146+
                              (location->string location)
147+
                              (home-type-name type)))))))
148+
        (user-home type default))))
149+
150+
(define-condition-type &home-error &error
151+
  home-error?)
152+
153+
(define-condition-type &missing-value-home-error &home-error
154+
  missing-value-home-error?
155+
  (type     missing-value-home-error-type)
156+
  (location missing-value-home-error-location))
157+
158+
(define-condition-type &missing-target-home-error &home-error
159+
   missing-target-home-error?
160+
   (home         missing-target-home-error-home)
161+
   (target-type  missing-target-home-error-target-type))
162+
163+
(define-condition-type &ambiguous-target-home-error &home-error
164+
   ambiguous-target-home-error?
165+
   (home         missing-target-home-error-home)
166+
   (target-type  missing-target-home-error-target-type))
167+
168+
(define root-home-type
169+
  (home-type
170+
    (name 'root)
171+
    (extension-points
172+
      (list (home-extension-point
173+
          (compose (lambda (l) (apply append l)))
174+
          (extend (lambda (v l) (apply append v l))))))
175+
    (default-value '())
176+
    (description "The root home type")))
177+
178+
;;;
179+
;;; Home composition
180+
;;;
181+
182+
(define (missing-target-error home target-type)
183+
  (raise
184+
    (condition (&missing-target-home-error
185+
                 (home home)
186+
                 (target-type target-type))
187+
               (&message
188+
                 (message
189+
                   (format #f (G_ "no target of type '~a' for home configuration '~a'")
190+
                           (home-type-name target-type)
191+
                           (home-type-name
192+
                             (user-home-type home))))))))
193+
194+
(define (home-back-edges homes)
195+
  "Return a procedure which, when passed a user-home from HOMES, returns the
196+
list of <user-home> that extend it."
197+
  (define (add-edges home edges)
198+
    (define (add-edge extension edges)
199+
      (define (add-extension-edge target edges)
200+
        (vhash-consq target home edges))
201+
      (let ((target-type (home-extension-target extension))
202+
            (target-point (home-extension-target-point extension)))
203+
        (match (filter
204+
                 (lambda (home)
205+
                   (if target-type
206+
                       (eq? (user-home-type home) target-type)
207+
                       (and target-point
208+
                            (not (null? (filter
209+
                                          (lambda (extension-point)
210+
                                            (eq?
211+
                                              (home-extension-point-name extension-point)
212+
                                              target-point))
213+
                                          (home-type-extension-points
214+
                                            (user-home-type home))))))))
215+
                 homes)
216+
          ((target ...)
217+
           (fold add-extension-edge edges target))
218+
          (()
219+
           (missing-target-error home target-type)))))
220+
    (let ((extensions (home-type-extensions (user-home-type home))))
221+
      (if extensions
222+
        (fold add-edge edges (home-type-extensions (user-home-type home)))
223+
        edges)))
224+
225+
  (let ((edges (fold add-edges vlist-null homes)))
226+
    (lambda (node)
227+
      (reverse (vhash-foldq* cons '() node edges)))))
228+
229+
(define (instantiate-missing-user-homes homes)
230+
  "Return HOMES, a list of user-home, augmented with any user-home targeted by
231+
extensions and missing from HOMES.  Only home types with a default value can
232+
be instantiated; other missing user-homes lead to a '&missing-target-home-error'."
233+
  (let loop ((homes homes))
234+
    (define (not-present? target)
235+
      (let ((target-type (home-extension-target target)))
236+
        (and target-type
237+
            (null? (filter (lambda (home)
238+
                             (eq? (user-home-type home) target-type))
239+
                           homes)))))
240+
    (define additions
241+
      (append-map
242+
        (lambda (home)
243+
          (let ((extensions (home-type-extensions (user-home-type home))))
244+
            (if extensions
245+
              (map (lambda (extension) (home-extension-target extension))
246+
                   (filter not-present? extensions))
247+
              '())))
248+
        homes))
249+
250+
    (define (uniq lst)
251+
      (let loop ((types lst) (result '()))
252+
        (match types
253+
          ((type types ...)
254+
           (if (member type types)
255+
               (loop types result)
256+
               (loop types (cons type result))))
257+
          (() result))))
258+
259+
    (define generated
260+
      (map
261+
        (lambda (type)
262+
          (let ((default (home-type-default-value type)))
263+
            (if (eq? default &no-default-value)
264+
                (missing-target-error home target-type)
265+
                (user-home type default))))
266+
        (uniq additions)))
267+
268+
    (if (null? generated)
269+
        homes
270+
        (loop (append homes generated)))))
271+
272+
(define (fold-home target-type homes)
273+
  "fold HOMES by successively resolving extension points, until we get only
274+
one user-home of type TARGET-TYPE."
275+
  (define dependents
276+
    (home-back-edges homes))
277+
  
278+
  (define (apply-extension target)
279+
    (define (update-extension extensions point home)
280+
      (let* ((point-name (home-extension-point-name point))
281+
             (matched-extensions
282+
               (filter (lambda (extension)
283+
                         (if point-name
284+
                             (eq? (home-extension-target-point extension)
285+
                                  point-name)
286+
                             (eq? (home-extension-target extension)
287+
                                  (user-home-type target))))
288+
                       (home-type-extensions (user-home-type home)))))
289+
        (if (null? matched-extensions)
290+
            extensions
291+
            (append
292+
              (map
293+
                (lambda (extension)
294+
                  `(,point-name ,((home-extension-compute extension)
295+
                                  (user-home-value home))))
296+
                matched-extensions)
297+
              extensions))))
298+
    (lambda (home)
299+
      (let loop ((extensions '()) (points (home-type-extension-points
300+
                                            (user-home-type target))))
301+
        (match points
302+
          (() extensions)
303+
          ((point points ...)
304+
           (loop
305+
             (update-extension extensions point home)
306+
             points))))))
307+
308+
  (define (merge-extensions points extensions)
309+
    (let loop ((points points) (extensions extensions))
310+
      (match points
311+
        (() extensions)
312+
        (((point value) points ...)
313+
         (loop points (acons point
314+
                             (let ((v (assoc-ref extensions point)))
315+
                               (if v (cons value v) (list value)))
316+
                             extensions))))))
317+
318+
  (define (compose-extension target)
319+
    (lambda (extension)
320+
      (match extension
321+
        ((point-name values ...)
322+
         (match (filter
323+
                  (lambda (extension-point)
324+
                      (eq? (home-extension-point-name extension-point) point-name))
325+
                    (home-type-extension-points (user-home-type target)))
326+
           ((point)
327+
            (list
328+
              point-name
329+
              ((home-extension-point-compose point)
330+
               values))))))))
331+
332+
  (match (filter (lambda (home)
333+
                   (eq? (user-home-type home) target-type))
334+
                 homes)
335+
    ((sink)
336+
     (let loop ((sink sink))
337+
       (let* ((dependents (map loop (dependents sink)))
338+
              (extensions (map (apply-extension sink) dependents))
339+
              (extensions (fold merge-extensions '() extensions))
340+
              (extensions (map (compose-extension sink) extensions)))
341+
         (user-home
342+
           (user-home-type sink)
343+
           (let ((extension-points (home-type-extension-points (user-home-type sink))))
344+
             (if extension-points
345+
               (fold (lambda (extension-point value)
346+
                       (let* ((extend (home-extension-point-extend extension-point))
347+
                              (name (home-extension-point-name extension-point))
348+
                              (extension-value (assoc-ref extensions name)))
349+
                         (if extension-value
350+
                             (extend value extension-value)
351+
                             value)))
352+
                     (user-home-value sink)
353+
                     (home-type-extension-points (user-home-type sink)))
354+
               (user-home-value sink)))))))
355+
    (()
356+
     (raise
357+
       (condition (&missing-target-home-error
358+
                    (home #f)
359+
                    (target-type target-type))
360+
                  (&message
361+
                    (message (format #f (G_ "home configuration of type '~a' not found")
362+
                                     (home-type-name target-type)))))))
363+
    (x
364+
      (raise
365+
        (condition (&ambiguous-target-home-error
366+
                    (home #f)
367+
                    (target-type target-type))
368+
                   (&message
369+
                    (message (format #f (G_ "home configuration of type '~a' not found")
370+
                                     (home-type-name target-type)))))))))
371+
372+
;;;
373+
;;; Home generation
374+
;;;
37375 
38376 
(define-syntax use-home-modules
39377 
  (syntax-rules ()
…
44382 
  make-home
45383 
  home?
46384 
  (data-directory home-data-directory)
47-
  (guix-symlink   home-guix-symlink (thunked)
48-
                  (default (string-append
49-
                             (home-data-directory this-record)
50-
                             "/.guix-profile")))
51-
  (guix-config-symlink home-guix-config-symlink (thunked)
52-
                       (default (string-append
53-
                                  (home-data-directory this-record)
54-
                                  "/.config/guix")))
55-
  (local-symlink  home-local-symlink (thunked)
56-
                  (default (string-append
57-
                             (home-data-directory this-record)
58-
                             "/.local")))
59-
  (cache-symlink  home-cache-symlink (thunked)
60-
                  (default (string-append
61-
                             (home-data-directory this-record)
62-
                             "/.cache")))
385+
  (base-configuration home-base-configuration (thunked)
386+
    (default
387+
      (base-home-configuration
388+
        (guix-symlink
389+
          (string-append (home-data-directory this-record) "/.guix-profile"))
390+
        (guix-config-symlink
391+
          (string-append (home-data-directory this-record) "/.config/guix"))
392+
        (local-symlink
393+
          (string-append (home-data-directory this-record) "/.local"))
394+
        (cache-symlink
395+
          (string-append (home-data-directory this-record) "/.cache")))))
63396 
  (configurations home-configurations
64-
                  (default '())))
397+
                  (default (list (user-home root-home-type)))))
398+
399+
(define-record-type* <base-home-configuration> base-home-configuration
400+
  make-base-home-configuration
401+
  base-home-configuration?
402+
  (guix-symlink        base-home-configuration-guix-symlink)
403+
  (guix-config-symlink base-home-configuration-guix-config-symlink)
404+
  (local-symlink       base-home-configuration-local-symlink)
405+
  (cache-symlink       base-home-configuration-cache-symlink))
406+
407+
(define base-home-type
408+
  (home-type
409+
    (name 'guix)
410+
    (extensions
411+
      (list
412+
        (home-extension
413+
          (target root-home-type)
414+
          (compute (lambda (config)
415+
                     `((".guix-profile"
416+
                        ,(base-home-configuration-guix-symlink config))
417+
                       (".config/guix"
418+
                        ,(base-home-configuration-guix-config-symlink config))
419+
                       (".local"
420+
                        ,(base-home-configuration-local-symlink config))
421+
                       (".cache"
422+
                        ,(base-home-configuration-cache-symlink config))))))))))
65423 
66424 
(define (home->derivation home)
67425 
  (define builder
68426 
    (with-imported-modules
69-
      '((guix build utils) (home build utils))
427+
      '((guix build utils) (home build utils) (ice-9 match))
70428 
      #~(begin
71-
          (use-modules (guix build utils) (home build utils))
72-
          (mkdir-p (home-file #$output ".config"))
73-
          ;; For guix
74-
          (symlink #$(home-guix-config-symlink home) (home-file #$output ".config/guix"))
75-
          (symlink #$(home-guix-symlink home) (home-file #$output ".guix-profile"))
76-
          ;; symlink writeable directories
77-
          (symlink #$(home-local-symlink home) (home-file #$output ".local"))
78-
          (symlink #$(home-cache-symlink home) (home-file #$output ".cache"))
79-
          ;; rest of the files
80-
          (for-each
81-
            (lambda (config)
82-
              (with-directory-excursion config
83-
                (for-each
84-
                  (lambda (f)
85-
                    (mkdir-p (home-file #$output (dirname f)))
86-
                    (symlink (home-file config f)
87-
                             (home-file #$output f)))
88-
                  (find-files "." "."))))
89-
            (list #$@(home-configurations home))))))
429+
          (use-modules (guix build utils) (home build utils) (ice-9 match))
430+
          #$(let* ((homes (instantiate-missing-user-homes
431+
                            (cons
432+
                              (user-home base-home-type (home-base-configuration home))
433+
                              (home-configurations home))))
434+
                   (root (fold-home root-home-type homes))
435+
                   (configs (user-home-value root)))
436+
              #~(for-each
437+
                  (lambda (config)
438+
                    (match config
439+
                      ((home-name target)
440+
                       (mkdir-p (dirname (home-file #$output home-name)))
441+
                       (symlink target (home-file #$output home-name)))))
442+
                  '(#$@configs))))))
90443 
  (gexp->derivation "home" builder
91444 
                    #:substitutable? #f
92445 
                    #:local-build? #t))
home/hexchat.scm
2121 
  #:use-module (guix records)
2222 
  #:use-module (gnu packages lxde)
2323 
  #:use-module (ice-9 match)
24+
  #:use-module (home)
2425 
  #:export (hexchat-configuration
2526 
            hexchat-configuration-servlist
2627 
            hexchat-configuration-log-dir
…
3435 
            hexchat-server-servers
3536 
            hexchat-server-flags
3637 
37-
            hexchat-home))
38+
            hexchat-home-type))
3839 
3940 
(define-record-type* <hexchat-server>
4041 
  hexchat-server make-hexchat-server
…
100101 
  (log-dir        hexchat-configuration-log-dir)
101102 
  (scrollback-dir hexchat-configuraton-scrollback-dir))
102103 
103-
(define (hexchat-home config)
104-
  (computed-file "hexchat-home"
105-
    (match config
106-
      (($ <hexchat-configuration> servlist log-dir scrollback-dir)
107-
       #~(let ((servlist.conf #$(plain-file "servlist.conf" (generate-hexchat-servlist servlist)))
108-
               (hexchat-dir (string-append #$output "/.config/hexchat")))
109-
           (use-modules (guix build utils))
110-
           (mkdir-p hexchat-dir)
111-
           (symlink #$log-dir (string-append hexchat-dir "/logs"))
112-
           (symlink #$scrollback-dir (string-append hexchat-dir "/scrollback"))
113-
           (copy-file servlist.conf (string-append hexchat-dir "/servlist.conf")))))
114-
    #:options
115-
    '(#:local-build? #t
116-
      #:modules ((guix build utils)))))
116>
1170>
\ No newline at end of file
104+
(define hexchat-home-type
105+
  (home-type
106+
    (name 'hexchat)
107+
    (extensions
108+
      (list
109+
        (home-extension
110+
          (target root-home-type)
111+
          (compute
112+
            (lambda (config)
113+
              (match config
114+
                (($ <hexchat-configuration> servlist log-dir scrollback-dir)
115+
                 (let ((servlist.conf (plain-file "servlist.conf" (generate-hexchat-servlist servlist))))
116+
                   `((".config/hexchat/servlist.conf" ,servlist.conf)
117+
                     (".config/hexchat/logs" ,log-dir)
118+
                     (".config/hexchat/scrollback" ,scrollback-dir))))))))))))
home/keepassxc.scm
2222 
  #:use-module (gnu packages lxde)
2323 
  #:use-module (ice-9 match)
2424 
  #:use-module (home utils)
25+
  #:use-module (home)
2526 
  #:export (keepassxc-configuration
2627 
            keepassxc-last-databases
2728 
            keepassxc-last-dir
…
4243 
            keepassxc-wordlist
4344 
            keepassxc-word-separator
4445 
45-
            keepassxc-home))
46+
            keepassxc-home-type))
4647 
4748 
(define-record-type* <keepassxc-configuration>
4849 
  keepassxc-configuration make-keepassxc-configuration
…
8485 
  (word-separator        keepassxc-word-separator
8586 
                         (default " ")))
8687 
87-
(define (keepassxc-home config)
88-
  (computed-file "keepassxc-home"
89-
    (let ((keepassxc.ini (make-ini-file "keepassxc.ini"
90-
                           `(("General"
91-
                              (("LastDatabases"
92-
                                ,(string-join
93-
                                   (keepassxc-last-databases config)
94-
                                   ", "))
95-
                               ("LastDir"
96-
                                ,(or (keepassxc-last-dir config) ""))
97-
                               ("LastOpenedDatabases"
98-
                                ,(string-join
99-
                                   (keepassxc-last-opened-databases config)
100-
                                   ", "))))
101-
                             ("GUI"
102-
                              (("HidePasswords"
103-
                                ,(keepassxc-hide-passwords? config))
104-
                               ("HideUsernames"
105-
                                ,(keepassxc-hide-usernames? config))))
106-
                             ("generator"
107-
                              (("EASCII"
108-
                                ,(keepassxc-use-eascii? config))
109-
                               ("EnsureEvery"
110-
                                ,(keepassxc-ensure-every? config))
111-
                               ("ExcludeAlike"
112-
                                ,(keepassxc-exclude-alike? config))
113-
                               ("Length"
114-
                                ,(keepassxc-password-length config))
115-
                               ("LowerCase"
116-
                                ,(keepassxc-use-lower-case? config))
117-
                               ("Numbers"
118-
                                ,(keepassxc-use-numbers? config))
119-
                               ("SpecialChars"
120-
                                ,(keepassxc-use-special-chars? config))
121-
                               ("Type"
122-
                                ,(keepassxc-type config))
123-
                               ("UpperCase"
124-
                                ,(keepassxc-use-upper-case? config))
125-
                               ("WordCount"
126-
                                ,(keepassxc-word-count config))
127-
                               ("WordList"
128-
                                ,(keepassxc-wordlist config))
129-
                               ("WordSeparator"
130-
                                ,(keepassxc-word-separator config))))))))
131-
      #~(begin
132-
          (let ((keepassxc-dir (string-append #$output "/.config/keepassxc")))
133-
            (use-modules (guix build utils))
134-
            (mkdir-p keepassxc-dir)
135-
            (copy-file #$keepassxc.ini (string-append keepassxc-dir "/keepassxc.ini")))))
136-
    #:options
137-
    '(#:local-build? #t
138-
      #:modules ((guix build utils)))))
88+
(define keepassxc-home-type
89+
  (home-type
90+
    (name 'keepassxc)
91+
    (extensions
92+
      (list
93+
        (home-extension
94+
          (target root-home-type)
95+
          (compute (lambda (config)
96+
                     (let ((keepassxc.ini
97+
                             (make-ini-file "keepassxc.ini"
98+
                              `(("General"
99+
                                 (("LastDatabases"
100+
                                   ,(string-join
101+
                                      (keepassxc-last-databases config)
102+
                                      ", "))
103+
                                  ("LastDir"
104+
                                   ,(or (keepassxc-last-dir config) ""))
105+
                                  ("LastOpenedDatabases"
106+
                                   ,(string-join
107+
                                      (keepassxc-last-opened-databases config)
108+
                                      ", "))))
109+
                                ("GUI"
110+
                                 (("HidePasswords"
111+
                                   ,(keepassxc-hide-passwords? config))
112+
                                  ("HideUsernames"
113+
                                   ,(keepassxc-hide-usernames? config))))
114+
                                ("generator"
115+
                                 (("EASCII"
116+
                                   ,(keepassxc-use-eascii? config))
117+
                                  ("EnsureEvery"
118+
                                   ,(keepassxc-ensure-every? config))
119+
                                  ("ExcludeAlike"
120+
                                   ,(keepassxc-exclude-alike? config))
121+
                                  ("Length"
122+
                                   ,(keepassxc-password-length config))
123+
                                  ("LowerCase"
124+
                                   ,(keepassxc-use-lower-case? config))
125+
                                  ("Numbers"
126+
                                   ,(keepassxc-use-numbers? config))
127+
                                  ("SpecialChars"
128+
                                   ,(keepassxc-use-special-chars? config))
129+
                                  ("Type"
130+
                                   ,(keepassxc-type config))
131+
                                  ("UpperCase"
132+
                                   ,(keepassxc-use-upper-case? config))
133+
                                  ("WordCount"
134+
                                   ,(keepassxc-word-count config))
135+
                                  ("WordList"
136+
                                   ,(keepassxc-wordlist config))
137+
                                  ("WordSeparator"
138+
                                   ,(keepassxc-word-separator config))))))))
139+
                       `((".config/keepassxc/keepassxc.ini" ,keepassxc.ini))))))))))
home/openbox.scm
2323 
  #:use-module (guix packages)
2424 
  #:use-module (guix records)
2525 
  #:use-module (gnu packages lxde)
26+
  #:use-module (home)
2627 
  #:use-module (ice-9 match)
2728 
  #:export (openbox-configuration
2829 
            openbox-configuration?
…
3940 
            openbox-element-menu
4041 
            openbox-element-execute
4142 
            
42-
            openbox-home))
43+
            openbox-home-type))
4344 
4445 
(define-record-type* <openbox-configuration>
4546 
  openbox-configuration make-openbox-configuration
…
114115 
    (#f (plain-file "rc.xml" ""))
115116 
    (_ rc)))
116117 
117-
(define (openbox-home config)
118-
  (computed-file "openbox-home"
119-
    (match config
120-
      (($ <openbox-configuration> autostart environ menus root-elements rc)
121-
       #~(let ((menu.xml #$(computed-file "menu.xml" (generate-openbox-menu menus root-elements)))
122-
               (autostart #$(openbox-autostart autostart))
123-
               (environ #$(openbox-environment environ))
124-
               (rc #$(openbox-rc rc))
125-
               (openbox-dir (string-append #$output "/.config/openbox")))
126-
           (use-modules (guix build utils))
127-
           (mkdir-p openbox-dir)
128-
           (copy-file autostart (string-append openbox-dir "/autostart"))
129-
           (copy-file environ (string-append openbox-dir "/environment"))
130-
           (copy-file menu.xml (string-append openbox-dir "/menu.xml"))
131-
           (copy-file rc (string-append openbox-dir "/rc.xml")))))
132-
    #:options
133-
    '(#:local-build? #t
134-
      #:modules ((guix build utils)))))
134>
1350>
\ No newline at end of file
118+
(define openbox-home-type
119+
  (home-type
120+
    (name 'openbox)
121+
    (default-value (openbox-configuration))
122+
    (extensions
123+
      (list
124+
        (home-extension
125+
          (target root-home-type)
126+
          (compute
127+
            (lambda (config)
128+
              (match config
129+
                (($ <openbox-configuration> autostart environ menus root-elements rc)
130+
                 `((".config/openbox/menu.xml"
131+
                    ,(computed-file "menu.xml" (generate-openbox-menu menus root-elements)))
132+
                   (".config/openbox/autostart" ,(openbox-autostart autostart))
133+
                   (".config/openbox/environment" ,(openbox-environment environ))
134+
                   (".config/openbox/rc.xml" ,(openbox-rc rc))))))))))))
home/ssh.scm
2121 
  #:use-module (guix records)
2222 
  #:use-module (gnu packages lxde)
2323 
  #:use-module (ice-9 match)
24+
  #:use-module (home)
2425 
  #:export (ssh-configuration
2526 
            ssh-configuration-authorized-keys
2627 
            ssh-configuration-known-hosts
…
3940 
            ssh-known-host-configuration-algo
4041 
            ssh-known-host-configuration-key
4142 
42-
            ssh-home))
43+
            ssh-home-type))
4344 
4445 
(define-record-type* <ssh-host-configuration>
4546 
  ssh-host-configuration make-ssh-host-configuration
…
129130 
(define (generate-ssh-known-hosts lst)
130131 
  (string-join (map known-host lst) "\n"))
131132 
132-
(define (ssh-home config)
133-
  (computed-file "ssh-home"
134-
    (match config
135-
      (($ <ssh-configuration> authorized-keys known-hosts hosts default-host)
136-
       #~(let ((config #$(plain-file "config" (generate-ssh-config hosts default-host)))
137-
               (known-hosts #$(plain-file "known_hosts"
138-
                                          (generate-ssh-known-hosts known-hosts)))
139-
               (authorized-keys #$(plain-file
140-
                                    "authorized_keys"
141-
                                    (generate-ssh-authorized-keys authorized-keys)))
142-
               (ssh-dir (string-append #$output "/.ssh")))
143-
           (use-modules (guix build utils))
144-
           (mkdir-p ssh-dir)
145-
           (copy-file authorized-keys (string-append ssh-dir "/authorized_keys"))
146-
           (copy-file known-hosts (string-append ssh-dir "/known_hosts"))
147-
           (copy-file config (string-append ssh-dir "/config")))))
148-
    #:options
149-
    '(#:local-build? #t
150-
      #:modules ((guix build utils)))))
133+
(define ssh-home-type
134+
  (home-type
135+
    (name 'ssh)
136+
    (extensions
137+
      (list
138+
        (home-extension
139+
          (target root-home-type)
140+
          (compute (lambda (config)
141+
                     (match config
142+
                       (($ <ssh-configuration> authorized-keys known-hosts hosts default-host)
143+
                        (let ((config (plain-file "config" (generate-ssh-config hosts default-host)))
144+
                              (known-hosts (plain-file "known_hosts"
145+
                                                       (generate-ssh-known-hosts known-hosts)))
146+
                              (authorized-keys (plain-file "authorized_keys"
147+
                                                           (generate-ssh-authorized-keys authorized-keys))))
148+
                     `((".ssh/authorized_keys" ,authorized-keys) (".ssh/known_hosts" ,known-hosts)
149+
                       (".ssh/config" ,config))))))))))))
home/utils.scm
1919 
  #:use-module (guix build utils)
2020 
  #:use-module (guix gexp)
2121 
  #:use-module (ice-9 match)
22+
  #:use-module (home)
2223 
  #:export (simple-file-home
2324 
            symlink-file-home
2425 
            make-ini-file))
2526 
2627 
(define (simple-file-home file-gexp location)
27-
  "Add @var{file-gexp}, a file-like object, to the user home at @var{location}."
28-
  (computed-file "simple-file-home"
29-
    #~(begin
30-
        (use-modules (guix build utils))
31-
        (mkdir-p (string-append #$output "/" #$(dirname location)))
32-
        (copy-file #$file-gexp (string-append #$output "/" #$location)))
33-
    #:options
34-
    '(#:local-build? #t
35-
      #:modules ((guix build utils)))))
28+
  (user-home
29+
    (home-type
30+
      (name 'simple-file)
31+
      (extensions
32+
        (list
33+
          (home-extension
34+
            (target root-home-type)
35+
            (compute
36+
              (const `((,location ,file-gexp))))))))
37+
    #t))
3638 
37-
(define (symlink-file-home from to)
39+
(define (symlink-file-home to from)
3840 
  "Create a symlink from the user home at @var{from} that points to @var{to}."
39-
  (computed-file "symlink-file-home"
40-
    #~(begin
41-
        (use-modules (guix build utils))
42-
        (mkdir-p (string-append #$output "/" #$(dirname to)))
43-
        (symlink #$from (string-append #$output "/" #$to)))
44-
    #:options
45-
    '(#:local-build? #t
46-
      #:modules ((guix build utils)))))
41+
  (user-home
42+
    (home-type
43+
      (name 'symlink-file)
44+
      (extensions
45+
        (list
46+
          (home-extension
47+
            (target root-home-type)
48+
            (compute
49+
              (const `((,from ,to))))))))
50+
    #t))
4751 
4852 
(define (make-ini-file name config)
4953 
  (define (make-ini-section name config)