[bug#50960] [PATCH 10/10] shell: Maintain a profile cache.

[Ludovic Courtès]

With this change, running "guix shell" (no arguments) is equivalent to:

  guix environment -r ~/.cache/guix/profiles/some-root -l guix.scm

This is the cache miss.  On cache hit, it's equivalent to:

  guix environment -p ~/.cache/guix/profiles/some-root

... which can run in 0.1s.

* guix/scripts/shell.scm (auto-detect-manifest): Looked for a cached GC
root to the profile and use it.
(%profile-cache-directory): New variable.
(profile-cache-key, profile-cached-gc-root): New procedures.
(guix-shell)[cache-entries, entry-expiration]: New procedures.
Add call to 'maybe-remove-expired-cache-entries'.
---
 guix/scripts/shell.scm | 90 +++++++++++++++++++++++++++++++++++++++---
 1 file changed, 84 insertions(+), 6 deletions(-)

diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 2f15befbd3..7c116cc770 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -29,6 +29,15 @@
   #:use-module (srfi srfi-37)
   #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
+  #:autoload   (guix base32) (bytevector->base32-string)
+  #:autoload   (rnrs bytevectors) (string->utf8)
+  #:autoload   (guix utils) (cache-directory)
+  #:autoload   (guix describe) (current-channels)
+  #:autoload   (guix channels) (channel-commit)
+  #:autoload   (gcrypt hash) (sha256)
+  #:use-module ((guix build utils) #:select (mkdir-p))
+  #:use-module (guix cache)
+  #:use-module ((ice-9 ftw) #:select (scandir))
   #:export (guix-shell))
 
 (define (show-help)
@@ -161,16 +170,85 @@ Return the modified OPTS."
          (warning (G_ "no packages specified; creating an empty 
environment~%"))
          opts)
         (file
+         ;; Load environment from FILE; if possible, use/maintain a GC root to
+         ;; the corresponding profile in cache.
          (info (G_ "loading environment from '~a'...~%") file)
-         (match (basename file)
-           ("guix.scm"
-            (alist-cons 'load `(package ,file) opts))
-           ("manifest.scm"
-            (alist-cons 'manifest file opts)))))))
+         (let* ((root (profile-cached-gc-root file))
+                (stat (and root (false-if-exception (lstat root)))))
+           (if (and stat
+                    (<= (stat:mtime ((@ (guile) stat) file))
+                        (stat:mtime stat)))
+               (let ((now (current-time)))
+                 ;; Update the atime on ROOT to reflect usage.
+                 (utime root
+                        now (stat:mtime stat)
+                        0 (stat:mtimensec stat)
+                        AT_SYMLINK_NOFOLLOW)
+                 (alist-cons 'profile root opts)) ;load right away
+               (let ((opts (match (basename file)
+                             ("guix.scm"
+                              (alist-cons 'load `(package ,file) opts))
+                             ("manifest.scm"
+                              (alist-cons 'manifest file opts)))))
+                 (if (and root (not (assq-ref opts 'gc-root)))
+                     (begin
+                       (if stat
+                           (delete-file root)
+                           (mkdir-p (dirname root)))
+                       (alist-cons 'gc-root root opts))
+                     opts))))))))
+
+
+;;;
+;;; Profile cache.
+;;;
+
+(define %profile-cache-directory
+  ;; Directory where profiles created by 'guix shell' alone (without extra
+  ;; options) are cached.
+  (make-parameter (string-append (cache-directory #:ensure? #f)
+                                 "/profiles")))
+
+(define (profile-cache-key file)
+  "Return the cache key for the profile corresponding to FILE, a 'guix.scm' or
+'manifest.scm' file, or #f if we lack channel information."
+  (match (current-channels)
+    (() #f)
+    (((= channel-commit commits) ...)
+     (let ((stat (stat file)))
+       (bytevector->base32-string
+        (sha256 (string->utf8
+                 (string-append (string-join commits) ":"
+                                (basename file) ":"
+                                (number->string (stat:dev stat)) ":"
+                                (number->string (stat:ino stat))))))))))
+
+(define (profile-cached-gc-root file)
+  "Return the cached GC root for FILE, a 'guix.scm' or 'manifest.scm' file, or
+#f if we lack information to cache it."
+  (match (profile-cache-key file)
+    (#f  #f)
+    (key (string-append (%profile-cache-directory) "/" key))))
 
 
 (define-command (guix-shell . args)
   (category development)
   (synopsis "spawn one-off software environments")
 
-  (guix-environment* (parse-args args)))
+  (define (cache-entries directory)
+    (filter-map (match-lambda
+                  ((or "." "..") #f)
+                  (file (string-append directory "/" file)))
+                (or (scandir directory) '())))
+
+  (define* (entry-expiration file)
+    ;; Return the time at which FILE, a cached profile, is considered expired.
+    (match (false-if-exception (lstat file))
+      (#f 0)                       ;FILE may have been deleted in the meantime
+      (st (+ (stat:atime st) (* 60 60 24 7)))))
+
+  (let ((result (guix-environment* (parse-args args))))
+    (maybe-remove-expired-cache-entries (%profile-cache-directory)
+                                        cache-entries
+                                        #:entry-expiration entry-expiration)
+    result))
-- 
2.33.0