summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorOleg Pykhalov <go.wigust@gmail.com>2021-09-27 17:27:12 +0300
committerOleg Pykhalov <go.wigust@gmail.com>2021-09-27 17:27:12 +0300
commit6ae4644984608b7eff7ab54d3a5787c661d85b2e (patch)
tree170f992d865b7f511d820a725754bc00e42b0451 /guix
parent86d316b3346eac29c7e466f66b4422067c1cdb96 (diff)
parenta2b937984a502f7129f3b84f631be92dde689022 (diff)
Merge branch 'wip-guix-home'
Diffstat (limited to 'guix')
-rw-r--r--guix/scripts/home.scm512
-rw-r--r--guix/scripts/home/import.scm241
-rw-r--r--guix/self.scm13
3 files changed, 765 insertions, 1 deletions
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
new file mode 100644
index 0000000000..75df6d707d
--- /dev/null
+++ b/guix/scripts/home.scm
@@ -0,0 +1,512 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; 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)
+ #:use-module (gnu home)
+ #:use-module (gnu home-services)
+ #:use-module (guix channels)
+ #:use-module (guix derivations)
+ #:use-module (guix ui)
+ #:use-module (guix grafts)
+ #:use-module (guix packages)
+ #:use-module (guix profiles)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix scripts)
+ #:use-module (guix scripts package)
+ #:use-module (guix scripts build)
+ #:use-module (guix scripts system search)
+ #:autoload (guix scripts pull) (channel-commit-hyperlink)
+ #:use-module (guix scripts home import)
+ #:use-module ((guix status) #:select (with-status-verbosity))
+ #: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 (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_ "\
+ 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"))
+
+ (show-build-options-help)
+ (display (G_ "
+ -v, --verbosity=LEVEL use the given verbosity LEVEL"))
+ (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)
+ 2 1)))
+
+(define %options
+ ;; Specification of the command-line options.
+ (cons* (option '(#\h "help") #f #f
+ (lambda args
+ (show-help)
+ (exit 0)))
+ (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)))))
+ %standard-build-options))
+
+(define %default-options
+ `((build-mode . ,(build-mode normal))
+ (graft? . #t)
+ (substitutes? . #t)
+ (offload? . #t)
+ (print-build-trace? . #t)
+ (print-extended-build-trace? . #t)
+ (multiplexed-build-output? . #t)
+ (verbosity . 3)
+ (debug . 0)))
+
+
+;;;
+;;; Actions.
+;;;
+
+(define* (perform-action action he
+ #:key
+ dry-run?
+ derivations-only?
+ use-substitutes?)
+ "Perform ACTION for home environment. "
+
+ (define println
+ (cut format #t "~a~%" <>))
+
+ (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)
+ (begin
+ (for-each (compose println derivation->output-path) drvs)
+
+ (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)))
+ (else
+ (newline)
+ (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)
+ (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~%")))))))
+
+ (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))
+
+ (case action
+ (else
+ (perform-action action home-environment
+ #:dry-run? dry?
+ #:derivations-only? (assoc-ref opts 'derivations-only?)
+ #:use-substitutes? (assoc-ref opts 'substitutes?))
+ ))))))
+ (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))))
+ (import-manifest manifest (current-output-port))))
+ ((describe)
+ (match (generation-number %guix-home)
+ (0
+ (error (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)
+ (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))
+
+ (with-error-handling
+ (let* ((opts (parse-command-line args %options
+ (list %default-options)
+ #:argument-handler
+ parse-sub-command))
+ (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
+ #: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"))
diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
new file mode 100644
index 0000000000..39f45dbeac
--- /dev/null
+++ b/guix/scripts/home/import.scm
@@ -0,0 +1,241 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;;
+;;; 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 import)
+ #:use-module (guix profiles)
+ #:use-module (guix ui)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 pretty-print)
+ #:use-module (srfi srfi-1)
+ #:export (import-manifest))
+
+;;; Commentary:
+;;;
+;;; This module provides utilities for generating home service
+;;; configurations from existing "dotfiles".
+;;;
+;;; Code:
+
+
+(define (generate-bash-module+configuration)
+ (let ((rc (string-append (getenv "HOME") "/.bashrc"))
+ (profile (string-append (getenv "HOME") "/.bash_profile"))
+ (logout (string-append (getenv "HOME") "/.bash_logout")))
+ `((gnu home-services bash)
+ (service home-bash-service-type
+ (home-bash-configuration
+ ,@(if (file-exists? rc)
+ `((bashrc
+ (list (slurp-file-gexp (local-file ,rc)))))
+ '())
+ ,@(if (file-exists? profile)
+ `((bash-profile
+ (list (slurp-file-gexp
+ (local-file ,profile)))))
+ '())
+ ,@(if (file-exists? logout)
+ `((bash-logout
+ (list (slurp-file-gexp
+ (local-file ,logout)))))
+ '()))))))
+
+
+(define %files-configurations-alist
+ `((".bashrc" . ,generate-bash-module+configuration)
+ (".bash_profile" . ,generate-bash-module+configuration)
+ (".bash_logout" . ,generate-bash-module+configuration)))
+
+(define (modules+configurations)
+ (let ((configurations (delete-duplicates
+ (filter-map (match-lambda
+ ((file . proc)
+ (if (file-exists?
+ (string-append (getenv "HOME") "/" file))
+ proc
+ #f)))
+ %files-configurations-alist)
+ (lambda (x y)
+ (equal? (procedure-name x) (procedure-name y))))))
+ (map (lambda (proc) (proc)) configurations)))
+
+;; Based on `manifest->code' from (guix profiles)
+;; MAYBE: Upstream it?
+(define* (manifest->code manifest
+ #:key
+ (entry-package-version (const ""))
+ (home-environment? #f))
+ "Return an sexp representing code to build an approximate version of
+MANIFEST; the code is wrapped in a top-level 'begin' form. If
+HOME-ENVIRONMENT? is #t, return an <home-environment> definition.
+Call ENTRY-PACKAGE-VERSION to determine the version number to use in
+the spec for a given entry; it can be set to 'manifest-entry-version'
+for fully-specified version numbers, or to some other procedure to
+disambiguate versions for packages for which several versions are
+available."
+ (define (entry-transformations entry)
+ ;; Return the transformations that apply to ENTRY.
+ (assoc-ref (manifest-entry-properties entry) 'transformations))
+
+ (define transformation-procedures
+ ;; List of transformation options/procedure name pairs.
+ (let loop ((entries (manifest-entries manifest))
+ (counter 1)
+ (result '()))
+ (match entries
+ (() result)
+ ((entry . tail)
+ (match (entry-transformations entry)
+ (#f
+ (loop tail counter result))
+ (options
+ (if (assoc-ref result options)
+ (loop tail counter result)
+ (loop tail (+ 1 counter)
+ (alist-cons options
+ (string->symbol
+ (format #f "transform~a" counter))
+ result)))))))))
+
+ (define (qualified-name entry)
+ ;; Return the name of ENTRY possibly with "@" followed by a version.
+ (match (entry-package-version entry)
+ ("" (manifest-entry-name entry))
+ (version (string-append (manifest-entry-name entry)
+ "@" version))))
+
+ (if (null? transformation-procedures)
+ (let ((specs (map (lambda (entry)
+ (match (manifest-entry-output entry)
+ ("out" (qualified-name entry))
+ (output (string-append (qualified-name entry)
+ ":" output))))
+ (manifest-entries manifest))))
+ (if home-environment?
+ (let ((modules+configurations (modules+configurations)))
+ `(begin
+ (use-modules (gnu home)
+ (gnu packages)
+ ,@(map first modules+configurations))
+ ,(home-environment-template
+ #:specs specs
+ #:services (map second modules+configurations))))
+ `(begin
+ (use-modules (gnu packages))
+
+ (specifications->manifest
+ (list ,@specs)))))
+ (let* ((transform (lambda (options exp)
+ (if (not options)
+ exp
+ (let ((proc (assoc-ref transformation-procedures
+ options)))
+ `(,proc ,exp)))))
+ (packages (map (lambda (entry)
+ (define options
+ (entry-transformations entry))
+
+ (define name
+ (qualified-name entry))
+
+ (match (manifest-entry-output entry)
+ ("out"
+ (transform options
+ `(specification->package ,name)))
+ (output
+ `(list ,(transform
+ options
+ `(specification->package ,name))
+ ,output))))
+ (manifest-entries manifest)))
+ (transformations (map (match-lambda
+ ((options . name)
+ `(define ,name
+ (options->transformation ',options))))
+ transformation-procedures)))
+ (if home-environment?
+ (let ((modules+configurations (modules+configurations)))
+ `(begin
+ (use-modules (guix transformations)
+ (gnu home)
+ (gnu packages)
+ ,@(map first modules+configurations))
+
+ ,@transformations
+
+ ,(home-environment-template
+ #:packages packages
+ #:services (map second modules+configurations))))
+ `(begin
+ (use-modules (guix transformations)
+ (gnu packages))
+
+ ,@transformations
+
+ (packages->manifest
+ (list ,@packages)))))))
+
+(define* (home-environment-template #:key (packages #f) (specs #f) services)
+ "Return an S-exp containing a <home-environment> declaration
+containing PACKAGES, or SPECS (package specifications), and SERVICES."
+ `(home-environment
+ (packages
+ ,@(if packages
+ `((list ,@packages))
+ `((map specification->package
+ (list ,@specs)))))
+ (services (list ,@services))))
+
+(define* (import-manifest
+ manifest
+ #:optional (port (current-output-port)))
+ "Write to PORT a <home-environment> corresponding to MANIFEST."
+ (define (version-spec entry)
+ (let ((name (manifest-entry-name entry)))
+ (match (map package-version (find-packages-by-name name))
+ ((_)
+ ;; A single version of NAME is available, so do not specify the
+ ;; version number, even if the available version doesn't match ENTRY.
+ "")
+ (versions
+ ;; If ENTRY uses the latest version, don't specify any version.
+ ;; Otherwise return the shortest unique version prefix. Note that
+ ;; this is based on the currently available packages, which could
+ ;; differ from the packages available in the revision that was used
+ ;; to build MANIFEST.
+ (let ((current (manifest-entry-version entry)))
+ (if (every (cut version>? current <>)
+ (delete current versions))
+ ""
+ (version-unique-prefix (manifest-entry-version entry)
+ versions)))))))
+
+ (match (manifest->code manifest
+ #:entry-package-version version-spec
+ #:home-environment? #t)
+ (('begin exp ...)
+ (format port (G_ "\
+;; This \"home-environment\" file can be passed to 'guix home reconfigure'
+;; to reproduce the content of your profile. This is \"symbolic\": it only
+;; specifies package names. To reproduce the exact same profile, you also
+;; need to capture the channels being used, as returned by \"guix describe\".
+;; See the \"Replicating Guix\" section in the manual.\n"))
+ (for-each (lambda (exp)
+ (newline port)
+ (pretty-print exp port))
+ exp))))
diff --git a/guix/self.scm b/guix/self.scm
index 79d93357a2..5922ea6aa1 100644
--- a/guix/self.scm
+++ b/guix/self.scm
@@ -958,13 +958,23 @@ itself."
#:guile-for-build
guile-for-build))
+ (define *home-modules*
+ (scheme-node "guix-home"
+ `((gnu home)
+ (gnu home-services)
+ ,@(scheme-modules* source "gnu/home-services"))
+ (list *core-package-modules* *package-modules*
+ *extra-modules* *core-modules* *system-modules*)
+ #:extensions dependencies
+ #:guile-for-build guile-for-build))
+
(define *cli-modules*
(scheme-node "guix-cli"
(append (scheme-modules* source "/guix/scripts")
`((gnu ci)))
(list *core-modules* *extra-modules*
*core-package-modules* *package-modules*
- *system-modules*)
+ *system-modules* *home-modules*)
#:extensions dependencies
#:guile-for-build guile-for-build))
@@ -1012,6 +1022,7 @@ itself."
*cli-modules*
*system-test-modules*
*system-modules*
+ *home-modules*
*package-modules*
*core-package-modules*
*extra-modules*