[bug#48971] [PATCH 2/2] hg-download: Support falling back to SWH.

[Xinglu Chen]

* guix/hg-download.scm (hg-fetch): Fall back to fetching the source from SWH
if the upstream source is missing.
---
 guix/hg-download.scm | 31 ++++++++++++++++++++++++++++---
 1 file changed, 28 insertions(+), 3 deletions(-)

diff --git a/guix/hg-download.scm b/guix/hg-download.scm
index eb7c345489..c386d2f5f3 100644
--- a/guix/hg-download.scm
+++ b/guix/hg-download.scm
@@ -67,6 +67,13 @@
   "Return a fixed-output derivation that fetches REF, a <hg-reference>
 object.  The output is expected to have recursive hash HASH of type
 HASH-ALGO (a symbol).  Use NAME as the file name, or a generic name if #f."
+  (define inputs
+    ;; The 'swh-download' procedure requires tar and gzip.
+    `(("gzip" ,(module-ref (resolve-interface '(gnu packages compression))
+                           'gzip))
+      ("tar" ,(module-ref (resolve-interface '(gnu packages base))
+                          'tar))))
+
   (define guile-zlib
     (module-ref (resolve-interface '(gnu packages guile)) 'guile-zlib))
 
@@ -79,7 +86,8 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
   (define modules
     (delete '(guix config)
             (source-module-closure '((guix build hg)
-                                     (guix build download-nar)))))
+                                     (guix build download-nar)
+                                     (guix swh)))))
 
   (define build
     (with-imported-modules modules
@@ -87,13 +95,30 @@ HASH-ALGO (a symbol).  Use NAME as the file name, or a 
generic name if #f."
                              guile-zlib)
         #~(begin
             (use-modules (guix build hg)
-                         (guix build download-nar))
+                         (guix build utils) ;for 
`set-path-environment-variable'
+                         (guix build download-nar)
+                         (guix swh)
+                         (ice-9 match))
+
+            (set-path-environment-variable "PATH" '("bin")
+                                           (match '#+inputs
+                                             (((names dirs outputs ...) ...)
+                                              dirs)))
 
             (or (hg-fetch '#$(hg-reference-url ref)
                           '#$(hg-reference-changeset ref)
                           #$output
                           #:hg-command (string-append #+hg "/bin/hg"))
-                (download-nar #$output))))))
+                (download-nar #$output)
+                ;; As a last resort, attempt to download from Software 
Heritage.
+                ;; Disable X.509 certificate verification to avoid depending
+                ;; on nss-certs--we're authenticating the checkout anyway.
+                (parameterize ((%verify-swh-certificate? #f))
+                  (format (current-error-port)
+                          "Trying to download from Software Heritage...~%")
+                  (swh-download #$(hg-reference-url ref)
+                                #$(hg-reference-changeset ref)
+                                #$output)))))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "hg-checkout") build
-- 
2.32.0