aboutsummaryrefslogtreecommitdiff
path: root/gnu/home.scm
blob: b390c8d534885a06e079a876cf4693fe8354d2eb (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

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2022, 2024 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 (gnu home)
  #:use-module (gnu home services)
  #:use-module (gnu home services symlink-manager)
  #:use-module (gnu home services shells)
  #:use-module (gnu home services xdg)
  #:use-module (gnu home services fontutils)
  #:use-module (gnu services)
  #:use-module (guix records)
  #:use-module (guix diagnostics)
  #:use-module (guix gexp)
  #:use-module (guix store)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:export (home-environment
            home-environment?
            this-home-environment

            home-environment-derivation
            home-environment-packages
            home-environment-user-services
            home-environment-essential-services
            home-environment-services
            home-environment-location

            home-environment-with-provenance

            home-generation-base))

;;; Comment:
;;;
;;; This module provides a <home-environment> record for managing
;;; per-user packages and configuration files in the similar way as
;;; <operating-system> do for system packages and configuration files.
;;;
;;; Code:

(define-record-type* <home-environment> home-environment
  make-home-environment
  home-environment?
  this-home-environment

  (packages           home-environment-packages            ; list of (PACKAGE OUTPUT...)
                      (default '()))

  (essential-services home-environment-essential-services  ; list of services
                      (thunked)
                      (default (home-environment-default-essential-services
                                this-home-environment)))

  (services           home-environment-user-services
                      (default '())
                      (sanitize validate-service-list))

  (location           home-environment-location            ; <location>
                      (default (and=> (current-source-location)
                                      source-properties->location))
                      (innate)))

(define (home-environment-default-essential-services he)
  "Return the list of essential services for home environment."
  (list
   (service home-run-on-first-login-service-type)
   (service home-activation-service-type)
   (service home-environment-variables-service-type)

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

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

   (service home-service-type)
   (service home-profile-service-type (home-environment-packages he))))

(define* (home-environment-services he)
  "Return all the services of home environment."
  (instantiate-missing-services
   (append (home-environment-user-services he)
           (home-environment-essential-services he))))

(define* (home-environment-derivation he)
  "Return a derivation that builds home environment."
  (let* ((services         (home-environment-services he))
         (home (fold-services services
                              #:target-type home-service-type)))
    (service-value home)))


(define (home-environment-configuration-file he)
  "Return the configuration file of HE, based on its 'location' field, or #f
if it could not be determined."
  (let ((file (and=> (home-environment-location he)
                     location-file)))
    (and file
         (or (and (string-prefix? "/" file) file)
             (search-path %load-path file)))))

(define* (home-environment-with-provenance he
                                           #:optional
                                           (config-file
                                            (home-environment-configuration-file
                                             he)))
  "Return a variant of HE that stores its own provenance information,
including CONFIG-FILE, if available.  This is achieved by adding an instance
of HOME-PROVENANCE-SERVICE-TYPE to its services."
  (home-environment
    (inherit he)
    (services (cons (service home-provenance-service-type config-file)
                    (home-environment-user-services he)))))

(define-gexp-compiler (home-environment-compiler (he <home-environment>)
                                                 system target)
  ((store-lift
    (lambda (store)
      (run-with-store store (home-environment-derivation he)
                      #:system system
                      #:target target)))))

(define %profile-generation-rx
  ;; Regexp that matches profile generation.
  (make-regexp "(.*)-([0-9]+)-link$"))

(define (home-generation-base file)
  "If FILE is a Home generation GC root such as \"guix-home-42-link\",
return its corresponding base---e.g., \"guix-home\".  Otherwise return #f.

This is similar to the 'generation-profile' procedure but applied to Home
generations."
  (match (regexp-exec %profile-generation-rx file)
    (#f #f)
    (m  (let ((profile (match:substring m 1)))
          ;; Distinguish from a "real" profile and from a system generation.
          (and (file-exists? (string-append profile "/on-first-login"))
               (file-exists? (string-append profile "/profile/manifest"))
               profile)))))
generated by cgit
#:name "usb-image" #:system system) ,(image->job store (image (inherit (image-with-label iso9660-image (string-append "GUIX_" system "_" (if (> (string-length %guix-version) 7) (substring %guix-version 0 7) %guix-version)))) (operating-system installation-os)) #:name "iso9660-image" #:system system) ;; Only cross-compile Guix System images from x86_64-linux for now. ,@(if (string=? system "x86_64-linux") (map (cut image->job store <> #:system system) %guix-system-images) '())) '()))) (define* (system-test-jobs store system #:key source commit) "Return a list of jobs for the system tests." (define (->job test) (let ((name (string-append "test." (system-test-name test) "." system)) (drv (run-with-store store (mbegin %store-monad (set-current-system system) (set-grafting #f) (set-guile-for-build (default-guile)) (system-test-value test))))) (derivation->job name drv))) (if (member system %guix-system-supported-systems) ;; Override the value of 'current-guix' used by system tests. Using a ;; channel instance makes tests that rely on 'current-guix' less ;; expensive. It also makes sure we get a valid Guix package when this ;; code is not running from a checkout. (parameterize ((current-guix-package (channel-source->package source #:commit commit))) (map ->job (all-system-tests))) '())) (define (tarball-jobs store system) "Return jobs to build the self-contained Guix binary tarball." (define (->job name drv) (let ((name (string-append name "." system))) (parameterize ((%graft? #f)) (derivation->job name drv)))) ;; XXX: Add a job for the stable Guix? (list (->job "binary-tarball" (run-with-store store (mbegin %store-monad (set-guile-for-build (default-guile)) (>>= (profile-derivation (packages->manifest (list guix))) (lambda (profile) (self-contained-tarball "guix-binary" profile #:profile-name "current-guix" #:localstatedir? #t #:compressor (lookup-compressor "xz"))))) #:system system)))) (define job-name ;; Return the name of a package's job. package-name) (define base-packages (mlambda (system) "Return the set of packages considered to be part of the base for SYSTEM." (delete-duplicates (append-map (match-lambda ((_ package _ ...) (match (package-transitive-inputs package) (((_ inputs _ ...) ...) inputs)))) (%final-inputs system))))) (define package->job (lambda* (store package system #:key (suffix "")) "Return a job for PACKAGE on SYSTEM, or #f if this combination is not valid. Append SUFFIX to the job name." (cond ((member package (base-packages system)) (package-job store (string-append "base." (job-name package)) package system #:suffix suffix)) ((supported-package? package system) (let ((drv (package-derivation store package system #:graft? #f))) (and (substitutable-derivation? drv) (package-job store (job-name package) package system #:suffix suffix)))) (else #f)))) (define %x86-64-micro-architectures ;; Micro-architectures for which we build tuned variants. '("haswell" "skylake" "x86-64-v2" "x86-64-v3" "x86-64-v4")) (define (tuned-package-jobs store package system) "Return a list of jobs for PACKAGE tuned for SYSTEM's micro-architectures." (filter-map (lambda (micro-architecture) (define suffix (string-append "." micro-architecture)) (package->job store (tuned-package package micro-architecture) system #:suffix suffix)) (match system ("x86_64-linux" %x86-64-micro-architectures) (_ '())))) (define (all-packages) "Return the list of packages to build." (define (adjust package result) (cond ((package-replacement package) ;; XXX: If PACKAGE and its replacement have the same name/version, ;; then both Cuirass jobs will have the same name, which ;; effectively means that the second one will be ignored. Thus, ;; return the replacement first. (cons* (package-replacement package) ;build both package result)) ((package-superseded package) result) ;don't build it (else (cons package result)))) (fold-packages adjust (fold adjust '() ;include base packages (match (%final-inputs) (((labels packages _ ...) ...) packages))) #:select? (const #t))) ;include hidden packages (define (arguments->manifests arguments channels) "Return the list of manifests extracted from ARGUMENTS." (map (lambda (manifest) (any (lambda (checkout) (let ((path (in-vicinity checkout manifest))) (and (file-exists? path) path))) (map channel-url channels))) arguments)) (define (manifests->jobs store manifests systems) "Return the list of jobs for the entries in MANIFESTS, a list of file names, for each one of SYSTEMS." (define (load-manifest manifest) (save-module-excursion (lambda () (set-current-module (make-user-module '((guix profiles) (gnu)))) (primitive-load manifest)))) (define (manifest-entry-job-name entry) (string-append (manifest-entry-name entry) "-" (manifest-entry-version entry))) (define (manifest-entry->job entry system) (let* ((obj (manifest-entry-item entry)) (drv (parameterize ((%graft? #f)) (run-with-store store (lower-object obj system) #:system system))) (max-silent-time (or (and (package? obj) (assoc-ref (package-properties obj) 'max-silent-time)) 3600)) (timeout (or (and (package? obj) (assoc-ref (package-properties obj) 'timeout)) (* 5 3600)))) (derivation->job (manifest-entry-job-name entry) drv #:max-silent-time max-silent-time #:timeout timeout))) (let ((entries (delete-duplicates (append-map (compose manifest-entries load-manifest) manifests) manifest-entry=?))) (append-map (lambda (system) (map (cut manifest-entry->job <> system) entries)) systems))) (define (arguments->systems arguments) "Return the systems list from ARGUMENTS." (match (assoc-ref arguments 'systems) (#f %cuirass-supported-systems) ((lst ...) lst) ((? string? str) (call-with-input-string str read)))) ;;; ;;; Cuirass entry point. ;;; (define (cuirass-jobs store arguments) "Register Cuirass jobs." (define subset (assoc-ref arguments 'subset)) (define systems (arguments->systems arguments)) (define channels (let ((channels (assq-ref arguments 'channels))) (map sexp->channel channels))) (define guix (find guix-channel? channels)) (define commit (channel-commit guix)) (define source (channel-url guix)) ;; Turn off grafts. Grafting is meant to happen on the user's machines. (parameterize ((%graft? #f)) ;; Return one job for each package, except bootstrap packages. (append-map (lambda (system) (format (current-error-port) "evaluating for '~a' (heap size: ~a MiB)...~%" system (round (/ (assoc-ref (gc-stats) 'heap-size) (expt 2. 20)))) (invalidate-derivation-caches!) (match subset ('all ;; Build everything, including replacements. (let ((all (all-packages)) (jobs (lambda (package) (match (package->job store package system) (#f '()) (main-job (cons main-job (if (tunable-package? package) (tuned-package-jobs store package system) '()))))))) (append (append-map jobs all) (cross-jobs store system)))) ('core ;; Build core packages only. (append (map (lambda (package) (package-job store (job-name package) package system)) (append (commencement-packages system) %core-packages)) (cross-jobs store system))) ('guix ;; Build Guix modules only. (guix-jobs store systems #:source source #:commit commit)) ('hello ;; Build hello package only. (let ((hello (specification->package "hello"))) (list (package-job store (job-name hello) hello system)))) ('images ;; Build Guix System images only. (image-jobs store system #:source source #:commit commit)) ('system-tests ;; Build Guix System tests only. (system-test-jobs store system #:source source #:commit commit)) ('tarball ;; Build Guix tarball only. (tarball-jobs store system)) (('custom . modules) ;; Build custom modules jobs only. (append-map (lambda (module) (let ((proc (module-ref (resolve-interface module) 'cuirass-jobs))) (proc store arguments))) modules)) (('channels . channels) ;; Build only the packages from CHANNELS. (let ((all (all-packages))) (filter-map (lambda (package) (any (lambda (channel) (and (member (channel-name channel) channels) (package->job store package system))) (package-channels package))) all))) (('packages . rest) ;; Build selected list of packages only. (let ((packages (map specification->package rest))) (map (lambda (package) (package-job store (job-name package) package system)) packages))) (('manifests . rest) ;; Build packages in the list of manifests. (let ((manifests (arguments->manifests rest channels))) (manifests->jobs store manifests systems))) (else (error "unknown subset" subset)))) systems)))
generated by cgit