bug#44187: whishlist: time-machine --channel falls back to SWH

["Ludovic Courtès" <ludo@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 1635 bytes --]

Hi,

zimoun <zimon.toutoune@gmail.com> skribis:

> Let’s describe the use case.  Consider that:
>
>   guix time-machine -C channels -- install foo
>
> is provided in some documentation, say scientific paper.  Where the
> channels.scm file is completly described:
>
> (list (channel
>         (name 'kikoo)
>         (url "https://example.org/that-great.git")
>         (commit
>           "353bdae32f72b720c7ddd706576ccc40e2b43f95")))
>
> In the future, if https://example.org/that-great.git disappears, then
> build/install the package ’foo’ is becoming difficult, nor impossible.
>
> However, let’s consider that the repo ’that-great’ had been saved in SWH
> (say manually); since it is a regular Git repo.  Guix should be able to
> fallback to it transparently.

I went head-down to add SWH fallback to ‘latest-repository-commit’… but
that’s of no use because (guix channels) wants a complete clone so that
it can determine commit relations (to detect downgrades).

The SWH vault gives access to checkouts primarily, but it’s also
possible to get a full repo in ‘git fast-import’ format, which is what
we need:

  https://archive.softwareheritage.org/api/1/vault/revision/gitfast/doc/

However, this API will be eventually replaced by some other solution say
SWH developers, possibly a bare Git repo export, so it may not be a good
idea to build upon it.

If we were able, using the SWH API, to map “revisions” to “origins”, we
could find potential mirrors hosting a given commit, but apparently
that’s not possible.

To be continued…

Ludo’.



[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Type: text/x-patch, Size: 2914 bytes --]

diff --git a/guix/git.scm b/guix/git.scm
index a5103547d3..449011c51a 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -32,6 +32,7 @@
   #:use-module (guix records)
   #:use-module (guix gexp)
   #:use-module (guix sets)
+  #:autoload   (guix swh) (swh-download)
   #:use-module ((guix diagnostics) #:select (leave))
   #:use-module (guix progress)
   #:use-module (rnrs bytevectors)
@@ -459,22 +460,43 @@ Log progress and checkout info to LOG-PORT."
                   (eq? 'regular (stat:type stat))))))
 
   (format log-port "updating checkout of '~a'...~%" url)
-  (let*-values
-      (((checkout commit _)
-        (update-cached-checkout url
-                                #:recursive? recursive?
-                                #:ref ref
-                                #:cache-directory
-                                (url-cache-directory url cache-directory
-                                                     #:recursive?
-                                                     recursive?)
-                                #:log-port log-port))
-       ((name)
-        (url+commit->name url commit)))
-    (format log-port "retrieved commit ~a~%" commit)
-    (values (add-to-store store name #t "sha256" checkout
-                          #:select? (negate dot-git?))
-            commit)))
+
+  (catch 'git-error
+    (lambda ()
+      (let*-values
+          (((checkout commit _)
+            (update-cached-checkout (pk 'l-r-c url)
+                                    #:recursive? recursive?
+                                    #:ref ref
+                                    #:cache-directory
+                                    (url-cache-directory url cache-directory
+                                                         #:recursive?
+                                                         recursive?)
+                                    #:log-port log-port))
+           ((name)
+            (url+commit->name url commit)))
+        (format log-port "retrieved commit ~a~%" commit)
+        (values (add-to-store store name #t "sha256" checkout
+                              #:select? (negate dot-git?))
+                commit)))
+    (lambda (key err . rest)
+      ;; XXX: 'swh-download' currently doesn't support submodules.
+      (when recursive?
+        (apply throw key err rest))
+
+      (pk 'err key err rest)
+      (match ref
+        (('commit . commit)
+         ;; Attempt to fetch COMMIT from SWH.
+         (call-with-temporary-directory
+          (lambda (directory)
+            (unless (swh-download url commit directory)
+              (apply throw key err rest))
+            (values (add-to-store store (url+commit->name url commit)
+                                  #t "sha256" directory)
+                    commit))))
+        (_
+         (apply throw key err rest))))))
 
 (define (print-git-error port key args default-printer)
   (match args