scripts: home: Add import subcommand.

* guix/scripts/home/import.scm: New file.
* Makefile.am (MODULES): Add it.

Signed-off-by: Oleg Pykhalov <go.wigust@gmail.com>
This commit is contained in:
Andrew Tropin 2021-08-31 12:40:58 +03:00 committed by Oleg Pykhalov
parent 89e05a6955
commit 879abff4fd
No known key found for this signature in database
GPG Key ID: 167F8EA5001AFA9C
3 changed files with 243 additions and 1 deletions

View File

@ -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 \

View File

@ -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)

View File

@ -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))))