04/07: home: Add 'home-generation-base'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 61db74a687e36e842077c5c2f4b2e2c7afcd814a
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Jul 31 23:00:53 2022 +0200

    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.
---
 gnu/home.scm | 26 ++++++++++++++++++++++++--
 1 file 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)))))