[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
02/02: download: Use Disarchive as a last resort.
|
From: |
guix-commits |
|
Subject: |
02/02: download: Use Disarchive as a last resort. |
|
Date: |
Tue, 27 Apr 2021 22:13:31 -0400 (EDT) |
samplet pushed a commit to branch master
in repository guix.
commit 66b14dccdd0d83c875ce3a8d50ceab8b6f0a3ce2
Author: Timothy Sample <samplet@ngyro.com>
AuthorDate: Fri Mar 19 23:03:25 2021 -0400
download: Use Disarchive as a last resort.
* 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 | 83 ++++++++++++++++++++++++++++++++++-----
guix/download.scm | 19 +++++++--
guix/scripts/perform-download.scm | 7 +++-
3 files changed, 95 insertions(+), 14 deletions(-)
diff --git a/guix/build/download.scm b/guix/build/download.scm
index a22d406..5431d7c 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@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
+;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -34,6 +35,8 @@
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:autoload (ice-9 ftw) (scandir)
+ #:autoload (guix base16) (bytevector->base16-string)
+ #:autoload (guix swh) (swh-download-directory)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (open-socket-for-uri
@@ -626,10 +629,53 @@ Return a list of URIs."
(else
(list uri))))
+(define* (disarchive-fetch/any uris file
+ #:key (timeout 10) (verify-certificate? #t))
+ "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?
+ verify-certificate?
+ #: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))
+
+ (format #t "Trying to use Disarchive to assemble ~a...~%" file)
+ (match (and=> (resolve-module '(disarchive) #:ensure #f)
+ (lambda (disarchive)
+ (cons (module-ref disarchive '%disarchive-log-port)
+ (module-ref disarchive 'disarchive-assemble))))
+ (#f
+ (format #t "could not load Disarchive~%"))
+ ((%disarchive-log-port . disarchive-assemble)
+ (match (fetch-specification uris)
+ (#f
+ (format #t "could not find its Disarchive specification~%"))
+ (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 +739,18 @@ otherwise simply ignore them."
hashes))
content-addressed-mirrors))
+ (define disarchive-uris
+ (append-map (match-lambda
+ ((? string? 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 +763,20 @@ 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
+ #:verify-certificate? verify-certificate?
+ #: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 30f69c0..72094e7 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 8d40909..6889bce 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