home: services: Make strings in Gexps translateble.
* gnu/home/services.scm (%initialize-gettext): New variable. (compute-on-first-login-script): Use it. (compute-on-change-gexp): Likewise. * gnu/home/services/symlink-manager.scm (update-symlinks-script): Likewise. * po/guix/POTFILES.in: Add gnu/home-services.scm and gnu/home/services/symlink-manager.scm. Suggested-by: Ludovic Courtès <ludo@gnu.org> Link: <https://yhetil.org/guix-bugs/87sfvy8k1u.fsf@gnu.org> Signed-off-by: Ludovic Courtès <ludo@gnu.org>master
Xinglu Chen
Ludovic Courtès
parent
2719dfa631
commit
cde3376b35
|
|
@ -19,6 +19,7 @@
|
|||
|
||||
(define-module (gnu home services)
|
||||
#:use-module (gnu services)
|
||||
#:use-module ((gnu packages package-management) #:select (guix))
|
||||
#:use-module (guix channels)
|
||||
#:use-module (guix monads)
|
||||
#:use-module (guix store)
|
||||
|
|
@ -28,7 +29,7 @@
|
|||
#:use-module (guix ui)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix diagnostics)
|
||||
|
||||
#:use-module (guix i18n)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
|
||||
|
|
@ -41,7 +42,9 @@
|
|||
home-run-on-change-service-type
|
||||
home-provenance-service-type
|
||||
|
||||
fold-home-service-types)
|
||||
fold-home-service-types
|
||||
|
||||
%initialize-gettext)
|
||||
|
||||
#:re-export (service
|
||||
service-type
|
||||
|
|
@ -274,25 +277,38 @@ directory containing FILES."
|
|||
(description "Configuration files for programs that
|
||||
will be put in @file{~/.guix-home/files}.")))
|
||||
|
||||
(define %initialize-gettext
|
||||
#~(begin
|
||||
(bindtextdomain %gettext-domain
|
||||
(string-append #$guix "/share/locale"))
|
||||
(textdomain %gettext-domain)
|
||||
(setlocale LC_ALL "")))
|
||||
|
||||
(define (compute-on-first-login-script _ gexps)
|
||||
(program-file
|
||||
"on-first-login"
|
||||
#~(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
|
||||
(format #f "/run/user/~a" (getuid))))
|
||||
(flag-file-path (string-append
|
||||
xdg-runtime-dir "/on-first-login-executed"))
|
||||
(touch (lambda (file-name)
|
||||
(call-with-output-file file-name (const #t)))))
|
||||
;; XDG_RUNTIME_DIR dissapears on logout, that means such trick
|
||||
;; allows to launch on-first-login script on first login only
|
||||
;; after complete logout/reboot.
|
||||
(if (file-exists? xdg-runtime-dir)
|
||||
(unless (file-exists? flag-file-path)
|
||||
(begin #$@gexps (touch flag-file-path)))
|
||||
(display "XDG_RUNTIME_DIR doesn't exists, on-first-login script
|
||||
#~(begin
|
||||
(use-modules (guix i18n))
|
||||
#$%initialize-gettext
|
||||
|
||||
(let* ((xdg-runtime-dir (or (getenv "XDG_RUNTIME_DIR")
|
||||
(format #f "/run/user/~a" (getuid))))
|
||||
(flag-file-path (string-append
|
||||
xdg-runtime-dir "/on-first-login-executed"))
|
||||
(touch (lambda (file-name)
|
||||
(call-with-output-file file-name (const #t)))))
|
||||
;; XDG_RUNTIME_DIR dissapears on logout, that means such trick
|
||||
;; allows to launch on-first-login script on first login only
|
||||
;; after complete logout/reboot.
|
||||
(if (file-exists? xdg-runtime-dir)
|
||||
(unless (file-exists? flag-file-path)
|
||||
(begin #$@gexps (touch flag-file-path)))
|
||||
;; TRANSLATORS: 'on-first-login' is the name of a service and
|
||||
;; shouldn't be translated
|
||||
(display (G_ "XDG_RUNTIME_DIR doesn't exists, on-first-login script
|
||||
won't execute anything. You can check if xdg runtime directory exists,
|
||||
XDG_RUNTIME_DIR variable is set to appropriate value and manually execute the
|
||||
script by running '$HOME/.guix-home/on-first-login'")))))
|
||||
script by running '$HOME/.guix-home/on-first-login'")))))))
|
||||
|
||||
(define (on-first-login-script-entry on-first-login)
|
||||
"Return, as a monadic value, an entry for the on-first-login script
|
||||
|
|
@ -385,6 +401,10 @@ with one gexp, but many times, and all gexps must be idempotent.")))
|
|||
|
||||
(define (compute-on-change-gexp eval-gexps? pattern-gexp-tuples)
|
||||
#~(begin
|
||||
(use-modules (guix i18n))
|
||||
|
||||
#$%initialize-gettext
|
||||
|
||||
(define (equal-regulars? file1 file2)
|
||||
"Check if FILE1 and FILE2 are bit for bit identical."
|
||||
(let* ((cmp-binary #$(file-append
|
||||
|
|
@ -449,21 +469,23 @@ with one gexp, but many times, and all gexps must be idempotent.")))
|
|||
"/gnu/store/non-existing-generation")
|
||||
"/" (car x)))
|
||||
(file2 (string-append (getenv "GUIX_NEW_HOME") "/" (car x)))
|
||||
(_ (format #t "Comparing ~a and\n~10t~a..." file1 file2))
|
||||
(_ (format #t (G_ "Comparing ~a and\n~10t~a...") file1 file2))
|
||||
(any-changes? (something-changed? file1 file2))
|
||||
(_ (format #t " done (~a)\n"
|
||||
(_ (format #t (G_ " done (~a)\n")
|
||||
(if any-changes? "changed" "same"))))
|
||||
(if any-changes? (cadr x) "")))
|
||||
'#$pattern-gexp-tuples))
|
||||
|
||||
(if #$eval-gexps?
|
||||
(begin
|
||||
(display "Evaling on-change gexps.\n\n")
|
||||
;;; TRANSLATORS: 'on-change' is the name of a service type, it
|
||||
;;; probably shouldn't be translated.
|
||||
(display (G_ "Evaluating on-change gexps.\n\n"))
|
||||
(for-each primitive-eval expressions-to-eval)
|
||||
(display "On-change gexps evaluation finished.\n\n"))
|
||||
(display (G_ "On-change gexps evaluation finished.\n\n")))
|
||||
(display "\
|
||||
On-change gexps won't be evaluated, disabled by service
|
||||
configuration.\n"))))
|
||||
On-change gexps won't be evaluated; evaluation has been disabled in the
|
||||
service configuration"))))
|
||||
|
||||
(define home-run-on-change-service-type
|
||||
(service-type (name 'home-run-on-change)
|
||||
|
|
|
|||
|
|
@ -41,7 +41,9 @@
|
|||
(use-modules (ice-9 ftw)
|
||||
(ice-9 curried-definitions)
|
||||
(ice-9 match)
|
||||
(srfi srfi-1))
|
||||
(srfi srfi-1)
|
||||
(guix i18n))
|
||||
#$%initialize-gettext
|
||||
(define ((simplify-file-tree parent) file)
|
||||
"Convert the result produced by `file-system-tree' to less
|
||||
verbose and more suitable for further processing format.
|
||||
|
|
@ -139,20 +141,21 @@ appear only after all nested items already listed."
|
|||
(backup-file
|
||||
(lambda (path)
|
||||
(mkdir-p backup-dir)
|
||||
(format #t "Backing up ~a..." (get-target-path path))
|
||||
(format #t (G_ "Backing up ~a...") (get-target-path path))
|
||||
(mkdir-p (dirname (get-backup-path path)))
|
||||
(rename-file (get-target-path path) (get-backup-path path))
|
||||
(display " done\n")))
|
||||
(display (G_ " done\n"))))
|
||||
|
||||
(cleanup-symlinks
|
||||
(lambda ()
|
||||
(let ((to-delete ((file-tree-traverse #f) old-tree)))
|
||||
(display
|
||||
"Cleaning up symlinks from previous home-environment.\n\n")
|
||||
(G_
|
||||
"Cleaning up symlinks from previous home-environment.\n\n"))
|
||||
(map
|
||||
(match-lambda
|
||||
(('dir . ".")
|
||||
(display "Cleanup finished.\n\n"))
|
||||
(display (G_ "Cleanup finished.\n\n")))
|
||||
|
||||
(('dir . path)
|
||||
(if (and
|
||||
|
|
@ -160,12 +163,13 @@ appear only after all nested items already listed."
|
|||
(directory? (get-target-path path))
|
||||
(empty-directory? (get-target-path path)))
|
||||
(begin
|
||||
(format #t "Removing ~a..."
|
||||
(format #t (G_ "Removing ~a...")
|
||||
(get-target-path path))
|
||||
(rmdir (get-target-path path))
|
||||
(display " done\n"))
|
||||
(display (G_ " done\n")))
|
||||
(format
|
||||
#t "Skipping ~a (not an empty directory)... done\n"
|
||||
#t
|
||||
(G_ "Skipping ~a (not an empty directory)... done\n")
|
||||
(get-target-path path))))
|
||||
|
||||
(('file . path)
|
||||
|
|
@ -175,12 +179,12 @@ appear only after all nested items already listed."
|
|||
;; up later during create-symlinks phase.
|
||||
(if (symlink-to-store? (get-target-path path))
|
||||
(begin
|
||||
(format #t "Removing ~a..." (get-target-path path))
|
||||
(format #t (G_ "Removing ~a...") (get-target-path path))
|
||||
(delete-file (get-target-path path))
|
||||
(display " done\n"))
|
||||
(display (G_ " done\n")))
|
||||
(format
|
||||
#t
|
||||
"Skipping ~a (not a symlink to store)... done\n"
|
||||
(G_ "Skipping ~a (not a symlink to store)... done\n")
|
||||
(get-target-path path))))))
|
||||
to-delete))))
|
||||
|
||||
|
|
@ -191,9 +195,9 @@ appear only after all nested items already listed."
|
|||
(match-lambda
|
||||
(('dir . ".")
|
||||
(display
|
||||
"New symlinks to home-environment will be created soon.\n")
|
||||
(G_ "New symlinks to home-environment will be created soon.\n"))
|
||||
(format
|
||||
#t "All conflicting files will go to ~a.\n\n" backup-dir))
|
||||
#t (G_ "All conflicting files will go to ~a.\n\n") backup-dir))
|
||||
|
||||
(('dir . path)
|
||||
(let ((target-path (get-target-path path)))
|
||||
|
|
@ -203,20 +207,20 @@ appear only after all nested items already listed."
|
|||
|
||||
(if (file-exists? target-path)
|
||||
(format
|
||||
#t "Skipping ~a (directory already exists)... done\n"
|
||||
#t (G_ "Skipping ~a (directory already exists)... done\n")
|
||||
target-path)
|
||||
(begin
|
||||
(format #t "Creating ~a..." target-path)
|
||||
(format #t (G_ "Creating ~a...") target-path)
|
||||
(mkdir target-path)
|
||||
(display " done\n")))))
|
||||
(display (G_ " done\n"))))))
|
||||
|
||||
(('file . path)
|
||||
(when (file-exists? (get-target-path path))
|
||||
(backup-file path))
|
||||
(format #t "Symlinking ~a -> ~a..."
|
||||
(format #t (G_ "Symlinking ~a -> ~a...")
|
||||
(get-target-path path) (get-source-path path))
|
||||
(symlink (get-source-path path) (get-target-path path))
|
||||
(display " done\n")))
|
||||
(display (G_ " done\n"))))
|
||||
to-create)))))
|
||||
|
||||
(when old-tree
|
||||
|
|
@ -227,7 +231,7 @@ appear only after all nested items already listed."
|
|||
(symlink new-home new-he-path)
|
||||
(rename-file new-he-path he-path)
|
||||
|
||||
(display " done\nFinished updating symlinks.\n\n")))))
|
||||
(display (G_" done\nFinished updating symlinks.\n\n"))))))
|
||||
|
||||
|
||||
(define (update-symlinks-gexp _)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ gnu/packages.scm
|
|||
gnu/services.scm
|
||||
gnu/system.scm
|
||||
gnu/services/shepherd.scm
|
||||
gnu/home/services.scm
|
||||
gnu/home/services/symlink-manager.scm
|
||||
gnu/system/file-systems.scm
|
||||
gnu/system/image.scm
|
||||
gnu/system/linux-container.scm
|
||||
|
|
|
|||
Reference in New Issue