summaryrefslogtreecommitdiff
path: root/guix/scripts/home.scm
blob: f43bf865a7159150ca8a300304193c7be8c72d0a (about) (plain)
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
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Pierre Langlois <pierre.langlois@gmx.com>
;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix scripts home)
  #:use-module (gnu packages admin)
  #:use-module ((gnu services) #:hide (delete))
  #:use-module (gnu packages)
  #:autoload   (gnu packages base) (coreutils)
  #:autoload   (gnu packages bash) (bash)
  #:autoload   (gnu packages gnupg) (guile-gcrypt)
  #:autoload   (gnu packages shells) (fish gash zsh)
  #:use-module (gnu home)
  #:use-module (gnu home services)
  #:autoload   (gnu home services shepherd) (home-shepherd-service-type
                                             home-shepherd-configuration-services
                                             shepherd-service-requirement)
  #:autoload   (guix modules) (source-module-closure)
  #:autoload   (gnu build linux-container) (call-with-container %namespaces)
  #:autoload   (gnu system linux-container) (eval/container)
  #:autoload   (gnu system file-systems) (file-system-mapping
                                          file-system-mapping-source
                                          file-system-mapping->bind-mount
                                          specification->file-system-mapping
                                          %network-file-mappings)
  #:autoload   (guix self) (make-config.scm)
  #:use-module (guix channels)
  #:use-module (guix derivations)
  #:use-module (guix ui)
  #:autoload   (guix colors) (supports-hyperlinks? file-hyperlink)
  #:use-module (guix grafts)
  #:use-module (guix packages)
  #:use-module (guix profiles)
  #:use-module (guix store)
  #:use-module (guix utils)
  #:autoload   (guix graph) (lookup-backend export-graph)
  #:use-module (guix scripts)
  #:use-module (guix scripts package)
  #:use-module (guix scripts build)
  #:autoload   (guix scripts system search) (service-type->recutils)
  #:use-module (guix scripts system reconfigure)
  #:autoload   (guix scripts pull) (channel-commit-hyperlink)
  #:autoload   (guix scripts system) (service-node-type
                                      shepherd-service-node-type)
  #:autoload   (guix scripts home import) (import-manifest)
  #:use-module ((guix status) #:select (with-status-verbosity))
  #:use-module ((guix build utils) #:select (mkdir-p))
  #:use-module (guix gexp)
  #:use-module (guix monads)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-26)
  #:use-module (srfi srfi-35)
  #:use-module (srfi srfi-37)
  #:use-module (srfi srfi-71)
  #:use-module (ice-9 match)
  #:export (guix-home))


;;;
;;; Options.
;;;

