;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
-;;; Copyright © 2015 Steve Sprang <scs@stevesprang.com>
+;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr>
;;;
;;; This file is part of GNU Guix.
;;;
#:use-module (guix base64)
#:use-module (guix ftp-client)
#:use-module (guix build utils)
+ #:use-module (guix progress)
#:use-module (rnrs io ports)
+ #:use-module ((ice-9 binary-ports) #:select (unget-bytevector))
#:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (ice-9 format)
#:export (open-socket-for-uri
open-connection-for-uri
+ http-fetch
%x509-certificate-directory
close-connection
resolve-uri-reference
maybe-expand-mirrors
url-fetch
byte-count->string
- current-terminal-columns
- progress-proc
uri-abbreviation
nar-uri-abbreviation
store-path-abbreviation))
;; Size of the HTTP receive buffer.
65536)
-(define current-terminal-columns
- ;; Number of columns of the terminal.
- (make-parameter 80))
-
-(define (nearest-exact-integer x)
- "Given a real number X, return the nearest exact integer, with ties going to
-the nearest exact even integer."
- (inexact->exact (round x)))
-
-(define (duration->seconds duration)
- "Return the number of seconds represented by DURATION, a 'time-duration'
-object, as an inexact number."
- (+ (time-second duration)
- (/ (time-nanosecond duration) 1e9)))
-
-(define (seconds->string duration)
- "Given DURATION in seconds, return a string representing it in 'mm:ss' or
-'hh:mm:ss' format, as needed."
- (if (not (number? duration))
- "00:00"
- (let* ((total-seconds (nearest-exact-integer duration))
- (extra-seconds (modulo total-seconds 3600))
- (num-hours (quotient total-seconds 3600))
- (hours (and (positive? num-hours) num-hours))
- (mins (quotient extra-seconds 60))
- (secs (modulo extra-seconds 60)))
- (format #f "~@[~2,'0d:~]~2,'0d:~2,'0d" hours mins secs))))
-
-(define (byte-count->string size)
- "Given SIZE in bytes, return a string representing it in a human-readable
-way."
- (let ((KiB 1024.)
- (MiB (expt 1024. 2))
- (GiB (expt 1024. 3))
- (TiB (expt 1024. 4)))
- (cond
- ((< size KiB) (format #f "~dB" (nearest-exact-integer size)))
- ((< size MiB) (format #f "~dKiB" (nearest-exact-integer (/ size KiB))))
- ((< size GiB) (format #f "~,1fMiB" (/ size MiB)))
- ((< size TiB) (format #f "~,2fGiB" (/ size GiB)))
- (else (format #f "~,3fTiB" (/ size TiB))))))
-
-(define* (progress-bar % #:optional (bar-width 20))
- "Return % as a string representing an ASCII-art progress bar. The total
-width of the bar is BAR-WIDTH."
- (let* ((fraction (/ % 100))
- (filled (inexact->exact (floor (* fraction bar-width))))
- (empty (- bar-width filled)))
- (format #f "[~a~a]"
- (make-string filled #\#)
- (make-string empty #\space))))
-
-(define (string-pad-middle left right len)
- "Combine LEFT and RIGHT with enough padding in the middle so that the
-resulting string has length at least LEN (it may overflow). If the string
-does not overflow, the last char in RIGHT will be flush with the LEN
-column."
- (let* ((total-used (+ (string-length left)
- (string-length right)))
- (num-spaces (max 1 (- len total-used)))
- (padding (make-string num-spaces #\space)))
- (string-append left padding right)))
-
(define* (ellipsis #:optional (port (current-output-port)))
"Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written
in PORT's encoding, and return either that or ASCII dots."
(string-drop base 32)))
store-path))
-(define* (progress-proc file size
- #:optional (log-port (current-output-port))
- #:key (abbreviation basename))
- "Return a procedure to show the progress of FILE's download, which is SIZE
-bytes long. The returned procedure is suitable for use as an argument to
-`dump-port'. The progress report is written to LOG-PORT, with ABBREVIATION
-used to shorten FILE for display."
- ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not
- ;; called as frequently as we'd like too; this is especially bad with Nginx
- ;; on hydra.gnu.org, which returns whole nars as a single chunk.
- (let ((start-time #f))
- (let-syntax ((with-elapsed-time
- (syntax-rules ()
- ((_ elapsed body ...)
- (let* ((now (current-time time-monotonic))
- (elapsed (and start-time
- (duration->seconds
- (time-difference now
- start-time)))))
- (unless start-time
- (set! start-time now))
- body ...)))))
- (if (number? size)
- (lambda (transferred cont)
- (with-elapsed-time elapsed
- (let* ((% (* 100.0 (/ transferred size)))
- (throughput (if elapsed
- (/ transferred elapsed)
- 0))
- (left (format #f " ~a ~a"
- (abbreviation file)
- (byte-count->string size)))
- (right (format #f "~a/s ~a ~a~6,1f%"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (progress-bar %) %)))
- (display "\r\x1b[K" log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (flush-output-port log-port)
- (cont))))
- (lambda (transferred cont)
- (with-elapsed-time elapsed
- (let* ((throughput (if elapsed
- (/ transferred elapsed)
- 0))
- (left (format #f " ~a"
- (abbreviation file)))
- (right (format #f "~a/s ~a | ~a transferred"
- (byte-count->string throughput)
- (seconds->string elapsed)
- (byte-count->string transferred))))
- (display "\r\x1b[K" log-port)
- (display (string-pad-middle left right
- (current-terminal-columns))
- log-port)
- (flush-output-port log-port)
- (cont))))))))
-
(define* (uri-abbreviation uri #:optional (max-length 42))
"If URI's string representation is larger than MAX-LENGTH, return an
abbreviation of URI showing the scheme, host, and basename of the file."
(string-drop path 33)
path)))
-(define* (ftp-fetch uri file #:key timeout)
+(define* (ftp-fetch uri file #:key timeout print-build-trace?)
"Fetch data from URI and write it to FILE. Return FILE on success. Bail
out if the connection could not be established in less than TIMEOUT seconds."
- (let* ((conn (ftp-open (uri-host uri) #:timeout timeout))
+ (let* ((conn (match (and=> (uri-userinfo uri)
+ (cut string-split <> #\:))
+ (((? string? user))
+ (ftp-open (uri-host uri) #:timeout timeout
+ #:username user))
+ (((? string? user) (? string? pass))
+ (ftp-open (uri-host uri) #:timeout timeout
+ #:username user
+ #:password pass))
+ (_ (ftp-open (uri-host uri) #:timeout timeout))))
(size (false-if-exception (ftp-size conn (uri-path uri))))
(in (ftp-retr conn (basename (uri-path uri))
- (dirname (uri-path uri)))))
+ (dirname (uri-path uri))
+ #:timeout timeout)))
(call-with-output-file file
(lambda (out)
- (dump-port in out
- #:buffer-size %http-receive-buffer-size
- #:progress (progress-proc (uri-abbreviation uri) size))))
-
- (ftp-close conn))
- (newline)
- file)
+ (dump-port* in out
+ #:buffer-size %http-receive-buffer-size
+ #:reporter
+ (if print-build-trace?
+ (progress-reporter/trace
+ file (uri->string uri) size)
+ (progress-reporter/file
+ (uri-abbreviation uri) size)))))
+
+ (ftp-close conn)
+ (unless print-build-trace?
+ (newline))
+ file))
;; Autoload GnuTLS so that this module can be used even when GnuTLS is
;; not available. At compile time, this yields "possibly unbound
;; be bound if we need them, because (guix download) adds GnuTLS as an
;; input in that case.
-;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
-;; See <http://bugs.gnu.org/12202>.
-(module-autoload! (current-module)
- '(gnutls) '(make-session connection-end/client))
-
-(define %tls-ports
- ;; Mapping of session record ports to the underlying file port.
- (make-weak-key-hash-table))
-
-(define (register-tls-record-port record-port port)
- "Hold a weak reference from RECORD-PORT to PORT, where RECORD-PORT is a TLS
-session record port using PORT as its underlying communication port."
- (hashq-set! %tls-ports record-port port))
+(define (load-gnutls)
+ ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
+ ;; See <http://bugs.gnu.org/12202>.
+ (module-use! (resolve-module '(guix build download))
+ (resolve-interface '(gnutls)))
+ (set! load-gnutls (const #t)))
(define %x509-certificate-directory
;; The directory where X.509 authority PEM certificates are stored.
(make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY")
- (getenv "SSL_CERT_DIR")))) ;like OpenSSL
+ (getenv "SSL_CERT_DIR") ;like OpenSSL
+ "/etc/ssl/certs")))
+
+(define (set-certificate-credentials-x509-trust-file!* cred file format)
+ "Like 'set-certificate-credentials-x509-trust-file!', but without the file
+name decoding bug described at
+<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>."
+ (let ((data (call-with-input-file file get-bytevector-all)))
+ (set-certificate-credentials-x509-trust-data! cred data format)))
(define (make-credendials-with-ca-trust-files directory)
"Return certificate credentials with X.509 authority certificates read from
DIRECTORY. Those authority certificates are checked when
'peer-certificate-status' is later called."
(let ((cred (make-certificate-credentials))
- (files (or (scandir directory
- (lambda (file)
- (string-suffix? ".pem" file)))
- '())))
+ (files (match (scandir directory (cut string-suffix? ".pem" <>))
+ ((or #f ())
+ ;; Some distros provide nothing but bundles (*.crt) under
+ ;; /etc/ssl/certs, so look for them.
+ (or (scandir directory (cut string-suffix? ".crt" <>))
+ '()))
+ (pem pem))))
(for-each (lambda (file)
(let ((file (string-append directory "/" file)))
;; Protect against dangling symlinks.
(when (file-exists? file)
- (set-certificate-credentials-x509-trust-file!
+ (set-certificate-credentials-x509-trust-file!*
cred file
x509-certificate-format/pem))))
- (or files '()))
+ files)
cred))
(define (peer-certificate session)
(format (current-error-port)
"gnutls: [~a|~a] ~a" (getpid) level str))
+ (load-gnutls)
(let ((session (make-session connection-end/client))
(ca-certs (%x509-certificate-directory)))
;;(set-log-level! 10)
;;(set-log-procedure! log)
- (handshake session)
+ (catch 'gnutls-error
+ (lambda ()
+ (handshake session))
+ (lambda (key err proc . rest)
+ (cond ((eq? err error/warning-alert-received)
+ ;; Like Wget, do no stop upon non-fatal alerts such as
+ ;; 'alert-description/unrecognized-name'.
+ (format (current-error-port)
+ "warning: TLS warning alert received: ~a~%"
+ (alert-description->string (alert-get session)))
+ (handshake session))
+ (else
+ ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't
+ ;; provide a binding for this.
+ (apply throw key err proc rest)))))
;; Verify the server's certificate if needed.
(when verify-certificate?
(apply throw args))))
(let ((record (session-record-port session)))
- ;; Since we use `fileno' above, the file descriptor behind PORT would be
- ;; closed when PORT is GC'd. If we used `port->fdes', it would instead
- ;; never be closed. So we use `fileno', but keep a weak reference to
- ;; PORT, so the file descriptor gets closed when RECORD is GC'd.
- (register-tls-record-port record port)
- record)))
+ (define (read! bv start count)
+ (define read-bv (get-bytevector-some record))
+ (if (eof-object? read-bv)
+ 0 ; read! returns 0 on eof-object
+ (let ((read-bv-len (bytevector-length read-bv)))
+ (bytevector-copy! read-bv 0 bv start (min read-bv-len count))
+ (when (< count read-bv-len)
+ (unget-bytevector record bv count (- read-bv-len count)))
+ read-bv-len)))
+ (define (write! bv start count)
+ (put-bytevector record bv start count)
+ (force-output record)
+ count)
+ (define (get-position)
+ (port-position record))
+ (define (set-position! new-position)
+ (set-port-position! record new-position))
+ (define (close)
+ (unless (port-closed? port)
+ (close-port port))
+ (unless (port-closed? record)
+ (close-port record)))
+
+ (setvbuf record 'block)
+
+ ;; Return a port that wraps RECORD to ensure that closing it also
+ ;; closes PORT, the actual socket port, and its file descriptor.
+ ;; XXX: This wrapper would be unnecessary if GnuTLS could
+ ;; automatically close SESSION's file descriptor when RECORD is
+ ;; closed, but that doesn't seem to be possible currently (as of
+ ;; 3.6.9).
+ (make-custom-binary-input/output-port "gnutls wrapped port" read! write!
+ get-position set-position!
+ close))))
(define (ensure-uri uri-or-string) ;XXX: copied from (web http)
(cond
((uri? uri-or-string) uri-or-string)
(else (error "Invalid URI" uri-or-string))))
-(define current-http-proxy
- ;; XXX: Add a dummy definition for Guile < 2.0.10; this is used in
- ;; 'open-socket-for-uri'.
- (or (and=> (module-variable (resolve-interface '(web client))
- 'current-http-proxy)
- variable-ref)
- (const #f)))
-
(define* (open-socket-for-uri uri-or-string #:key timeout)
"Return an open input/output port for a connection to URI. When TIMEOUT is
not #f, it must be a (possibly inexact) number denoting the maximum duration
(connect* s (addrinfo:addr ai) timeout)
;; Buffer input and output on this port.
- (setvbuf s _IOFBF)
+ (setvbuf s 'block)
;; If we're using a proxy, make a note of that.
(when http-proxy (set-http-proxy-port?! s #t))
s)
(apply throw args)
(loop (cdr addresses))))))))
+(define (setup-http-tunnel port uri)
+ "Establish over PORT an HTTP tunnel to the destination server of URI."
+ (define target
+ (string-append (uri-host uri) ":"
+ (number->string
+ (or (uri-port uri)
+ (match (uri-scheme uri)
+ ('http 80)
+ ('https 443))))))
+ (format port "CONNECT ~a HTTP/1.1\r\n" target)
+ (format port "Host: ~a\r\n\r\n" target)
+ (force-output port)
+ (read-response port))
+
(define* (open-connection-for-uri uri
#:key
timeout
"Like 'open-socket-for-uri', but also handle HTTPS connections. The
resulting port must be closed with 'close-connection'. When
VERIFY-CERTIFICATE? is true, verify HTTPS server certificates."
+ ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually
+ ;; undefined. See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047.
+
(define https?
(eq? 'https (uri-scheme uri)))
+ (define https-proxy (let ((proxy (getenv "https_proxy")))
+ (and (not (equal? proxy ""))
+ proxy)))
+
(let-syntax ((with-https-proxy
(syntax-rules ()
((_ exp)
;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
- ;; FIXME: Proxying is not supported for https.
(let ((thunk (lambda () exp)))
(if (and https?
(module-variable
(resolve-interface '(web client))
'current-http-proxy))
- (parameterize ((current-http-proxy #f))
- (when (and=> (getenv "https_proxy")
- (negate string-null?))
- (format (current-error-port)
- "warning: 'https_proxy' is ignored~%"))
+ (parameterize ((current-http-proxy https-proxy))
(thunk))
(thunk)))))))
(with-https-proxy
(let ((s (open-socket-for-uri uri #:timeout timeout)))
;; Buffer input and output on this port.
- (setvbuf s _IOFBF %http-receive-buffer-size)
+ (setvbuf s 'block %http-receive-buffer-size)
+
+ (when (and https? https-proxy)
+ (setup-http-tunnel s uri))
(if https?
(tls-wrap s (uri-host uri)
#:verify-certificate? verify-certificate?)
s)))))
-(define (close-connection port)
- "Like 'close-port', but (1) idempotent, and (2) also closes the underlying
-port if PORT is a TLS session record port."
- ;; FIXME: This is a partial workaround for <http://bugs.gnu.org/20145>,
- ;; because 'http-fetch' & co. may return a chunked input port whose 'close'
- ;; method calls 'close-port', not 'close-connection'.
+(define (close-connection port) ;deprecated
(unless (port-closed? port)
- (close-port port))
- (and=> (hashq-ref %tls-ports port)
- close-connection))
+ (close-port port)))
;; XXX: This is an awful hack to make sure the (set-port-encoding! p
;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
'set-port-encoding!
(lambda (p e) #f))
-;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile
-;; up to 2.0.7.
-(module-define! (resolve-module '(web client))
- 'shutdown (const #f))
-
-
-;; XXX: Work around <http://bugs.gnu.org/23421>, fixed in Guile commit
-;; 16050431f29d56f80c4a8253506fc851b8441840. Guile's date validation
-;; procedure rejects dates in which the hour is not padded with a zero but
-;; with whitespace.
-(begin
- (define-syntax string-match?
- (lambda (x)
- (syntax-case x ()
- ((_ str pat) (string? (syntax->datum #'pat))
- (let ((p (syntax->datum #'pat)))
- #`(let ((s str))
- (and
- (= (string-length s) #,(string-length p))
- #,@(let lp ((i 0) (tests '()))
- (if (< i (string-length p))
- (let ((c (string-ref p i)))
- (lp (1+ i)
- (case c
- ((#\.) ; Whatever.
- tests)
- ((#\d) ; Digit.
- (cons #`(char-numeric? (string-ref s #,i))
- tests))
- ((#\a) ; Alphabetic.
- (cons #`(char-alphabetic? (string-ref s #,i))
- tests))
- (else ; Literal.
- (cons #`(eqv? (string-ref s #,i) #,c)
- tests)))))
- tests)))))))))
-
- (define (parse-rfc-822-date str space zone-offset)
- (let ((parse-non-negative-integer (@@ (web http) parse-non-negative-integer))
- (parse-month (@@ (web http) parse-month))
- (bad-header (@@ (web http) bad-header)))
- ;; We could verify the day of the week but we don't.
- (cond ((string-match? (substring str 0 space) "aaa, dd aaa dddd dd:dd:dd")
- (let ((date (parse-non-negative-integer str 5 7))
- (month (parse-month str 8 11))
- (year (parse-non-negative-integer str 12 16))
- (hour (parse-non-negative-integer str 17 19))
- (minute (parse-non-negative-integer str 20 22))
- (second (parse-non-negative-integer str 23 25)))
- (make-date 0 second minute hour date month year zone-offset)))
- ((string-match? (substring str 0 space) "aaa, d aaa dddd dd:dd:dd")
- (let ((date (parse-non-negative-integer str 5 6))
- (month (parse-month str 7 10))
- (year (parse-non-negative-integer str 11 15))
- (hour (parse-non-negative-integer str 16 18))
- (minute (parse-non-negative-integer str 19 21))
- (second (parse-non-negative-integer str 22 24)))
- (make-date 0 second minute hour date month year zone-offset)))
-
- ;; The next two clauses match dates that have a space instead of
- ;; a leading zero for hours, like " 8:49:37".
- ((string-match? (substring str 0 space) "aaa, dd aaa dddd d:dd:dd")
- (let ((date (parse-non-negative-integer str 5 7))
- (month (parse-month str 8 11))
- (year (parse-non-negative-integer str 12 16))
- (hour (parse-non-negative-integer str 18 19))
- (minute (parse-non-negative-integer str 20 22))
- (second (parse-non-negative-integer str 23 25)))
- (make-date 0 second minute hour date month year zone-offset)))
- ((string-match? (substring str 0 space) "aaa, d aaa dddd d:dd:dd")
- (let ((date (parse-non-negative-integer str 5 6))
- (month (parse-month str 7 10))
- (year (parse-non-negative-integer str 11 15))
- (hour (parse-non-negative-integer str 17 18))
- (minute (parse-non-negative-integer str 19 21))
- (second (parse-non-negative-integer str 22 24)))
- (make-date 0 second minute hour date month year zone-offset)))
-
- (else
- (bad-header 'date str) ; prevent tail call
- #f))))
- (module-set! (resolve-module '(web http))
- 'parse-rfc-822-date parse-rfc-822-date))
-
-;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile
-;; up to 2.0.11.
-(unless (or (> (string->number (major-version)) 2)
- (> (string->number (minor-version)) 0)
- (> (string->number (micro-version)) 11))
- (let ((var (module-variable (resolve-module '(web http))
- 'declare-relative-uri-header!)))
- ;; If 'declare-relative-uri-header!' doesn't exist, forget it.
- (when (and var (variable-bound? var))
- (let ((declare-relative-uri-header! (variable-ref var)))
- (declare-relative-uri-header! "Location")))))
-
(define (resolve-uri-reference ref base)
"Resolve the URI reference REF, interpreted relative to the BASE URI, into a
target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
#:query (uri-query ref)
#:fragment (uri-fragment ref)))))
-(define* (http-fetch uri file #:key timeout (verify-certificate? #t))
- "Fetch data from URI and write it to FILE; when TIMEOUT is true, bail out if
-the connection could not be established in less than TIMEOUT seconds. Return
-FILE on success. When VERIFY-CERTIFICATE? is true, verify HTTPS
-certificates; otherwise simply ignore them."
-
- (define post-2.0.7?
- (or (> (string->number (major-version)) 2)
- (> (string->number (minor-version)) 0)
- (> (string->number (micro-version)) 7)
- (string>? (version) "2.0.7")))
+(define* (http-fetch uri #:key timeout (verify-certificate? #t))
+ "Return an input port containing the data at URI, and the expected number of
+bytes available or #f. When TIMEOUT is true, bail out if the connection could
+not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is
+true, verify HTTPS certificates; otherwise simply ignore them."
(define headers
`(;; Some web sites, such as http://dist.schmorp.de, would block you if
#:timeout timeout
#:verify-certificate?
verify-certificate?))
- ((resp bv-or-port)
- ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by
- ;; #:streaming? in 2.0.8. We know we're using it within the
- ;; chroot, but `guix-download' might be using a different
- ;; version. So keep this compatibility hack for now.
- (if post-2.0.7?
- (http-get uri #:port connection #:decode-body? #f
- #:streaming? #t
- #:headers headers)
- (if (module-defined? (resolve-interface '(web client))
- 'http-get*)
- (http-get* uri #:port connection #:decode-body? #f
- #:headers headers)
- (http-get uri #:port connection #:decode-body? #f
- #:extra-headers headers))))
+ ((resp port)
+ (http-get uri #:port connection #:decode-body? #f
+ #:streaming? #t
+ #:headers headers))
((code)
- (response-code resp))
- ((size)
- (response-content-length resp)))
+ (response-code resp)))
(case code
((200) ; OK
- (begin
- (call-with-output-file file
- (lambda (p)
- (if (port? bv-or-port)
- (begin
- (dump-port bv-or-port p
- #:buffer-size %http-receive-buffer-size
- #:progress (progress-proc (uri-abbreviation uri)
- size))
- (newline))
- (put-bytevector p bv-or-port))))
- file))
+ (values port (response-content-length resp)))
((301 ; moved permanently
302 ; found (redirection)
- 307) ; temporary redirection
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(format #t "following redirection to `~a'...~%"
(uri->string uri))
(close connection)
- (http-fetch uri file
+ (http-fetch uri
#:timeout timeout
#:verify-certificate? verify-certificate?)))
(else
#:key
(timeout 10) (verify-certificate? #t)
(mirrors '()) (content-addressed-mirrors '())
- (hashes '()))
+ (hashes '())
+ print-build-trace?)
"Fetch FILE from URL; URL may be either a single string, or a list of
string denoting alternate URLs for FILE. Return #f on failure, and FILE
on success.
file (uri->string uri))
(case (uri-scheme uri)
((http https)
- (false-if-exception* (http-fetch uri file
- #:verify-certificate?
- verify-certificate?
- #:timeout timeout)))
+ (false-if-exception*
+ (let-values (((port size)
+ (http-fetch uri
+ #:verify-certificate? verify-certificate?
+ #:timeout timeout)))
+ (call-with-output-file file
+ (lambda (output)
+ (dump-port* port output
+ #:buffer-size %http-receive-buffer-size
+ #:reporter (if print-build-trace?
+ (progress-reporter/trace
+ file (uri->string uri) size)
+ (progress-reporter/file
+ (uri-abbreviation uri) size)))
+ (newline)))
+ file)))
((ftp)
(false-if-exception* (ftp-fetch uri file
- #:timeout timeout)))
+ #:timeout timeout
+ #:print-build-trace?
+ print-build-trace?)))
(else
(format #t "skipping URI with unsupported scheme: ~s~%"
uri)
hashes))
content-addressed-mirrors))
- ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means
- ;; '\n', not '\r', so it's not appropriate here.
- (setvbuf (current-output-port) _IONBF)
+ ;; 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)
- (setvbuf (current-error-port) _IOLBF)
+ (setvbuf (current-error-port) 'line)
(let try ((uri (append uri content-addressed-uris)))
(match uri
(()
(format (current-error-port) "failed to download ~s from ~s~%"
file url)
- #f))))
-;;; Local Variables:
-;;; eval: (put 'with-elapsed-time 'scheme-indent-function 1)
-;;; End:
+ ;; 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
HCoop / jackhill / guix / guix.git / blobdiff