diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2022-07-31 23:00:53 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2022-08-01 00:02:04 +0200 |
| commit | 61db74a687e36e842077c5c2f4b2e2c7afcd814a (patch) | |
| tree | 6a0db8e58d340b8ab0bd48cdc611fc886b95fef6 | |
| parent | a3a6931c75c899ad749e5bc8965ec5b5ed55451d (diff) | |
| download | guix-61db74a687e36e842077c5c2f4b2e2c7afcd814a.tar.gz | |
home: Add 'home-generation-base'.
This reverts commit 670818a4049edb8a77a5b596fbc7558bde57165c, thereby reinstating 5df8f7802e8b45855e8f84830677001dc631e4f7. * gnu/home.scm (%profile-generation-rx): New variable. (home-generation-base): New procedure.
| -rw-r--r-- | gnu/home.scm | 26 |
1 files changed, 24 insertions, 2 deletions
diff --git a/gnu/home.scm b/gnu/home.scm index a9f0a469a5..4ddbafe412 100644 --- a/gnu/home.scm +++ b/gnu/home.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,7 +28,8 @@ #:use-module (guix diagnostics) #:use-module (guix gexp) #:use-module (guix store) - + #:use-module (ice-9 match) + #:use-module (ice-9 regex) #:export (home-environment home-environment? this-home-environment @@ -38,7 +40,9 @@ home-environment-services home-environment-location - home-environment-with-provenance)) + home-environment-with-provenance + + home-generation-base)) ;;; Comment: ;;; @@ -114,3 +118,21 @@ of HOME-PROVENANCE-SERVICE-TYPE to its services." (run-with-store store (home-environment-derivation he) #:system system #:target target))))) + +(define %profile-generation-rx + ;; Regexp that matches profile generation. + (make-regexp "(.*)-([0-9]+)-link$")) + +(define (home-generation-base file) + "If FILE is a Home generation GC root such as \"guix-home-42-link\", +return its corresponding base---e.g., \"guix-home\". Otherwise return #f. + +This is similar to the 'generation-profile' procedure but applied to Home +generations." + (match (regexp-exec %profile-generation-rx file) + (#f #f) + (m (let ((profile (match:substring m 1))) + ;; Distinguish from a "real" profile and from a system generation. + (and (file-exists? (string-append profile "/on-first-login")) + (file-exists? (string-append profile "/profile/manifest")) + profile))))) |