~abcdw/rde-devel

guix: scripts: home: Add ‘import’ command. v1 APPLIED

Xinglu Chen: 1
 guix: scripts: home: Add ‘import’ command.

 1 files changed, 185 insertions(+), 8 deletions(-)
Export patchset (mbox)
How do I use this?

Copy & paste the following snippet into your terminal to import this patchset into git:

curl -s https://lists.sr.ht/~abcdw/rde-devel/patches/23373/mbox | git am -3
Learn more about email & git
View this thread in the archives

[PATCH] guix: scripts: home: Add ‘import’ command. Export this patch

* 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
Xinglu Chen <public@yoctocell.xyz> writes: