diff --git a/doc/guix.texi b/doc/guix.texi index 3d764e6021..a796d9c8f8 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -44265,18 +44265,12 @@ Essential Home Services be: @lisp -(use-modules (guix utils)) - (home-environment - - [...] - + ;; @dots{} (services (service home-dotfiles-service-type (home-dotfiles-configuration - (directories - (list (string-append (current-source-directory) - "/.dotfiles"))))))) + (directories (list "./dot-files")))))) @end lisp The expected home directory state would be: diff --git a/gnu/home/services.scm b/gnu/home/services.scm index 3e925c07c8..c7379c93c7 100644 --- a/gnu/home/services.scm +++ b/gnu/home/services.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021-2023 Andrew Tropin ;;; Copyright © 2021 Xinglu Chen -;;; Copyright © 2022-2023 Ludovic Courtès +;;; Copyright © 2022-2024 Ludovic Courtès ;;; Copyright © 2023 Carlo Zancanaro ;;; Copyright © 2023 Giacomo Leidi ;;; @@ -24,7 +24,7 @@ (define-module (gnu home services) #:use-module (gnu services) #:use-module ((gnu packages package-management) #:select (guix)) #:use-module ((gnu packages base) #:select (coreutils)) - #:use-module (guix build utils) + #:autoload (guix build utils) (find-files) #:use-module (guix channels) #:use-module (guix monads) #:use-module (guix store) @@ -32,6 +32,7 @@ (define-module (gnu home services) #:use-module (guix profiles) #:use-module (guix sets) #:use-module (guix ui) + #:use-module ((guix utils) #:select (current-source-directory)) #:use-module (guix discovery) #:use-module (guix diagnostics) #:use-module (guix i18n) @@ -43,7 +44,6 @@ (define-module (gnu home services) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 regex) - #:use-module (ice-9 string-fun) #:use-module (ice-9 vlist) #:export (home-service-type @@ -375,65 +375,69 @@ (define %home-dotfiles-excluded (define-record-type* home-dotfiles-configuration make-home-dotfiles-configuration home-dotfiles-configuration? + (source-directory home-dotfiles-configuration-source-directory + (default (current-source-directory)) + (innate)) (directories home-dotfiles-configuration-directories ;list of strings (default '())) (excluded home-dotfiles-configuration-excluded ;list of strings (default %home-dotfiles-excluded))) -(define* (import-dotfiles directory excluded) +(define (import-dotfiles directory files) "Return a list of objects compatible with @code{home-files-service-type}'s value. Each object is a pair where the first element is the relative path of a file and the second is a gexp representing the file content. Objects are generated by recursively visiting DIRECTORY and mapping its contents to the user's home directory, excluding files that match any of the patterns in EXCLUDED." - (define filtered - (find-files directory - (lambda (file stat) - (not (string-match - (string-append - "^.*(" (string-join excluded "|") ")$") file))))) (define (strip file) - (string-drop file (+ 1 (string-length directory)))) - (define (resolve file) - (if (eq? 'symlink (stat:type (lstat file))) - (let ((resolved (readlink file))) - (with-directory-excursion (dirname file) - (canonicalize-path resolved))) - file)) + (string-drop file (+ 1 (string-length directory)))) + (define (format file) - (let* ((without-spaces - (string-replace-substring file " " "_")) - (without-slashes-and-spaces - (string-replace-substring without-spaces "/" "-"))) - (string-append "home-dotfiles-" without-slashes-and-spaces))) + ;; Remove from FILE characters that cannot be used in the store. + (string-append + "home-dotfiles-" + (string-map (lambda (chr) + (if (and (char-set-contains? char-set:ascii chr) + (char-set-contains? char-set:graphic chr) + (not (memv chr '(#\. #\/)))) + chr + #\-)) + file))) (map (lambda (file) - (let* ((stripped (strip file))) + (let ((stripped (strip file))) (list stripped - (local-file (resolve file) (format stripped) + (local-file file (format stripped) #:recursive? #t)))) - filtered)) + files)) (define (home-dotfiles-configuration->files config) - "Return a list of objects compatible with @code{home-files-service-type}'s + "Return a list of objects compatible with @code{home-files-service-type}'s value, generated following GNU Stow's algorithm for each of the directories in CONFIG, excluding files that match any of the patterns configured." - (define (directory-contents directories) - (append-map - (lambda (directory) - (map - (lambda (content) - (with-directory-excursion directory - (canonicalize-path content))) - (scandir directory - (lambda (name) - (not (member name '("." ".."))))))) - directories)) - (append-map - (lambda (app) - (import-dotfiles app (home-dotfiles-configuration-excluded config))) - (directory-contents - (home-dotfiles-configuration-directories config)))) + (define excluded + (home-dotfiles-configuration-excluded config)) + (define exclusion-rx + (make-regexp (string-append "^.*(" (string-join excluded "|") ")$"))) + + (define (directory-contents directory) + (find-files directory + (lambda (file stat) + (not (regexp-exec exclusion-rx + (basename file)))))) + + (define (resolve directory) + ;; Resolve DIRECTORY relative to the 'source-directory' field of CONFIG. + (if (string-prefix? "/" directory) + directory + (in-vicinity (home-dotfiles-configuration-source-directory config) + directory))) + + (append-map (lambda (directory) + (let* ((directory (resolve directory)) + (contents (directory-contents directory))) + (import-dotfiles directory contents))) + (home-dotfiles-configuration-directories config))) (define-public home-dotfiles-service-type (service-type (name 'home-dotfiles)