me
/
guix
Archived
1
0
Fork 0

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.
master
Timothy Sample 2021-03-19 23:03:25 -04:00
parent 4f59ef3edb
commit 66b14dccdd
No known key found for this signature in database
GPG Key ID: 2AC6A5EC1C357C59
3 changed files with 95 additions and 14 deletions

View File

@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> ;;; 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 © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;; Copyright © 2021 Timothy Sample <samplet@ngyro.com>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -34,6 +35,8 @@
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:autoload (ice-9 ftw) (scandir) #: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 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:export (open-socket-for-uri #:export (open-socket-for-uri
@ -626,10 +629,53 @@ Return a list of URIs."
(else (else
(list uri)))) (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 (define* (url-fetch url file
#:key #:key
(timeout 10) (verify-certificate? #t) (timeout 10) (verify-certificate? #t)
(mirrors '()) (content-addressed-mirrors '()) (mirrors '()) (content-addressed-mirrors '())
(disarchive-mirrors '())
(hashes '()) (hashes '())
print-build-trace?) print-build-trace?)
"Fetch FILE from URL; URL may be either a single string, or a list of "Fetch FILE from URL; URL may be either a single string, or a list of
@ -693,6 +739,18 @@ otherwise simply ignore them."
hashes)) hashes))
content-addressed-mirrors)) 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 ;; Make this unbuffered so 'progress-report/file' works as expected. 'line
;; means '\n', not '\r', so it's not appropriate here. ;; means '\n', not '\r', so it's not appropriate here.
(setvbuf (current-output-port) 'none) (setvbuf (current-output-port) 'none)
@ -705,15 +763,20 @@ otherwise simply ignore them."
(or (fetch uri file) (or (fetch uri file)
(try tail))) (try tail)))
(() (()
;; 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~%" (format (current-error-port) "failed to download ~s from ~s~%"
file url) file url)
;; Remove FILE in case we made an incomplete download, for
;; Remove FILE in case we made an incomplete download, for example due ;; example due to ENOSPC.
;; to ENOSPC.
(catch 'system-error (catch 'system-error
(lambda () (lambda ()
(delete-file file)) (delete-file file))
(const #f)) (const #f))
#f)))) #f))))))
;;; download.scm ends here ;;; download.scm ends here

View File

@ -406,12 +406,19 @@
(plain-file "content-addressed-mirrors" (plain-file "content-addressed-mirrors"
(object->string %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* (define built-in-builders*
(store-lift built-in-builders)) (store-lift built-in-builders))
(define* (built-in-download file-name url (define* (built-in-download file-name url
#:key system hash-algo hash #:key system hash-algo hash
mirrors content-addressed-mirrors mirrors content-addressed-mirrors
disarchive-mirrors
executable? executable?
(guile 'unused)) (guile 'unused))
"Download FILE-NAME from URL using the built-in 'download' builder. When "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." download by itself using its own dependencies."
(mlet %store-monad ((mirrors (lower-object mirrors)) (mlet %store-monad ((mirrors (lower-object mirrors))
(content-addressed-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" '() (raw-derivation file-name "builtin:download" '()
#:system system #:system system
#:hash-algo hash-algo #:hash-algo hash-algo
#:hash hash #:hash hash
#:recursive? executable? #:recursive? executable?
#:sources (list mirrors content-addressed-mirrors) #:sources (list mirrors
content-addressed-mirrors
disarchive-mirrors)
;; Honor the user's proxy and locale settings. ;; Honor the user's proxy and locale settings.
#:leaked-env-vars '("http_proxy" "https_proxy" #:leaked-env-vars '("http_proxy" "https_proxy"
@ -439,6 +449,7 @@ download by itself using its own dependencies."
("mirrors" . ,mirrors) ("mirrors" . ,mirrors)
("content-addressed-mirrors" ("content-addressed-mirrors"
. ,content-addressed-mirrors) . ,content-addressed-mirrors)
("disarchive-mirrors" . ,disarchive-mirrors)
,@(if executable? ,@(if executable?
'(("executable" . "1")) '(("executable" . "1"))
'())) '()))
@ -492,7 +503,9 @@ name in the store."
#:executable? executable? #:executable? executable?
#:mirrors %mirror-file #:mirrors %mirror-file
#:content-addressed-mirrors #:content-addressed-mirrors
%content-addressed-mirror-file))))) %content-addressed-mirror-file
#:disarchive-mirrors
%disarchive-mirror-file)))))
(define* (url-fetch/executable url hash-algo hash (define* (url-fetch/executable url hash-algo hash
#:optional name #:optional name

View File

@ -54,7 +54,8 @@ actual output is different from that when we're doing a 'bmCheck' or
(output* "out") (output* "out")
(executable "executable") (executable "executable")
(mirrors "mirrors") (mirrors "mirrors")
(content-addressed-mirrors "content-addressed-mirrors")) (content-addressed-mirrors "content-addressed-mirrors")
(disarchive-mirrors "disarchive-mirrors"))
(unless url (unless url
(leave (G_ "~a: missing URL~%") (derivation-file-name drv))) (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) (lambda (port)
(eval (read port) %user-module))) (eval (read port) %user-module)))
'()) '())
#:disarchive-mirrors
(if disarchive-mirrors
(call-with-input-file disarchive-mirrors read)
'())
#:hashes `((,algo . ,hash)) #:hashes `((,algo . ,hash))
;; Since DRV's output hash is known, X.509 certificate ;; Since DRV's output hash is known, X.509 certificate