diff mbox series

[bug#69328,09/12] bzr-download: Implement nar fallback.

Message ID 4e0514fe0f56873a54c4d79245813274a01cbb5b.1708697539.git.ludo@gnu.org
State New
Headers show
Series Better source code recovery from SWH | expand

Commit Message

Ludovic Courtès Feb. 23, 2024, 3:48 p.m. UTC 
* guix/bzr-download.scm (bzr-fetch)[guile-json, guile-lzlib,
guile-gnutls]: New variables.
[build]: Add ‘with-extensions’ and import more modules.  Invoke
‘download-nar’ when ‘bzr-fetch’ returns #f.
* guix/build/bzr.scm (bzr-fetch): Actually return #t on success.

Change-Id: Id5d4ebd0f9ddc3c44b6456d3b46c0000cc7b9997
---
 guix/build/bzr.scm    |  3 ++-
 guix/bzr-download.scm | 43 ++++++++++++++++++++++++++++++++-----------
 2 files changed, 34 insertions(+), 12 deletions(-)
diff mbox series

Patch

diff --git a/guix/build/bzr.scm b/guix/build/bzr.scm
index a0f5e15880..dede5e031a 100644
--- a/guix/build/bzr.scm
+++ b/guix/build/bzr.scm
@@ -37,6 +37,7 @@  (define* (bzr-fetch url revision directory
   (invoke bzr-command "-Ossl.cert_reqs=none" "checkout"
           "--lightweight" "-r" revision url directory)
   (with-directory-excursion directory
-    (delete-file-recursively ".bzr")))
+    (delete-file-recursively ".bzr"))
+  #t)
 
 ;;; bzr.scm ends here
diff --git a/guix/bzr-download.scm b/guix/bzr-download.scm
index d97f84838e..01c12fd54d 100644
--- a/guix/bzr-download.scm
+++ b/guix/bzr-download.scm
@@ -1,5 +1,6 @@ 
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2017, 2022 Maxim Cournoyer <maxim.cournoyer@gmail.com>
+;;; Copyright © 2024 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -51,20 +52,40 @@  (define (bzr-package)
     (module-ref distro 'breezy)))
 
 (define* (bzr-fetch ref hash-algo hash
-                       #:optional name
-                       #:key (system (%current-system)) (guile (default-guile))
-                       (bzr (bzr-package)))
+                    #:optional name
+                    #:key (system (%current-system)) (guile (default-guile))
+                    (bzr (bzr-package)))
   "Return a fixed-output derivation that fetches REF, a <bzr-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 guile-json
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-json-4))
+
+  (define guile-lzlib
+    (module-ref (resolve-interface '(gnu packages guile)) 'guile-lzlib))
+
+  (define guile-gnutls
+    (module-ref (resolve-interface '(gnu packages tls)) 'guile-gnutls))
+
   (define build
-    (with-imported-modules (source-module-closure
-                            '((guix build bzr)))
-      #~(begin
-          (use-modules (guix build bzr))
-          (bzr-fetch
-           (getenv "bzr url") (getenv "bzr reference") #$output
-           #:bzr-command (string-append #+bzr "/bin/brz")))))
+    (with-extensions (list guile-gnutls guile-lzlib guile-json)
+      (with-imported-modules (source-module-closure
+                              '((guix build bzr)
+                                (guix build utils)
+                                (guix build download-nar)))
+        #~(begin
+            (use-modules (guix build bzr)
+                         (guix build download-nar)
+                         (guix build utils)
+                         (srfi srfi-34))
+
+            (or (guard (c ((invoke-error? c)
+                           (report-invoke-error c)
+                           #f))
+                  (bzr-fetch (getenv "bzr url") (getenv "bzr reference")
+                             #$output
+                             #:bzr-command (string-append #+bzr "/bin/brz")))
+                (download-nar #$output))))))
 
   (mlet %store-monad ((guile (package->derivation guile system)))
     (gexp->derivation (or name "bzr-branch") build
@@ -79,7 +100,7 @@  (define* (bzr-fetch ref hash-algo hash
                                           "LC_ALL" "LC_MESSAGES" "LANG"
                                           "COLUMNS")
                       #:system system
-                      #:local-build? #t  ;don't offload repo branching
+                      #:local-build? #t          ;don't offload repo branching
                       #:hash-algo hash-algo
                       #:hash hash
                       #:recursive? #t