patched-guix/guix/scripts/home/import.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se>
;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
;;;
;;; 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 (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

            ;; For tests.
            manifest+configuration-files->code))

;;; Commentary:
;;;
;;; This module provides utilities for generating home service
;;; configurations from existing "dotfiles".
;;;
;;; 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
            ,(comment (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)
            ,(comment (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))))