(define %user-module
  (make-user-module '((gnu home))))

(define %guix-home
  (string-append %profile-directory "/guix-home"))

(define (show-help)
  (display (G_ "Usage: guix home [OPTION ...] ACTION [ARG ...] [FILE]
Build the home environment declared in FILE according to ACTION.
Some ACTIONS support additional ARGS.\n"))
    (newline)
  (display (G_ "The valid values for ACTION are:\n"))
  (newline)
  (display (G_ "\
   search             search for existing service types\n"))
  (display (G_ "
   container          run the home environment configuration in a container\n"))
  (display (G_ "\
   reconfigure        switch to a new home environment configuration\n"))
  (display (G_ "\
   roll-back          switch to the previous home environment configuration\n"))
  (display (G_ "\
   describe           describe the current home environment\n"))
  (display (G_ "\
   list-generations   list the home environment generations\n"))
  (display (G_ "\
   switch-generation  switch to an existing home environment configuration\n"))
  (display (G_ "\
   delete-generations delete old home environment generations\n"))
  (display (G_ "\
   build              build the home environment without installing anything\n"))
  (display (G_ "\
   import             generates a home environment definition from dotfiles\n"))
  (display (G_ "\
   extension-graph    emit the service extension graph\n"))
  (display (G_ "\
   shepherd-graph     emit the graph of shepherd services\n"))

  (show-build-options-help)
  (display (G_ "
  -e, --expression=EXPR  consider the home-environment EXPR evaluates to
                         instead of reading FILE, when applicable"))
  (display (G_ "
      --allow-downgrades for 'reconfigure', allow downgrades to earlier
                         channel revisions"))
  (newline)
  (display (G_ "
  -N, --network          allow containers to access the network"))
  (display (G_ "
      --share=SPEC       for containers, share writable host file system
                         according to SPEC"))
  (display (G_ "
      --expose=SPEC      for containers, expose read-only host file system
                         according to SPEC"))
  (newline)
  (display (G_ "
  -v, --verbosity=LEVEL  use the given verbosity LEVEL"))
  (display (G_ "
      --graph-backend=BACKEND
                         use BACKEND for 'extension-graph' and 'shepherd-graph'"))
  (newline)
  (display (G_ "
  -h, --help             display this help and exit"))
  (display (G_ "
  -V, --version          display version information and exit"))
  (newline)
  (show-bug-report-information))

(define (verbosity-level opts)
  "Return the verbosity level based on OPTS, the alist of parsed options."
  (or (assoc-ref opts 'verbosity)
      (if (eq? (assoc-ref opts 'action) 'build)
          3 1)))

(define %options
  ;; Specification of the command-line options.
  (cons* (option '(#\h "help") #f #f
                 (lambda args
                   (show-help)
                   (exit 0)))
         (option '(#\n "dry-run") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'dry-run? #t result)))
         (option '(#\V "version") #f #f
                 (lambda args
                   (show-version-and-exit "guix show")))
         (option '(#\v "verbosity") #t #f
                 (lambda (opt name arg result)
                   (let ((level (string->number* arg)))
                     (alist-cons 'verbosity level
                                 (alist-delete 'verbosity result)))))
         (option '(#\e "expression") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'expression arg result)))
         (option '("allow-downgrades") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'validate-reconfigure
                               warn-about-backward-reconfigure
                               result)))
         (option '("graph-backend") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'graph-backend arg result)))

         ;; Container options.
         (option '(#\N "network") #f #f
                 (lambda (opt name arg result)
                   (alist-cons 'network? #t result)))
         (option '("share") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file-system-mapping
                               (specification->file-system-mapping arg #t)
                               result)))
         (option '("expose") #t #f
                 (lambda (opt name arg result)
                   (alist-cons 'file-system-mapping
                               (specification->file-system-mapping arg #f)
                               result)))

         %standard-build-options))

(define %default-options
  `((graft? . #t)
    (substitutes? . #t)
    (offload? . #t)
    (print-build-trace? . #t)
    (print-extended-build-trace? . #t)
    (multiplexed-build-output? . #t)
    (verbosity . #f)                              ;default
    (debug . 0)
    (validate-reconfigure . ,ensure-forward-reconfigure)
    (graph-backend . "graphviz")))


;;;
;;; Container.
;;;

(define not-config?
  ;; Select (guix …) and (gnu …) modules, except (guix config).
  (match-lambda
    (('guix 'config) #f)
    (('guix _ ...) #t)
    (('gnu _ ...) #t)
    (_ #f)))

(define (user-shell)
  (match (and=> (or (getenv "SHELL")
                    (passwd:shell (getpwuid (getuid))))
                basename)
    ("zsh"  (file-append zsh "/bin/zsh"))
    ("fish" (file-append fish "/bin/fish"))
    ("gash" (file-append gash "/bin/gash"))
    (_      (file-append bash "/bin/bash"))))

(define %default-system-profile
  ;; The "system" profile available when running 'guix home container'.  The
  ;; activation script currently expects to run "env -0" (XXX), so provide
  ;; Coreutils by default.
  (delay (profile
          (name "home-system-profile")
          (content (packages->manifest (list coreutils))))))

(define* (spawn-home-container home
                               #:key
                               network?
                               (command '())
                               (mappings '())
                               (system-profile
                                (force %default-system-profile)))
  "Spawn a login shell within a container running HOME, a home environment.
When COMMAND is a non-empty list, execute it in the container and exit
immediately.  Return the exit status of the process in the container."
  (define passwd (getpwuid (getuid)))
  (define home-directory (or (getenv "HOME") (passwd:dir passwd)))
  (define host (gethostname))
  (define uid 1000)
  (define gid 1000)
  (define user-name (passwd:name passwd))
  (define user-real-name (passwd:gecos passwd))

  (define (optional-mapping mapping)
    (and (file-exists? (file-system-mapping-source mapping))
         mapping))

  (define network-mappings
    (if network?
        (filter-map optional-mapping %network-file-mappings)
        '()))

  (eval/container
   (with-extensions (list guile-gcrypt)
     (with-imported-modules `(((guix config) => ,(make-config.scm))
                              ,@(source-module-closure
                                 '((gnu build accounts)
                                   (guix profiles)
                                   (guix build utils)
                                   (guix build syscalls))
                                 #:select? not-config?))
       #~(begin
           (use-modules (guix build utils)
                        (gnu build accounts)
                        ((guix build syscalls)
                         #:select (set-network-interface-up)))

           (define shell
             #$(user-shell))

           (define term
             #$(getenv "TERM"))

           (define passwd
             (password-entry
              (name #$user-name)
              (real-name #$user-real-name)
              (uid #$uid) (gid #$gid) (shell shell)
              (directory #$home-directory)))

           (define groups
             (list (group-entry (name "users") (gid #$gid))
                   (group-entry (gid 65534)       ;the overflow GID
                                (name "overflow"))))

           ;; (guix profiles) loads (guix utils), which calls 'getpw' from the
           ;; top level.  Thus, arrange so that it's loaded after /etc/passwd
           ;; has been created.
           (module-autoload! (current-module)
                             '(guix profiles) '(load-profile))

           ;; Create /etc/passwd for applications that need it, such as mcron.
           (mkdir-p "/etc")
           (write-passwd (list passwd))
           (write-group groups)

           (unless #$network?
             ;; When isolated from the network, provide a minimal /etc/hosts
             ;; to resolve "localhost".
             (call-with-output-file "/etc/hosts"
               (lambda (port)
                 (display "127.0.0.1 localhost\n" port)
                 (chmod port #o444))))

           ;; Set PATH for things that the activation script might expect, such
           ;; as "env".
           (load-profile #$system-profile)

           (mkdir-p #$home-directory)
           (setenv "HOME" #$home-directory)
           (setenv "GUIX_NEW_HOME" #$home)
           (primitive-load (string-append #$home "/activate"))
           (setenv "GUIX_NEW_HOME" #f)

           (when term
             ;; Preserve TERM for proper interactive use.
             (setenv "TERM" term))

           (chdir #$home-directory)

           ;; Invoke SHELL with argv[0] starting with "-": that's how shells
           ;; figure out that they are login shells!
           (execl shell (string-append "-" (basename shell))
                  #$@(match command
                       (() #~())
                       ((_ ...)
                        #~("-c" #$(string-join command))))))))

   #:namespaces (if network?
                    (delq 'net %namespaces)       ; share host network
                    %namespaces)
   #:mappings (append network-mappings mappings)
   #:guest-uid uid
   #:guest-gid gid))


;;;
;;; Actions.
;;;

(define* (export-extension-graph home port
                                 #:key (backend (lookup-backend "graphviz")))
  "Export the service extension graph of HOME to PORT using BACKEND."
  (let* ((services (home-environment-services home))
         (home     (find (lambda (service)
                           (eq? (service-kind service) home-service-type))
                         services)))
    (export-graph (list home) port
                  #:backend backend
                  #:node-type (service-node-type services)
                  #:reverse-edges? #t)))

(define* (export-shepherd-graph home port
                                #:key (backend (lookup-backend "graphviz")))
  "Export the graph of shepherd services of HOME to PORT using BACKEND."
  (let* ((services  (home-environment-services home))
         (root      (fold-services services
                                   #:target-type home-shepherd-service-type))
         ;; Get the list of <shepherd-service>.
         (shepherds (home-shepherd-configuration-services
                     (service-value root)))
         (sinks     (filter (lambda (service)
                              (null? (shepherd-service-requirement service)))
                            shepherds)))
    (export-graph sinks port
                  #:backend backend
                  #:node-type (shepherd-service-node-type shepherds)
                  #:reverse-edges? #t)))

(define* (perform-action action he
                         #:key
                         dry-run?
                         derivations-only?
                         use-substitutes?
                         (graph-backend "graphviz")
                         (validate-reconfigure ensure-forward-reconfigure)

                         ;; Container options.
                         (file-system-mappings '())
                         (container-command '())
                         network?)
  "Perform ACTION for home environment. "

  (define println
    (cut format #t "~a~%" <>))

  (when (eq? action 'reconfigure)
    (check-forward-update validate-reconfigure
                          #:current-channels (home-provenance %guix-home)))

  (case action
    ((extension-graph)
     (export-extension-graph he (current-output-port)
                             #:backend (lookup-backend graph-backend)))
    ((shepherd-graph)
     (export-shepherd-graph he (current-output-port)
                            #:backend (lookup-backend graph-backend)))
    (else
     (mlet* %store-monad
         ((he-drv   (home-environment-derivation he))
          (drvs     (mapm/accumulate-builds lower-object (list he-drv)))
          (%        (if derivations-only?
                        (return
                         (for-each (compose println derivation-file-name) drvs))
                        (built-derivations drvs)))

          (he-out-path -> (derivation->output-path he-drv)))
       (if (or dry-run? derivations-only?)
           (return #f)
           (case action
             ((reconfigure)
              (let* ((number (generation-number %guix-home))
                     (generation (generation-file-name
                                  %guix-home (+ 1 number))))

                (switch-symlinks generation he-out-path)
                (switch-symlinks %guix-home generation)
                (setenv "GUIX_NEW_HOME" he-out-path)
                (primitive-load (string-append he-out-path "/activate"))
                (setenv "GUIX_NEW_HOME" #f)
                (return he-out-path)))
             ((container)
              (mlet %store-monad ((status (spawn-home-container
                                           he
                                           #:network? network?
                                           #:mappings file-system-mappings
                                           #:command
                                           container-command)))
                (match (status:exit-val status)
                  (0 (return #t))
                  ((? integer? n) (return (exit n)))
                  (#f
                   (if (status:term-sig status)
                       (leave (G_ "process terminated with signal ~a~%")
                              (status:term-sig status))
                       (leave (G_ "process stopped with signal ~a~%")
                              (status:stop-sig status)))))))
             (else
              (for-each (compose println derivation->output-path) drvs)
              (return he-out-path))))))))

(define (process-action action args opts)
  "Process ACTION, a sub-command, with the arguments are listed in ARGS.
ACTION must be one of the sub-commands that takes a home environment
declaration as an argument (a file name.)  OPTS is the raw alist of options
resulting from command-line parsing."
  (define (ensure-home-environment file-or-exp obj)
    (ensure-profile-directory)
    (unless (home-environment? obj)
      (leave (G_ "'~a' does not return a home environment ~%")
             file-or-exp))
    obj)

  (let* ((file   (match args
                   (() #f)
                   ((x . _) x)))
         (expr   (assoc-ref opts 'expression))
         (system (assoc-ref opts 'system))

         (transform   (lambda (obj)
                        (home-environment-with-provenance obj file)))

         (home-environment
          (transform
           (ensure-home-environment
            (or file expr)
            (cond
             ((and expr file)
              (leave
               (G_ "both file and expression cannot be specified~%")))
             (expr
              (read/eval expr))
             (file
              (load* file %user-module
                     #:on-error (assoc-ref opts 'on-error)))
             (else
              (leave (G_ "no configuration specified~%")))))))

         (mappings    (filter-map (match-lambda
                                    (('file-system-mapping . mapping) mapping)
                                    (_ #f))
                                  opts))
         (dry?        (assoc-ref opts 'dry-run?)))

    (with-store store
      (set-build-options-from-command-line store opts)
      (with-build-handler (build-notifier #:use-substitutes?
                                          (assoc-ref opts 'substitutes?)
                                          #:verbosity
                                          (verbosity-level opts)
                                          #:dry-run?
                                          (assoc-ref opts 'dry-run?))

        (run-with-store store
          (mbegin %store-monad
            (set-guile-for-build (default-guile))

            (perform-action action home-environment
                            #:dry-run? dry?
                            #:derivations-only? (assoc-ref opts 'derivations-only?)
                            #:use-substitutes? (assoc-ref opts 'substitutes?)
                            #:validate-reconfigure
                            (assoc-ref opts 'validate-reconfigure)
                            #:graph-backend
                            (assoc-ref opts 'graph-backend)
                            #:network? (assoc-ref opts 'network?)
                            #:file-system-mappings mappings
                            #:container-command
                            (or (assoc-ref opts 'container-command) '()))))))
    (warn-about-disk-space)))


(define (process-command command args opts)
  "Process COMMAND, one of the 'guix home' sub-commands.  ARGS is its
argument list and OPTS is the option alist."
  (define-syntax-rule (with-store* store exp ...)
    (with-store store
      (set-build-options-from-command-line store opts)
      exp ...))
  (case command
    ;; The following commands do not need to use the store, and they do not need
    ;; an home environment file.
    ((search)
     (apply search args))
    ((import)
     (let* ((profiles (delete-duplicates
                       (match (filter-map (match-lambda
                                            (('profile . p) p)
                                            (_              #f))
                                          opts)
                         (() (list %current-profile))
                         (lst (reverse lst)))))
            (manifest (concatenate-manifests
                       (map profile-manifest profiles)))
            (destination (match args
                           ((destination) destination)
                           (_ (leave (G_ "wrong number of arguments~%"))))))
       (unless (file-exists? destination)
         (mkdir-p destination))
       (call-with-output-file
           (string-append destination "/home-configuration.scm")
         (cut import-manifest manifest destination <>))
       (info (G_ "'~a' populated with all the Home configuration files~%")
             destination)
       (display-hint (format #f (G_ "\
Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively
deploy the home environment described by these files.\n")
                             destination))))
    ((describe)
     (match (generation-number %guix-home)
       (0
        (leave (G_ "no home environment generation, nothing to describe~%")))
       (generation
        (display-home-environment-generation generation))))
    ((list-generations)
     (let ((pattern (match args
                      (() #f)
                      ((pattern) pattern)
                      (x (leave (G_ "wrong number of arguments~%"))))))
       (list-generations pattern)))
    ((switch-generation)
     (let ((pattern (match args
                      ((pattern) pattern)
                      (x (leave (G_ "wrong number of arguments~%"))))))
       (with-store* store
                    (switch-to-home-environment-generation store pattern))))
    ((roll-back)
     (let ((pattern (match args
                      (() "")
                      (x (leave (G_ "wrong number of arguments~%"))))))
       (with-store* store
                    (roll-back-home-environment store))))
    ((delete-generations)
     (let ((pattern (match args
                      (() #f)
                      ((pattern) pattern)
                      (x (leave (G_ "wrong number of arguments~%"))))))
       (with-store*
        store
        (delete-matching-generations store %guix-home pattern))))
    (else (process-action command args opts))))

(define-command (guix-home . args)
  (synopsis "build and deploy home environments")

  (define (parse-sub-command arg result)
    ;; Parse sub-command ARG and augment RESULT accordingly.
    (if (assoc-ref result 'action)
        (alist-cons 'argument arg result)
        (let ((action (string->symbol arg)))
          (case action
            ((build
              reconfigure
              extension-graph shepherd-graph
              list-generations describe
              delete-generations roll-back
              switch-generation search
              import container)
             (alist-cons 'action action result))
            (else (leave (G_ "~a: unknown action~%") action))))))

  (define (match-pair car)
    ;; Return a procedure that matches a pair with CAR.
    (match-lambda
      ((head . tail)
       (and (eq? car head) tail))
      (_ #f)))

  (define (option-arguments opts)
    ;; Extract the plain arguments from OPTS.
    (let* ((args   (reverse (filter-map (match-pair 'argument) opts)))
           (count  (length args))
           (action (assoc-ref opts 'action))
           (expr   (assoc-ref opts 'expression)))
      (define (fail)
        (leave (G_ "wrong number of arguments for action '~a'~%")
               action))

      (unless action
        (format (current-error-port)
                (G_ "guix home: missing command name~%"))
        (format (current-error-port)
                (G_ "Try 'guix home --help' for more information.~%"))
        (exit 1))

      (case action
        ((build reconfigure)
         (unless (or (= count 1)
                     (and expr (= count 0)))
           (fail)))
        ((init)
         (unless (= count 2)
           (fail))))
      args))

  (define (parse-args args)
    ;; Parse the list of command line arguments ARGS.

    ;; The '--' token is used to separate the command to run from the rest of
    ;; the operands.
    (let* ((args rest (break (cut string=? "--" <>) args))
           (opts (parse-command-line args %options (list %default-options)
                                     #:argument-handler
                                     parse-sub-command)))
      (match rest
        (() opts)
        (("--") opts)
        (("--" command ...)
         (match (assoc-ref opts 'action)
           ('container
            (alist-cons 'container-command command opts))
           (_
            (leave (G_ "~a: extraneous command~%")
                   (string-join command))))))))

  (with-error-handling
    (let* ((opts     (parse-args args))
           (args     (option-arguments opts))
           (command  (assoc-ref opts 'action)))
      (parameterize ((%graft? (assoc-ref opts 'graft?)))
        (with-status-verbosity (verbosity-level opts)
          (process-command command args opts))))))


;;;
;;; Searching.
;;;

(define service-type-name*
  (compose symbol->string service-type-name))

(define (service-type-description-string type)
  "Return the rendered and localised description of TYPE, a service type."
  (and=> (service-type-description type)
         (compose texi->plain-text P_)))

(define %service-type-metrics
  ;; Metrics used to estimate the relevance of a search result.
  `((,service-type-name* . 3)
    (,service-type-description-string . 2)
    (,(lambda (type)
        (match (and=> (service-type-location type) location-file)
          ((? string? file)
           (basename file ".scm"))
          (#f
           "")))
     . 1)))

(define (find-service-types regexps)
  "Return a list of service type/score pairs: service types whose name or
description matches REGEXPS sorted by relevance, and their score."
  (let ((matches (fold-home-service-types
                  (lambda (type result)
                    (match (relevance type regexps
                                      %service-type-metrics)
                      ((? zero?)
                       result)
                      (score
                       (cons (cons type score) result))))
                  '())))
    (sort matches
          (lambda (m1 m2)
            (match m1
              ((type1 . score1)
               (match m2
                 ((type2 . score2)
                  (if (= score1 score2)
                      (string>? (service-type-name* type1)
                                (service-type-name* type2))
                      (> score1 score2))))))))))

(define (search . args)
  (with-error-handling
    (let* ((regexps (map (cut make-regexp* <> regexp/icase) args))
           (matches (find-service-types regexps)))
      (leave-on-EPIPE
       (display-search-results matches (current-output-port)
                               #:print service-type->recutils
                               #:regexps regexps
                               #:command "guix home search")))))


;;;
;;; Generations.
;;;

(define* (display-home-environment-generation
          number
          #:optional (profile %guix-home))
  "Display a summary of home-environment generation NUMBER in a
human-readable format."
  (define (display-channel channel)
    (format #t     "    ~a:~%" (channel-name channel))
    (format #t (G_ "      repository URL: ~a~%") (channel-url channel))
    (when (channel-branch channel)
      (format #t (G_ "      branch: ~a~%") (channel-branch channel)))
    (format #t (G_ "      commit: ~a~%")
            (if (supports-hyperlinks?)
                (channel-commit-hyperlink channel)
                (channel-commit channel))))

  (unless (zero? number)
    (let* ((generation  (generation-file-name profile number)))
      (define-values (channels config-file)
        ;; The function will work for home environments too, we just
        ;; need to keep provenance file.
        (system-provenance generation))

      (display-generation profile number)
      (format #t (G_ "  file name: ~a~%") generation)
      (format #t (G_ "  canonical file name: ~a~%") (readlink* generation))
      ;; TRANSLATORS: Please preserve the two-space indentation.

      (unless (null? channels)
        ;; TRANSLATORS: Here "channel" is the same terminology as used in
        ;; "guix describe" and "guix pull --channels".
        (format #t (G_ "  channels:~%"))
        (for-each display-channel channels))
      (when config-file
        (format #t (G_ "  configuration file: ~a~%")
                (if (supports-hyperlinks?)
                    (file-hyperlink config-file)
                    config-file))))))

(define* (list-generations pattern #:optional (profile %guix-home))
  "Display in a human-readable format all the home environment
generations matching PATTERN, a string.  When PATTERN is #f, display
all the home environment generations."
  (cond ((not (file-exists? profile))             ; XXX: race condition
         (raise (condition (&profile-not-found-error
                            (profile profile)))))
        ((not pattern)
         (for-each display-home-environment-generation (profile-generations profile)))
        ((matching-generations pattern profile)
         =>
         (lambda (numbers)
           (if (null-list? numbers)
               (exit 1)
               (leave-on-EPIPE
                (for-each display-home-environment-generation numbers)))))))


;;;
;;; Switch generations.
;;;

;; TODO: Make it public in (guix scripts system)
(define-syntax-rule (unless-file-not-found exp)
  (catch 'system-error
    (lambda ()
      exp)
    (lambda args
      (if (= ENOENT (system-error-errno args))
          #f
          (apply throw args)))))

(define (switch-to-home-environment-generation store spec)
  "Switch the home-environment profile to the generation specified by
SPEC.  STORE is an open connection to the store."
  (let* ((number (relative-generation-spec->number %guix-home spec))
         (generation (generation-file-name %guix-home number))
         (activate (string-append generation "/activate")))
    (if number
        (begin
          (setenv "GUIX_NEW_HOME" (readlink generation))
          (switch-to-generation* %guix-home number)
          (unless-file-not-found (primitive-load activate))
          (setenv "GUIX_NEW_HOME" #f))
        (leave (G_ "cannot switch to home environment generation '~a'~%") spec))))


;;;
;;; Roll-back.
;;;

(define (roll-back-home-environment store)
  "Roll back the home-environment profile to its previous generation.
STORE is an open connection to the store."
  (switch-to-home-environment-generation store "-1"))