mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-25 13:58:15 -05:00
Revert "download: Use Disarchive as a last resort."
This reverts commit 66b14dccdd
, which broke
'guix pull'.
This commit is contained in:
parent
1f6854bd06
commit
e74250c3c5
3 changed files with 14 additions and 95 deletions
|
@ -2,7 +2,6 @@
|
||||||
;;; 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.
|
||||||
;;;
|
;;;
|
||||||
|
@ -35,8 +34,6 @@ (define-module (guix build download)
|
||||||
#: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
|
||||||
|
@ -629,53 +626,10 @@ (define (maybe-expand-mirrors uri mirrors)
|
||||||
(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
|
||||||
|
@ -739,18 +693,6 @@ (define content-addressed-uris
|
||||||
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)
|
||||||
|
@ -763,20 +705,15 @@ (define disarchive-uris
|
||||||
(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
|
|
||||||
;; example due to ENOSPC.
|
;; Remove FILE in case we made an incomplete download, for example due
|
||||||
|
;; 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
|
||||||
|
|
|
@ -406,19 +406,12 @@ (define %content-addressed-mirror-file
|
||||||
(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
|
||||||
|
@ -429,16 +422,13 @@ (define* (built-in-download file-name url
|
||||||
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
|
#:sources (list mirrors content-addressed-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"
|
||||||
|
@ -449,7 +439,6 @@ (define* (built-in-download file-name url
|
||||||
("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"))
|
||||||
'()))
|
'()))
|
||||||
|
@ -503,9 +492,7 @@ (define file-name
|
||||||
#: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
|
||||||
|
|
|
@ -54,8 +54,7 @@ (define* (perform-download drv #:optional output
|
||||||
(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)))
|
||||||
|
|
||||||
|
@ -80,10 +79,6 @@ (define* (perform-download drv #:optional output
|
||||||
(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
|
||||||
|
|
Loading…
Reference in a new issue