;;; 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.
;;;
#: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
(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
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)
(or (fetch uri file)
(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~%"
- 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))))))
+ (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
(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
download by itself using its own dependencies."
(mlet %store-monad ((mirrors (lower-object mirrors))
(content-addressed-mirrors
- (lower-object content-addressed-mirrors))
- (disarchive-mirrors (lower-object disarchive-mirrors)))
+ (lower-object content-addressed-mirrors)))
(raw-derivation file-name "builtin:download" '()
#:system system
#:hash-algo hash-algo
#:hash hash
#:recursive? executable?
- #:sources (list mirrors
- content-addressed-mirrors
- disarchive-mirrors)
+ #:sources (list mirrors content-addressed-mirrors)
;; Honor the user's proxy and locale settings.
#:leaked-env-vars '("http_proxy" "https_proxy"
("mirrors" . ,mirrors)
("content-addressed-mirrors"
. ,content-addressed-mirrors)
- ("disarchive-mirrors" . ,disarchive-mirrors)
,@(if executable?
'(("executable" . "1"))
'()))
#:executable? executable?
#:mirrors %mirror-file
#:content-addressed-mirrors
- %content-addressed-mirror-file
- #:disarchive-mirrors
- %disarchive-mirror-file)))))
+ %content-addressed-mirror-file)))))
(define* (url-fetch/executable url hash-algo hash
#:optional name