123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203 |
- (define-module (guix scripts home import)
- #:use-module (guix profiles)
- #:use-module (guix ui)
- #:use-module (guix utils)
- #:use-module (guix packages)
- #:autoload (guix scripts package) (manifest-entry-version-prefix)
- #:use-module (guix read-print)
- #:use-module (gnu packages)
- #:use-module (ice-9 match)
- #:use-module (ice-9 rdelim)
- #:use-module (ice-9 regex)
- #:use-module (ice-9 popen)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-26)
- #:export (import-manifest
-
- manifest+configuration-files->code))
- (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))
- (define alias-rx
- (make-regexp "^alias ([^=]+)=[\"'](.+)[\"']$"))
- (define (bash-alias->pair line)
- (match (regexp-exec alias-rx line)
- (#f #f)
- (matched
- `(,(match:substring matched 1) . ,(match:substring matched 2)))))
- (define (parse-aliases input)
- (let loop ((result '()))
- (match (read-line input)
- ((? eof-object?)
- (reverse result))
- (line
- (match (bash-alias->pair line)
- (#f (loop result))
- (alias (loop (cons alias result))))))))
- (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)
- `((aliases
- ',(let* ((port (open-pipe* OPEN_READ "bash" "-i" "-c" "alias"))
- (alist (parse-aliases port)))
- (close-port port)
- alist)))
- '())
- ,@(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)))
- ,(vertical-space 1)
- (home-environment
- ,( (G_ "\
- ;; Below is the list of packages that will show up in your
- ;; Home profile, under ~/.guix-home/profile.\n"))
- (packages
- (specifications->packages ,packages))
- ,(vertical-space 1)
- ,( (G_ "\
- ;; Below is the list of Home services. To search for available
- ;; services, run 'guix home search KEYWORD' in a terminal.\n"))
- (services (list ,@services)))))))))
- (define* (import-manifest
- manifest destination-directory
- #:optional (port (current-output-port)))
- "Write to PORT a <home-environment> corresponding to MANIFEST."
- (match (manifest+configuration-files->code manifest
- destination-directory)
- (('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"))
- (newline port)
- (pretty-print-with-comments/splice port exp))))
|