[bug#50296] [PATCH 2/2] scripts: home: Add import subcommand.

[Andrew Tropin <andrew@trop.in>]

[-- Attachment #1: Type: text/plain, Size: 12300 bytes --]

* guix/scripts/home/import.scm: New file.
* Makefile.am (MODULES): Add it.
---
 Makefile.am                  |   1 +
 guix/scripts/home.scm        |   2 +-
 guix/scripts/home/import.scm | 241 +++++++++++++++++++++++++++++++++++
 3 files changed, 243 insertions(+), 1 deletion(-)
 create mode 100644 guix/scripts/home/import.scm

diff --git a/Makefile.am b/Makefile.am
index d44360c034..c27dcf9a38 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -296,6 +296,7 @@ MODULES =					\
   guix/scripts/system/search.scm		\
   guix/scripts/system/reconfigure.scm		\
   guix/scripts/home.scm			\
+  guix/scripts/home/import.scm			\
   guix/scripts/lint.scm				\
   guix/scripts/challenge.scm			\
   guix/scripts/import/crate.scm			\
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 9eb5c0c917..75df6d707d 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -36,7 +36,7 @@
   #: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 scripts home import)
   #:use-module ((guix status) #:select (with-status-verbosity))
   #:use-module (guix gexp)
   #:use-module (guix monads)
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))))
-- 
2.33.0


[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 832 bytes --]