Package: guix-patches;
Reported by: Timothy Sample <samplet <at> ngyro.com>
Date: Tue, 23 Mar 2021 04:43:01 UTC
Severity: normal
Done: Timothy Sample <samplet <at> ngyro.com>
Bug is archived. No further changes may be made.
Message #11 received at 47336 <at> debbugs.gnu.org (full text, mbox):
From: Timothy Sample <samplet <at> ngyro.com> To: 47336 <at> debbugs.gnu.org Cc: Timothy Sample <samplet <at> ngyro.com> Subject: [PATCH 2/2] download: Use Disarchive as a last resort. Date: Tue, 23 Mar 2021 00:52:13 -0400
* guix/download.scm (%disarchive-mirrors): New variable.
(%disarchive-mirror-file): New variable.
(built-in-download): Add 'disarchive-mirrors' keyword argument and
pass its value along to the 'builtin:download' derivation.
(url-fetch): Pass '%disarchive-mirror-file' to 'built-in-download'.
* guix/scripts/perform-download.scm (perform-download): Read
Disarchive mirrors from the environment and pass them to
'url-fetch'.
* guix/build/download.scm (disarchive-fetch/any): New procedure.
(url-fetch): Add 'disarchive-mirrors' keyword argument, use it to
make a list of URIs, and use the new procedure to fetch the file if
all other methods fail.
---
guix/build/download.scm | 77 +++++++++++++++++++++++++++----
guix/download.scm | 19 ++++++--
guix/scripts/perform-download.scm | 7 ++-
3 files changed, 89 insertions(+), 14 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index a22d4064ca..f476d0f8ec 100644
--- a/guix/build/download.scm
+++ b/guix/build/download.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo <at> gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw <at> netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me <at> tobias.gr>
+;;; Copyright © 2021 Timothy Sample <samplet <at> ngyro.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -23,10 +24,12 @@
#:use-module (web http)
#:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response)
+ #:use-module (guix base16)
#:use-module (guix base64)
#:use-module (guix ftp-client)
#:use-module (guix build utils)
#:use-module (guix progress)
+ #:use-module (guix swh)
#:use-module (rnrs io ports)
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
@@ -626,10 +629,50 @@ Return a list of URIs."
(else
(list uri))))
+(define* (disarchive-fetch/any uris file
+ #:key (timeout 10))
+ "Fetch a Disarchive specification from any of URIS, assemble it,
+and write the output to FILE."
+ (define (fetch-specification uris)
+ (any (lambda (uri)
+ (false-if-exception*
+ (let-values (((port size) (http-fetch uri
+ #:verify-certificate? #t
+ #:timeout timeout)))
+ (let ((specification (read port)))
+ (close-port port)
+ specification))))
+ uris))
+
+ (define (resolve addresses output)
+ (any (match-lambda
+ (('swhid swhid)
+ (match (string-split swhid #\:)
+ (("swh" "1" "dir" id)
+ (format #t "Downloading from Software Heritage...~%" file)
+ (false-if-exception*
+ (swh-download-directory id output)))
+ (_ #f)))
+ (_ #f))
+ addresses))
+
+ (match (and=> (resolve-module '(disarchive) #:ensure #f)
+ (lambda (disarchive)
+ (cons (module-ref disarchive '%disarchive-log-port)
+ (module-ref disarchive 'disarchive-assemble))))
+ (#f #f)
+ ((%disarchive-log-port . disarchive-assemble)
+ (format #t "Trying to use Disarchive to assemble ~a~%" file)
+ (match (fetch-specification uris)
+ (#f #f)
+ (spec (parameterize ((%disarchive-log-port (current-output-port)))
+ (disarchive-assemble spec file #:resolver resolve)))))))
+
(define* (url-fetch url file
#:key
(timeout 10) (verify-certificate? #t)
(mirrors '()) (content-addressed-mirrors '())
+ (disarchive-mirrors '())
(hashes '())
print-build-trace?)
"Fetch FILE from URL; URL may be either a single string, or a list of
@@ -693,6 +736,17 @@ otherwise simply ignore them."
hashes))
content-addressed-mirrors))
+ (define disarchive-uris
+ (append-map (lambda (mirror)
+ (map (match-lambda
+ ((hash-algo . hash)
+ (string->uri
+ (string-append mirror
+ (symbol->string hash-algo) "/"
+ (bytevector->base16-string hash)))))
+ hashes))
+ disarchive-mirrors))
+
;; Make this unbuffered so 'progress-report/file' works as expected. 'line
;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) 'none)
@@ -705,15 +759,18 @@ otherwise simply ignore them."
(or (fetch uri file)
(try tail)))
(()
- (format (current-error-port) "failed to download ~s from ~s~%"
- file url)
-
- ;; Remove FILE in case we made an incomplete download, for example due
- ;; to ENOSPC.
- (catch 'system-error
- (lambda ()
- (delete-file file))
- (const #f))
- #f))))
+ ;; If we are looking for a software archive, one last thing we
+ ;; can try is to use Disarchive to assemble it.
+ (or (disarchive-fetch/any disarchive-uris file #:timeout timeout)
+ (begin
+ (format (current-error-port) "failed to download ~s from ~s~%"
+ file url)
+ ;; Remove FILE in case we made an incomplete download, for
+ ;; example due to ENOSPC.
+ (catch 'system-error
+ (lambda ()
+ (delete-file file))
+ (const #f))
+ #f))))))
;;; download.scm ends here
diff --git a/guix/download.scm b/guix/download.scm
index 30f69c0325..72094e7318 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -406,12 +406,19 @@
(plain-file "content-addressed-mirrors"
(object->string %content-addressed-mirrors)))
+(define %disarchive-mirrors
+ '("https://disarchive.ngyro.com/"))
+
+(define %disarchive-mirror-file
+ (plain-file "disarchive-mirrors" (object->string %disarchive-mirrors)))
+
(define built-in-builders*
(store-lift built-in-builders))
(define* (built-in-download file-name url
#:key system hash-algo hash
mirrors content-addressed-mirrors
+ disarchive-mirrors
executable?
(guile 'unused))
"Download FILE-NAME from URL using the built-in 'download' builder. When
@@ -422,13 +429,16 @@ explicitly depend on Guile, GnuTLS, etc. Instead, the daemon performs the
download by itself using its own dependencies."
(mlet %store-monad ((mirrors (lower-object mirrors))
(content-addressed-mirrors
- (lower-object content-addressed-mirrors)))
+ (lower-object content-addressed-mirrors))
+ (disarchive-mirrors (lower-object disarchive-mirrors)))
(raw-derivation file-name "builtin:download" '()
#:system system
#:hash-algo hash-algo
#:hash hash
#:recursive? executable?
- #:sources (list mirrors content-addressed-mirrors)
+ #:sources (list mirrors
+ content-addressed-mirrors
+ disarchive-mirrors)
;; Honor the user's proxy and locale settings.
#:leaked-env-vars '("http_proxy" "https_proxy"
@@ -439,6 +449,7 @@ download by itself using its own dependencies."
("mirrors" . ,mirrors)
("content-addressed-mirrors"
. ,content-addressed-mirrors)
+ ("disarchive-mirrors" . ,disarchive-mirrors)
,@(if executable?
'(("executable" . "1"))
'()))
@@ -492,7 +503,9 @@ name in the store."
#:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
- %content-addressed-mirror-file)))))
+ %content-addressed-mirror-file
+ #:disarchive-mirrors
+ %disarchive-mirror-file)))))
(define* (url-fetch/executable url hash-algo hash
#:optional name
diff --git a/guix/scripts/perform-download.scm b/guix/scripts/perform-download.scm
index 8d409092ba..6889bcef79 100644
--- a/guix/scripts/perform-download.scm
+++ b/guix/scripts/perform-download.scm
@@ -54,7 +54,8 @@ actual output is different from that when we're doing a 'bmCheck' or
(output* "out")
(executable "executable")
(mirrors "mirrors")
- (content-addressed-mirrors "content-addressed-mirrors"))
+ (content-addressed-mirrors "content-addressed-mirrors")
+ (disarchive-mirrors "disarchive-mirrors"))
(unless url
(leave (G_ "~a: missing URL~%") (derivation-file-name drv)))
@@ -79,6 +80,10 @@ actual output is different from that when we're doing a 'bmCheck' or
(lambda (port)
(eval (read port) %user-module)))
'())
+ #:disarchive-mirrors
+ (if disarchive-mirrors
+ (call-with-input-file disarchive-mirrors read)
+ '())
#:hashes `((,algo . ,hash))
;; Since DRV's output hash is known, X.509 certificate
--
2.31.0
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.