summaryrefslogtreecommitdiff
path: root/guix/scripts/home/import.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/scripts/home/import.scm')
-rw-r--r--guix/scripts/home/import.scm301
1 files changed, 110 insertions, 191 deletions
diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
index 611f580e85..7a7712dd96 100644
--- a/guix/scripts/home/import.scm
+++ b/guix/scripts/home/import.scm
@@ -1,6 +1,7 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -22,12 +23,16 @@
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix packages)
+ #:autoload (guix scripts package) (manifest-entry-version-prefix)
#:use-module (gnu packages)
#:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26)
- #:export (import-manifest))
+ #:export (import-manifest
+
+ ;; For tests.
+ manifest+configuration-files->code))
;;; Commentary:
;;;
@@ -36,200 +41,114 @@
;;;
;;; 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 (local-file ,rc))))
- '())
- ,@(if (file-exists? profile)
- `((bash-profile
- (list (local-file ,profile))))
- '())
- ,@(if (file-exists? logout)
- `((bash-logout
- (list (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 (basename+remove-dots file-name)
+ "Remove the dot from the dotfile FILE-NAME; replace the other dots in
+FILE-NAME with \"-\", and return the basename of it."
+ (string-map (match-lambda
+ (#\. #\-)
+ (c c))
+ (let ((base (basename file-name)))
+ (if (string-prefix? "." base)
+ (string-drop base 1)
+ base))))
+
+(define (generate-bash-configuration+modules destination-directory)
+ (define (destination-append path)
+ (string-append destination-directory "/" path))
+
+ (let ((rc (destination-append ".bashrc"))
+ (profile (destination-append ".bash_profile"))
+ (logout (destination-append ".bash_logout")))
+ `((service home-bash-service-type
+ (home-bash-configuration
+ ,@(if (file-exists? rc)
+ `((bashrc
+ (list (local-file ,rc
+ ,(basename+remove-dots rc)))))
+ '())
+ ,@(if (file-exists? profile)
+ `((bash-profile
+ (list (local-file ,profile
+ ,(basename+remove-dots profile)))))
+ '())
+ ,@(if (file-exists? logout)
+ `((bash-logout
+ (list (local-file ,logout
+ ,(basename+remove-dots logout)))))
+ '())))
+ (guix gexp)
+ (gnu home services shells))))
+
+(define %files+configurations-alist
+ `((".bashrc" . ,generate-bash-configuration+modules)
+ (".bash_profile" . ,generate-bash-configuration+modules)
+ (".bash_logout" . ,generate-bash-configuration+modules)))
+
+(define (configurations+modules configuration-directory)
+ "Return a list of procedures which when called, generate code for a home
+service declaration. Copy configuration files to CONFIGURATION-DIRECTORY; the
+generated service declarations will refer to those files that have been saved
+in CONFIGURATION-DIRECTORY."
+ (define configurations
+ (delete-duplicates
+ (filter-map (match-lambda
+ ((file . proc)
+ (let ((absolute-path (string-append (getenv "HOME")
+ "/" file)))
+ (and (file-exists? absolute-path)
+ (begin
+ (copy-file absolute-path
+ (string-append
+ configuration-directory "/" file))
+ proc)))))
+ %files+configurations-alist)
+ eq?))
+
+ (map (lambda (proc) (proc configuration-directory)) configurations))
+
+(define (manifest+configuration-files->code manifest
+ configuration-directory)
+ "Read MANIFEST and the user's configuration files listed in
+%FILES+CONFIGURATIONS-ALIST, and return a 'home-environment' sexp. Copy the
+user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them."
+ (match (manifest->code manifest
+ #:entry-package-version
+ manifest-entry-version-prefix)
+ (('begin ('use-modules profile-modules ...)
+ definitions ... ('packages->manifest packages))
+ (match (configurations+modules configuration-directory)
+ (((services . modules) ...)
+ `(begin
+ (use-modules (gnu home)
+ (gnu packages)
+ (gnu services)
+ ,@(delete-duplicates
+ (append profile-modules (concatenate modules))))
+
+ ,@definitions
+
+ (home-environment
+ (packages ,packages)
+ (services (list ,@services)))))))
+ (('begin ('specifications->manifest packages))
+ (match (configurations+modules configuration-directory)
+ (((services . modules) ...)
+ `(begin
+ (use-modules (gnu home)
+ (gnu packages)
+ (gnu services)
+ ,@(delete-duplicates (concatenate modules)))
+
+ (home-environment
+ (packages (map specification->package ,packages))
+ (services (list ,@services)))))))))
(define* (import-manifest
- manifest
+ manifest destination-directory
#: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)
+ (match (manifest+configuration-files->code manifest
+ destination-directory)
(('begin exp ...)
(format port (G_ "\
;; This \"home-environment\" file can be passed to 'guix home reconfigure'
generated by cgit v1.2.3 (git 2.45.2) at 2024-06-29 07:59:27 +0000