1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
3 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
5 ;;; This file is part of GNU Guix.
7 ;;; GNU Guix is free software; you can redistribute it and/or modify it
8 ;;; under the terms of the GNU General Public License as published by
9 ;;; the Free Software Foundation; either version 3 of the License, or (at
10 ;;; your option) any later version.
12 ;;; GNU Guix is distributed in the hope that it will be useful, but
13 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 ;;; GNU General Public License for more details.
17 ;;; You should have received a copy of the GNU General Public License
18 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
20 (define-module (guix build download)
21 #:use-module (web uri)
22 #:use-module ((web client) #:hide (open-socket-for-uri))
23 #:use-module (web response)
24 #:use-module (guix ftp-client)
25 #:use-module (guix build utils)
26 #:use-module (rnrs io ports)
27 #:use-module (srfi srfi-1)
28 #:use-module (srfi srfi-11)
29 #:use-module (srfi srfi-19)
30 #:use-module (srfi srfi-26)
31 #:use-module (ice-9 match)
32 #:use-module (ice-9 format)
33 #:export (open-socket-for-uri
34 open-connection-for-uri
43 ;;; Fetch data such as tarballs over HTTP or FTP (builder-side code).
47 (define %http-receive-buffer-size
48 ;; Size of the HTTP receive buffer.
51 (define (duration->seconds duration)
52 "Return the number of seconds represented by DURATION, a 'time-duration'
53 object, as an inexact number."
54 (+ (time-second duration)
55 (/ (time-nanosecond duration) 1e9)))
57 (define (throughput->string throughput)
58 "Given THROUGHPUT, measured in bytes per second, return a string
59 representing it in a human-readable way."
60 (if (> throughput 3e6)
61 (format #f "~,2f MiB/s" (/ throughput (expt 2. 20)))
62 (format #f "~,0f KiB/s" (/ throughput 1024.0))))
64 (define* (progress-proc file size #:optional (log-port (current-output-port)))
65 "Return a procedure to show the progress of FILE's download, which is
66 SIZE byte long. The returned procedure is suitable for use as an
67 argument to `dump-port'. The progress report is written to LOG-PORT."
68 ;; XXX: Because of <http://bugs.gnu.org/19939> this procedure is often not
69 ;; called as frequently as we'd like too; this is especially bad with Nginx
70 ;; on hydra.gnu.org, which returns whole nars as a single chunk.
71 (let ((start-time #f))
72 (let-syntax ((with-elapsed-time
75 (let* ((now (current-time time-monotonic))
76 (elapsed (and start-time
81 (set! start-time now))
84 (lambda (transferred cont)
85 (with-elapsed-time elapsed
86 (let ((% (* 100.0 (/ transferred size)))
87 (throughput (if elapsed
88 (/ transferred elapsed)
90 (display #\cr log-port)
91 (format log-port "~a\t~5,1f% of ~,1f KiB (~a)"
92 file % (/ size 1024.0)
93 (throughput->string throughput))
94 (flush-output-port log-port)
96 (lambda (transferred cont)
97 (with-elapsed-time elapsed
98 (let ((throughput (if elapsed
99 (/ transferred elapsed)
101 (display #\cr log-port)
102 (format log-port "~a\t~6,1f KiB transferred (~a)"
103 file (/ transferred 1024.0)
104 (throughput->string throughput))
105 (flush-output-port log-port)
108 (define* (uri-abbreviation uri #:optional (max-length 42))
109 "If URI's string representation is larger than MAX-LENGTH, return an
110 abbreviation of URI showing the scheme, host, and basename of the file."
111 (define uri-as-string
115 (let ((path (uri-path uri)))
116 (string-append (symbol->string (uri-scheme uri)) "://"
118 ;; `file' URIs have no host part.
119 (or (uri-host uri) "")
121 (string-append "/.../" (basename path)))))
123 (if (> (string-length uri-as-string) max-length)
124 (let ((short (elide-path)))
125 (if (< (string-length short) (string-length uri-as-string))
130 (define (ftp-fetch uri file)
131 "Fetch data from URI and write it to FILE. Return FILE on success."
132 (let* ((conn (ftp-open (uri-host uri)))
133 (size (false-if-exception (ftp-size conn (uri-path uri))))
134 (in (ftp-retr conn (basename (uri-path uri))
135 (dirname (uri-path uri)))))
136 (call-with-output-file file
139 #:buffer-size %http-receive-buffer-size
140 #:progress (progress-proc (uri-abbreviation uri) size))))
146 ;; Autoload GnuTLS so that this module can be used even when GnuTLS is
147 ;; not available. At compile time, this yields "possibly unbound
148 ;; variable" warnings, but these are OK: we know that the variables will
149 ;; be bound if we need them, because (guix download) adds GnuTLS as an
150 ;; input in that case.
152 ;; XXX: Use this hack instead of #:autoload to avoid compilation errors.
153 ;; See <http://bugs.gnu.org/12202>.
154 (module-autoload! (current-module)
155 '(gnutls) '(make-session connection-end/client))
157 (define add-weak-reference
158 (let ((table (make-weak-key-hash-table)))
160 "Hold a weak reference from FROM to TO."
161 (hashq-set! table from to))))
163 (define (tls-wrap port server)
164 "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS
165 host name without trailing dot."
166 (define (log level str)
167 (format (current-error-port)
168 "gnutls: [~a|~a] ~a" (getpid) level str))
170 (let ((session (make-session connection-end/client)))
172 ;; Some servers such as 'cloud.github.com' require the client to support
173 ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is
174 ;; not available in older GnuTLS releases. See
175 ;; <http://bugs.gnu.org/18526> for details.
176 (if (module-defined? (resolve-interface '(gnutls))
177 'set-session-server-name!)
178 (set-session-server-name! session server-name-type/dns server)
179 (format (current-error-port)
180 "warning: TLS 'SERVER NAME' extension not supported~%"))
182 (set-session-transport-fd! session (fileno port))
183 (set-session-default-priority! session)
184 (set-session-credentials! session (make-certificate-credentials))
186 ;; Uncomment the following lines in case of debugging emergency.
187 ;;(set-log-level! 10)
188 ;;(set-log-procedure! log)
191 (let ((record (session-record-port session)))
192 ;; Since we use `fileno' above, the file descriptor behind PORT would be
193 ;; closed when PORT is GC'd. If we used `port->fdes', it would instead
194 ;; never be closed. So we use `fileno', but keep a weak reference to
195 ;; PORT, so the file descriptor gets closed when RECORD is GC'd.
196 (add-weak-reference record port)
199 (define (open-socket-for-uri uri)
200 "Return an open port for URI. This variant works around
201 <http://bugs.gnu.org/15368> which affects Guile's 'open-socket-for-uri' up to
204 ;; The maximum size for a receive buffer on Linux, see socket(7).
205 "/proc/sys/net/core/rmem_max")
208 (if (file-exists? rmem-max)
209 (call-with-input-file rmem-max read)
210 126976)) ;the default for Linux, per 'rmem_default'
212 (let ((s ((@ (web client) open-socket-for-uri) uri)))
213 ;; Work around <http://bugs.gnu.org/15368> by restoring a decent
215 (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size)
218 (define (open-connection-for-uri uri)
219 "Like 'open-socket-for-uri', but also handle HTTPS connections."
221 (eq? 'https (uri-scheme uri)))
223 (let-syntax ((with-https-proxy
226 ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'.
227 ;; FIXME: Proxying is not supported for https.
228 (let ((thunk (lambda () exp)))
231 (resolve-interface '(web client))
232 'current-http-proxy))
233 (parameterize ((current-http-proxy #f))
234 (when (getenv "https_proxy")
235 (format (current-error-port)
236 "warning: 'https_proxy' is ignored~%"))
240 (let ((s (open-socket-for-uri uri)))
241 ;; Buffer input and output on this port.
242 (setvbuf s _IOFBF %http-receive-buffer-size)
245 (tls-wrap s (uri-host uri))
248 ;; XXX: This is an awful hack to make sure the (set-port-encoding! p
249 ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap
250 ;; where iconv is not available.
251 (module-define! (resolve-module '(web response))
255 ;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile
257 (module-define! (resolve-module '(web client))
258 'shutdown (const #f))
260 ;; XXX: Work around <http://bugs.gnu.org/19840>, present in Guile
262 (unless (or (> (string->number (major-version)) 2)
263 (> (string->number (minor-version)) 0)
264 (> (string->number (micro-version)) 11))
265 (let ((var (module-variable (resolve-module '(web http))
266 'declare-relative-uri-header!)))
267 ;; If 'declare-relative-uri-header!' doesn't exist, forget it.
268 (when (and var (variable-bound? var))
269 (let ((declare-relative-uri-header! (variable-ref var)))
270 (declare-relative-uri-header! "Location")))))
272 (define (resolve-uri-reference ref base)
273 "Resolve the URI reference REF, interpreted relative to the BASE URI, into a
274 target URI, according to the algorithm specified in RFC 3986 section 5.2.2.
275 Return the resulting target URI."
277 (define (merge-paths base-path rel-path)
278 (let* ((base-components (string-split base-path #\/))
279 (base-directory-components (match base-components
280 ((components ... last) components)
282 (base-directory (string-join base-directory-components "/")))
283 (string-append base-directory "/" rel-path)))
285 (define (remove-dot-segments path)
287 ;; Drop leading "." and ".." components from a relative path.
288 ;; (absolute paths will start with a "" component)
289 (drop-while (match-lambda
292 (string-split path #\/)))
300 (error "remove-dot-segments: too many '..' components" path))
302 (loop rest (cdr out)))))
304 (loop rest (cons component out)))
306 (string-join (reverse out) "/")))))
308 (cond ((or (uri-scheme ref)
310 (build-uri (or (uri-scheme ref)
312 #:userinfo (uri-userinfo ref)
313 #:host (uri-host ref)
314 #:port (uri-port ref)
315 #:path (remove-dot-segments (uri-path ref))
316 #:query (uri-query ref)
317 #:fragment (uri-fragment ref)))
318 ((string-null? (uri-path ref))
319 (build-uri (uri-scheme base)
320 #:userinfo (uri-userinfo base)
321 #:host (uri-host base)
322 #:port (uri-port base)
323 #:path (remove-dot-segments (uri-path base))
324 #:query (or (uri-query ref)
326 #:fragment (uri-fragment ref)))
328 (build-uri (uri-scheme base)
329 #:userinfo (uri-userinfo base)
330 #:host (uri-host base)
331 #:port (uri-port base)
332 #:path (remove-dot-segments
333 (if (string-prefix? "/" (uri-path ref))
335 (merge-paths (uri-path base)
337 #:query (uri-query ref)
338 #:fragment (uri-fragment ref)))))
340 (define (http-fetch uri file)
341 "Fetch data from URI and write it to FILE. Return FILE on success."
344 (or (> (string->number (major-version)) 2)
345 (> (string->number (minor-version)) 0)
346 (> (string->number (micro-version)) 7)
347 (string>? (version) "2.0.7")))
350 '(;; Some web sites, such as http://dist.schmorp.de, would block you if
351 ;; there's no 'User-Agent' header, presumably on the assumption that
352 ;; you're a spammer. So work around that.
353 (User-Agent . "GNU Guile")
355 ;; Some servers, such as https://alioth.debian.org, return "406 Not
356 ;; Acceptable" when not explicitly told that everything is accepted.
359 (let*-values (((connection)
360 (open-connection-for-uri uri))
362 ;; XXX: `http-get*' was introduced in 2.0.7, and replaced by
363 ;; #:streaming? in 2.0.8. We know we're using it within the
364 ;; chroot, but `guix-download' might be using a different
365 ;; version. So keep this compatibility hack for now.
367 (http-get uri #:port connection #:decode-body? #f
370 (if (module-defined? (resolve-interface '(web client))
372 (http-get* uri #:port connection #:decode-body? #f
374 (http-get uri #:port connection #:decode-body? #f
375 #:extra-headers headers))))
377 (response-code resp))
379 (response-content-length resp)))
383 (call-with-output-file file
385 (if (port? bv-or-port)
387 (dump-port bv-or-port p
388 #:buffer-size %http-receive-buffer-size
389 #:progress (progress-proc (uri-abbreviation uri)
392 (put-bytevector p bv-or-port))))
394 ((301 ; moved permanently
395 302) ; found (redirection)
396 (let ((uri (resolve-uri-reference (response-location resp) uri)))
397 (format #t "following redirection to `~a'...~%"
400 (http-fetch uri file)))
402 (error "download failed" (uri->string uri)
403 code (response-reason-phrase resp))))))
406 (define-syntax-rule (false-if-exception* body ...)
407 "Like `false-if-exception', but print the exception on the error port."
414 (print-exception (current-error-port) #f key args))))
416 (define (uri-vicinity dir file)
417 "Concatenate DIR, slash, and FILE, keeping only one slash in between.
418 This is required by some HTTP servers."
419 (string-append (string-trim-right dir #\/) "/"
420 (string-trim file #\/)))
422 (define (maybe-expand-mirrors uri mirrors)
423 "If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist.
424 Return a list of URIs."
425 (case (uri-scheme uri)
427 (let ((kind (string->symbol (uri-host uri)))
428 (path (uri-path uri)))
429 (match (assoc-ref mirrors kind)
431 (map (compose string->uri (cut uri-vicinity <> path))
434 (error "unsupported URL mirror kind" kind uri)))))
438 (define* (url-fetch url file #:key (mirrors '()))
439 "Fetch FILE from URL; URL may be either a single string, or a list of
440 string denoting alternate URLs for FILE. Return #f on failure, and FILE
443 (append-map (cut maybe-expand-mirrors <> mirrors)
445 ((_ ...) (map string->uri url))
446 (_ (list (string->uri url))))))
448 (define (fetch uri file)
449 (format #t "starting download of `~a' from `~a'...~%"
450 file (uri->string uri))
451 (case (uri-scheme uri)
453 (false-if-exception* (http-fetch uri file)))
455 (false-if-exception* (ftp-fetch uri file)))
457 (format #t "skipping URI with unsupported scheme: ~s~%"
461 ;; Make this unbuffered so 'progress-proc' works as expected. _IOLBF means
462 ;; '\n', not '\r', so it's not appropriate here.
463 (setvbuf (current-output-port) _IONBF)
465 (setvbuf (current-error-port) _IOLBF)
473 (format (current-error-port) "failed to download ~s from ~s~%"
478 ;;; eval: (put 'with-elapsed-time 'scheme-indent-function 1)
481 ;;; download.scm ends here