01/08: describe: Add 'current-profile-date'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit cd2e4b2a8dbded85f7183d86be0747707e55d49e
Author: Ludovic Courtès <address@hidden>
Date:   Sun Mar 17 17:01:56 2019 +0100

    describe: Add 'current-profile-date'.
    
    * guix/describe.scm (current-profile-date): New procedure.
---
 guix/describe.scm | 25 ++++++++++++++++++++++++-
 1 file changed, 24 insertions(+), 1 deletion(-)

diff --git a/guix/describe.scm b/guix/describe.scm
index 00372bb..893dca2 100644
--- a/guix/describe.scm
+++ b/guix/describe.scm
@@ -21,10 +21,12 @@
   #:use-module (guix profiles)
   #:use-module (guix packages)
   #:use-module ((guix utils) #:select (location-file))
-  #:use-module ((guix store) #:select (%store-prefix))
+  #:use-module ((guix store) #:select (%store-prefix store-path?))
+  #:use-module ((guix config) #:select (%state-directory))
   #:use-module (srfi srfi-1)
   #:use-module (ice-9 match)
   #:export (current-profile
+            current-profile-date
             current-profile-entries
             package-path-entries
 
@@ -55,6 +57,27 @@ or #f if this is not applicable."
               (and (file-exists? (string-append candidate "/manifest"))
                    candidate)))))))
 
+(define (current-profile-date)
+  "Return the creation date of the current profile (produced by 'guix pull'),
+as a number of seconds since the Epoch, or #f if it could not be determined."
+  ;; Normally 'current-profile' will return ~/.config/guix/current.  We need
+  ;; to 'readlink' once to get '/var/guix/…/guix-profile', whose mtime is the
+  ;; piece of information we're looking for.
+  (let loop ((profile (current-profile)))
+    (match profile
+      (#f #f)
+      ((? store-path?) #f)
+      (file
+       (if (string-prefix? %state-directory file)
+           (and=> (lstat file) stat:mtime)
+           (catch 'system-error
+             (lambda ()
+               (let ((target (readlink file)))
+                 (loop (if (string-prefix? "/" target)
+                           target
+                           (string-append (dirname file) "/" target)))))
+             (const #f)))))))
+
 (define current-profile-entries
   (mlambda ()
     "Return the list of entries in the 'guix pull' profile the calling process