* guix/scripts/home.scm (show-help): Add ‘import’ command.
(process-command): Likewise.
(manifest->code, home-environment-template, import-manifest): New
procedures.
---
guix/scripts/home.scm | 193 ++++++++++++++++++++++++++++++++++++++++--
1 file changed, 185 insertions(+), 8 deletions(-)
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 11b3d6c..8bebab0 100644
--- a/guix/scripts/home.scm+++ b/guix/scripts/home.scm
@@ -1,6 +1,7 @@
(define-module (guix scripts home)
#:use-module (gnu packages admin)
#:use-module (gnu services)
+ #:use-module (gnu packages) #:use-module (gnu home)
#:use-module (gnu home-services)
#:use-module (guix channels)
@@ -9,7 +10,7 @@
#:use-module (guix ui)
#:use-module (guix grafts)
#:use-module (guix packages)
- #:use-module (guix profiles)+ #:use-module ((guix profiles) #:hide (manifest->code)) #:use-module (guix store)
#:use-module (guix utils)
#:use-module (guix scripts)
@@ -57,6 +58,8 @@ Some ACTIONS support additional ARGS.\n"))
delete-generations delete old home environment generations\n"))
(display (G_ "\
build build the home environment without installing anything\n"))
+ (display (G_ "\+ import print a home environment file for a profile")) ;; (show-build-options-help)
(newline)
@@ -200,13 +203,24 @@ resulting from command-line parsing."
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 ...))+ (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 operating 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
@@ -224,21 +238,21 @@ argument list and OPTS is the option alist."
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
(with-store* store
- (switch-to-home-environment-generation store pattern))))+ (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))))+ (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))))+ store+ (delete-matching-generations store %guix-home pattern)))) (else (process-action command args opts))))
(define-command (guix-home . args)
@@ -255,7 +269,8 @@ argument list and OPTS is the option alist."
extension-graph shepherd-graph
list-generations describe
delete-generations roll-back
- switch-generation search)+ switch-generation search+ import) (alist-cons 'action action result))
(else (leave (G_ "~a: unknown action~%") action))))))
@@ -463,3 +478,165 @@ SPEC. STORE is an open connection to the store."
STORE is an open connection to the store."
(switch-to-home-environment-generation store "-1"))
+++;;;+;;; Import.+;;;++;; Based on `manifest->code' from (guix profiles)+(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?+ `(begin+ (use-modules (gnu home)+ (gnu packages))+ ,(home-environment-template #:specs specs))+ `(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?+ `(begin+ (use-modules (guix transformations)+ (gnu home)+ (gnu packages))++ ,@transformations++ ,(home-environment-template #:packages packages))+ `(begin+ (use-modules (guix transformations)+ (gnu packages))++ ,@transformations++ (packages->manifest+ (list ,@packages)))))))++(define* (home-environment-template #:key (packages #f) (specs #f))+ "Return an S-exp containing a <home-environment> declaration+containing PACKAGES, or SPECS (package specifications)."+ `(home-environment+ (home-directory ,(getenv "HOME"))+ (packages+ ,@(if packages+ `((list ,@packages))+ `((map specification->package+ (list ,@specs)))))))++;; TODO: Read ~/ and generate service configurations+(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))))
base-commit: 6d40090ef287a4523fee32d4350b4dcd5fe90f0b
--
2.32.0