Commit | Line | Data |
---|---|---|
4155e2a9 | 1 | ;;; GNU Guix --- Functional package management for GNU |
6a7c4636 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> |
04dec194 | 3 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
57d28987 | 4 | ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> |
62cab99c | 5 | ;;; |
4155e2a9 | 6 | ;;; This file is part of GNU Guix. |
62cab99c | 7 | ;;; |
4155e2a9 | 8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it |
62cab99c LC |
9 | ;;; under the terms of the GNU General Public License as published by |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
4155e2a9 | 13 | ;;; GNU Guix is distributed in the hope that it will be useful, but |
62cab99c LC |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
4155e2a9 | 19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
62cab99c LC |
20 | |
21 | (define-module (guix build download) | |
22 | #:use-module (web uri) | |
60fd5122 | 23 | #:use-module (web http) |
76238483 | 24 | #:use-module ((web client) #:hide (open-socket-for-uri)) |
62cab99c | 25 | #:use-module (web response) |
242ad41c | 26 | #:use-module (guix base64) |
62cab99c LC |
27 | #:use-module (guix ftp-client) |
28 | #:use-module (guix build utils) | |
8c348825 | 29 | #:use-module (guix progress) |
62cab99c | 30 | #:use-module (rnrs io ports) |
f4cde9ac | 31 | #:use-module ((ice-9 binary-ports) #:select (unget-bytevector)) |
242ad41c | 32 | #:use-module (rnrs bytevectors) |
94d222ad | 33 | #:use-module (srfi srfi-1) |
62cab99c | 34 | #:use-module (srfi srfi-11) |
9fbe6f19 | 35 | #:use-module (srfi srfi-19) |
94d222ad | 36 | #:use-module (srfi srfi-26) |
bc3c41ce | 37 | #:autoload (ice-9 ftw) (scandir) |
62cab99c | 38 | #:use-module (ice-9 match) |
e47bac79 | 39 | #:use-module (ice-9 format) |
76238483 LC |
40 | #:export (open-socket-for-uri |
41 | open-connection-for-uri | |
347fa4ae | 42 | http-fetch |
b111bcee | 43 | %x509-certificate-directory |
097a951e | 44 | close-connection |
04dec194 | 45 | resolve-uri-reference |
dd8ea244 | 46 | maybe-expand-mirrors |
a3bf0969 | 47 | url-fetch |
a8be7b9a | 48 | byte-count->string |
a8be7b9a | 49 | uri-abbreviation |
cf5e5829 | 50 | nar-uri-abbreviation |
a8be7b9a | 51 | store-path-abbreviation)) |
62cab99c LC |
52 | |
53 | ;;; Commentary: | |
54 | ;;; | |
55 | ;;; Fetch data such as tarballs over HTTP or FTP (builder-side code). | |
56 | ;;; | |
57 | ;;; Code: | |
58 | ||
e7620dc9 LC |
59 | (define %http-receive-buffer-size |
60 | ;; Size of the HTTP receive buffer. | |
61 | 65536) | |
62 | ||
fde17830 LC |
63 | (define* (ellipsis #:optional (port (current-output-port))) |
64 | "Make a rough guess at whether Unicode's HORIZONTAL ELLIPSIS can be written | |
65 | in PORT's encoding, and return either that or ASCII dots." | |
66 | (if (equal? (port-encoding port) "UTF-8") | |
67 | "…" | |
68 | "...")) | |
69 | ||
a8be7b9a | 70 | (define* (store-path-abbreviation store-path #:optional (prefix-length 6)) |
75726135 LC |
71 | "If STORE-PATH is the file name of a store entry, return an abbreviation of |
72 | STORE-PATH for display, showing PREFIX-LENGTH characters of the hash. | |
73 | Otherwise return STORE-PATH." | |
74 | (if (string-prefix? (%store-directory) store-path) | |
75 | (let ((base (basename store-path))) | |
76 | (string-append (string-take base prefix-length) | |
fde17830 | 77 | (ellipsis) |
75726135 LC |
78 | (string-drop base 32))) |
79 | store-path)) | |
a8be7b9a | 80 | |
28e55604 LC |
81 | (define* (uri-abbreviation uri #:optional (max-length 42)) |
82 | "If URI's string representation is larger than MAX-LENGTH, return an | |
83 | abbreviation of URI showing the scheme, host, and basename of the file." | |
84 | (define uri-as-string | |
85 | (uri->string uri)) | |
86 | ||
87 | (define (elide-path) | |
3e31ec82 LC |
88 | (let* ((path (uri-path uri)) |
89 | (base (basename path)) | |
90 | (prefix (string-append (symbol->string (uri-scheme uri)) "://" | |
91 | ||
92 | ;; `file' URIs have no host part. | |
93 | (or (uri-host uri) "") | |
94 | ||
95 | (string-append "/" (ellipsis) "/")))) | |
96 | (if (> (+ (string-length prefix) (string-length base)) max-length) | |
97 | (string-append prefix (ellipsis) | |
98 | (string-drop base (quotient (string-length base) 2))) | |
99 | (string-append prefix base)))) | |
28e55604 LC |
100 | |
101 | (if (> (string-length uri-as-string) max-length) | |
102 | (let ((short (elide-path))) | |
103 | (if (< (string-length short) (string-length uri-as-string)) | |
104 | short | |
105 | uri-as-string)) | |
106 | uri-as-string)) | |
107 | ||
cf5e5829 LC |
108 | (define (nar-uri-abbreviation uri) |
109 | "Abbreviate URI, which is assumed to be the URI of a nar as served by Hydra | |
110 | and 'guix publish', something like | |
111 | \"http://example.org/nar/1ldrllwbna0aw5z8kpci4fsvbd2w8cw4-texlive-bin-2015\"." | |
112 | (let* ((uri (if (string? uri) (string->uri uri) uri)) | |
113 | (path (basename (uri-path uri)))) | |
114 | (if (and (> (string-length path) 33) | |
115 | (char=? (string-ref path 32) #\-)) | |
116 | (string-drop path 33) | |
117 | path))) | |
118 | ||
240a9c69 | 119 | (define* (ftp-fetch uri file #:key timeout print-build-trace?) |
b18ede27 LC |
120 | "Fetch data from URI and write it to FILE. Return FILE on success. Bail |
121 | out if the connection could not be established in less than TIMEOUT seconds." | |
6dfd683d LC |
122 | (let* ((conn (match (and=> (uri-userinfo uri) |
123 | (cut string-split <> #\:)) | |
a4f54234 RJ |
124 | (((? string? user)) |
125 | (ftp-open (uri-host uri) #:timeout timeout | |
126 | #:username user)) | |
127 | (((? string? user) (? string? pass)) | |
128 | (ftp-open (uri-host uri) #:timeout timeout | |
129 | #:username user | |
130 | #:password pass)) | |
131 | (_ (ftp-open (uri-host uri) #:timeout timeout)))) | |
e47bac79 | 132 | (size (false-if-exception (ftp-size conn (uri-path uri)))) |
62cab99c | 133 | (in (ftp-retr conn (basename (uri-path uri)) |
9f860595 LC |
134 | (dirname (uri-path uri)) |
135 | #:timeout timeout))) | |
62cab99c LC |
136 | (call-with-output-file file |
137 | (lambda (out) | |
79864851 SB |
138 | (dump-port* in out |
139 | #:buffer-size %http-receive-buffer-size | |
240a9c69 LC |
140 | #:reporter |
141 | (if print-build-trace? | |
142 | (progress-reporter/trace | |
143 | file (uri->string uri) size) | |
144 | (progress-reporter/file | |
145 | (uri-abbreviation uri) size))))) | |
146 | ||
147 | (ftp-close conn) | |
148 | (unless print-build-trace? | |
149 | (newline)) | |
150 | file)) | |
62cab99c | 151 | |
483f1158 LC |
152 | ;; Autoload GnuTLS so that this module can be used even when GnuTLS is |
153 | ;; not available. At compile time, this yields "possibly unbound | |
154 | ;; variable" warnings, but these are OK: we know that the variables will | |
155 | ;; be bound if we need them, because (guix download) adds GnuTLS as an | |
156 | ;; input in that case. | |
157 | ||
6a7c4636 LC |
158 | (define (load-gnutls) |
159 | ;; XXX: Use this hack instead of #:autoload to avoid compilation errors. | |
160 | ;; See <http://bugs.gnu.org/12202>. | |
058d0251 LC |
161 | (module-use! (resolve-module '(guix build download)) |
162 | (resolve-interface '(gnutls))) | |
6a7c4636 | 163 | (set! load-gnutls (const #t))) |
483f1158 | 164 | |
bc3c41ce LC |
165 | (define %x509-certificate-directory |
166 | ;; The directory where X.509 authority PEM certificates are stored. | |
167 | (make-parameter (or (getenv "GUIX_TLS_CERTIFICATE_DIRECTORY") | |
674e143c LC |
168 | (getenv "SSL_CERT_DIR") ;like OpenSSL |
169 | "/etc/ssl/certs"))) | |
bc3c41ce | 170 | |
27fd13c3 LC |
171 | (define (set-certificate-credentials-x509-trust-file!* cred file format) |
172 | "Like 'set-certificate-credentials-x509-trust-file!', but without the file | |
173 | name decoding bug described at | |
174 | <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=26948#17>." | |
175 | (let ((data (call-with-input-file file get-bytevector-all))) | |
176 | (set-certificate-credentials-x509-trust-data! cred data format))) | |
177 | ||
bc3c41ce LC |
178 | (define (make-credendials-with-ca-trust-files directory) |
179 | "Return certificate credentials with X.509 authority certificates read from | |
180 | DIRECTORY. Those authority certificates are checked when | |
181 | 'peer-certificate-status' is later called." | |
182 | (let ((cred (make-certificate-credentials)) | |
0d78d0f0 LC |
183 | (files (match (scandir directory (cut string-suffix? ".pem" <>)) |
184 | ((or #f ()) | |
185 | ;; Some distros provide nothing but bundles (*.crt) under | |
186 | ;; /etc/ssl/certs, so look for them. | |
187 | (or (scandir directory (cut string-suffix? ".crt" <>)) | |
188 | '())) | |
189 | (pem pem)))) | |
bc3c41ce | 190 | (for-each (lambda (file) |
580deec5 LC |
191 | (let ((file (string-append directory "/" file))) |
192 | ;; Protect against dangling symlinks. | |
193 | (when (file-exists? file) | |
27fd13c3 | 194 | (set-certificate-credentials-x509-trust-file!* |
580deec5 LC |
195 | cred file |
196 | x509-certificate-format/pem)))) | |
0d78d0f0 | 197 | files) |
bc3c41ce LC |
198 | cred)) |
199 | ||
200 | (define (peer-certificate session) | |
201 | "Return the certificate of the remote peer in SESSION." | |
202 | (match (session-peer-certificate-chain session) | |
203 | ((first _ ...) | |
204 | (import-x509-certificate first x509-certificate-format/der)))) | |
205 | ||
206 | (define (assert-valid-server-certificate session server) | |
207 | "Return #t if the certificate of the remote peer for SESSION is a valid | |
208 | certificate for SERVER, where SERVER is the expected host name of peer." | |
209 | (define cert | |
210 | (peer-certificate session)) | |
211 | ||
212 | ;; First check whether the server's certificate matches SERVER. | |
213 | (unless (x509-certificate-matches-hostname? cert server) | |
214 | (throw 'tls-certificate-error 'host-mismatch cert server)) | |
215 | ||
216 | ;; Second check its validity and reachability from the set of authority | |
217 | ;; certificates loaded via 'set-certificate-credentials-x509-trust-file!'. | |
218 | (match (peer-certificate-status session) | |
219 | (() ;certificate is valid | |
220 | #t) | |
221 | ((statuses ...) | |
222 | (throw 'tls-certificate-error 'invalid-certificate cert server | |
223 | statuses)))) | |
224 | ||
225 | (define (print-tls-certificate-error port key args default-printer) | |
226 | "Print the TLS certificate error represented by ARGS in an intelligible | |
227 | way." | |
228 | (match args | |
229 | (('host-mismatch cert server) | |
230 | (format port | |
231 | "X.509 server certificate for '~a' does not match: ~a~%" | |
232 | server (x509-certificate-dn cert))) | |
233 | (('invalid-certificate cert server statuses) | |
234 | (format port | |
235 | "X.509 certificate of '~a' could not be verified:~%~{ ~a~%~}" | |
236 | server | |
237 | (map certificate-status->string statuses))))) | |
238 | ||
239 | (set-exception-printer! 'tls-certificate-error | |
240 | print-tls-certificate-error) | |
241 | ||
242 | (define* (tls-wrap port server #:key (verify-certificate? #t)) | |
077bd18d LC |
243 | "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS |
244 | host name without trailing dot." | |
483f1158 LC |
245 | (define (log level str) |
246 | (format (current-error-port) | |
247 | "gnutls: [~a|~a] ~a" (getpid) level str)) | |
248 | ||
6a7c4636 | 249 | (load-gnutls) |
bc3c41ce LC |
250 | (let ((session (make-session connection-end/client)) |
251 | (ca-certs (%x509-certificate-directory))) | |
077bd18d LC |
252 | |
253 | ;; Some servers such as 'cloud.github.com' require the client to support | |
254 | ;; the 'SERVER NAME' extension. However, 'set-session-server-name!' is | |
255 | ;; not available in older GnuTLS releases. See | |
256 | ;; <http://bugs.gnu.org/18526> for details. | |
257 | (if (module-defined? (resolve-interface '(gnutls)) | |
258 | 'set-session-server-name!) | |
259 | (set-session-server-name! session server-name-type/dns server) | |
260 | (format (current-error-port) | |
261 | "warning: TLS 'SERVER NAME' extension not supported~%")) | |
262 | ||
483f1158 LC |
263 | (set-session-transport-fd! session (fileno port)) |
264 | (set-session-default-priority! session) | |
967ee481 LC |
265 | |
266 | ;; The "%COMPAT" bit allows us to work around firewall issues (info | |
267 | ;; "(gnutls) Priority Strings"); see <http://bugs.gnu.org/23311>. | |
268 | ;; Explicitly disable SSLv3, which is insecure: | |
269 | ;; <https://tools.ietf.org/html/rfc7568>. | |
621fb83a | 270 | (set-session-priorities! session "NORMAL:%COMPAT:-VERS-SSL3.0") |
967ee481 | 271 | |
bc3c41ce LC |
272 | (set-session-credentials! session |
273 | (if (and verify-certificate? ca-certs) | |
274 | (make-credendials-with-ca-trust-files | |
275 | ca-certs) | |
276 | (make-certificate-credentials))) | |
483f1158 LC |
277 | |
278 | ;; Uncomment the following lines in case of debugging emergency. | |
279 | ;;(set-log-level! 10) | |
280 | ;;(set-log-procedure! log) | |
281 | ||
7b9ac883 LC |
282 | (catch 'gnutls-error |
283 | (lambda () | |
284 | (handshake session)) | |
285 | (lambda (key err proc . rest) | |
286 | (cond ((eq? err error/warning-alert-received) | |
287 | ;; Like Wget, do no stop upon non-fatal alerts such as | |
288 | ;; 'alert-description/unrecognized-name'. | |
289 | (format (current-error-port) | |
290 | "warning: TLS warning alert received: ~a~%" | |
291 | (alert-description->string (alert-get session))) | |
292 | (handshake session)) | |
293 | (else | |
294 | ;; XXX: We'd use 'gnutls_error_is_fatal' but (gnutls) doesn't | |
295 | ;; provide a binding for this. | |
296 | (apply throw key err proc rest))))) | |
bc3c41ce LC |
297 | |
298 | ;; Verify the server's certificate if needed. | |
299 | (when verify-certificate? | |
300 | (catch 'tls-certificate-error | |
301 | (lambda () | |
302 | (assert-valid-server-certificate session server)) | |
303 | (lambda args | |
304 | (close-port port) | |
305 | (apply throw args)))) | |
306 | ||
dd9afe64 | 307 | (let ((record (session-record-port session))) |
f4cde9ac LC |
308 | (define (read! bv start count) |
309 | (define read-bv (get-bytevector-some record)) | |
310 | (if (eof-object? read-bv) | |
311 | 0 ; read! returns 0 on eof-object | |
312 | (let ((read-bv-len (bytevector-length read-bv))) | |
313 | (bytevector-copy! read-bv 0 bv start (min read-bv-len count)) | |
314 | (when (< count read-bv-len) | |
315 | (unget-bytevector record bv count (- read-bv-len count))) | |
316 | read-bv-len))) | |
317 | (define (write! bv start count) | |
318 | (put-bytevector record bv start count) | |
319 | (force-output record) | |
320 | count) | |
321 | (define (get-position) | |
322 | (port-position record)) | |
323 | (define (set-position! new-position) | |
324 | (set-port-position! record new-position)) | |
325 | (define (close) | |
326 | (unless (port-closed? port) | |
327 | (close-port port)) | |
328 | (unless (port-closed? record) | |
329 | (close-port record))) | |
330 | ||
331 | (setvbuf record 'block) | |
332 | ||
333 | ;; Return a port that wraps RECORD to ensure that closing it also | |
334 | ;; closes PORT, the actual socket port, and its file descriptor. | |
335 | ;; XXX: This wrapper would be unnecessary if GnuTLS could | |
336 | ;; automatically close SESSION's file descriptor when RECORD is | |
337 | ;; closed, but that doesn't seem to be possible currently (as of | |
338 | ;; 3.6.9). | |
339 | (make-custom-binary-input/output-port "gnutls wrapped port" read! write! | |
340 | get-position set-position! | |
341 | close)))) | |
483f1158 | 342 | |
60fd5122 LC |
343 | (define (ensure-uri uri-or-string) ;XXX: copied from (web http) |
344 | (cond | |
345 | ((string? uri-or-string) (string->uri uri-or-string)) | |
346 | ((uri? uri-or-string) uri-or-string) | |
347 | (else (error "Invalid URI" uri-or-string)))) | |
348 | ||
60fd5122 LC |
349 | (define* (open-socket-for-uri uri-or-string #:key timeout) |
350 | "Return an open input/output port for a connection to URI. When TIMEOUT is | |
351 | not #f, it must be a (possibly inexact) number denoting the maximum duration | |
352 | in seconds to wait for the connection to complete; passed TIMEOUT, an | |
353 | ETIMEDOUT error is raised." | |
354 | ;; Includes a fix for <http://bugs.gnu.org/15368> which affects Guile's | |
1b9aefa3 LC |
355 | ;; 'open-socket-for-uri' up to 2.0.11 included, uses 'connect*' instead |
356 | ;; of 'connect', and uses AI_ADDRCONFIG. | |
60fd5122 LC |
357 | |
358 | (define http-proxy (current-http-proxy)) | |
359 | (define uri (ensure-uri (or http-proxy uri-or-string))) | |
360 | (define addresses | |
361 | (let ((port (uri-port uri))) | |
362 | (delete-duplicates | |
363 | (getaddrinfo (uri-host uri) | |
364 | (cond (port => number->string) | |
365 | (else (symbol->string (uri-scheme uri)))) | |
1b9aefa3 LC |
366 | (if (number? port) |
367 | (logior AI_ADDRCONFIG AI_NUMERICSERV) | |
368 | AI_ADDRCONFIG)) | |
60fd5122 LC |
369 | (lambda (ai1 ai2) |
370 | (equal? (addrinfo:addr ai1) (addrinfo:addr ai2)))))) | |
371 | ||
372 | (let loop ((addresses addresses)) | |
373 | (let* ((ai (car addresses)) | |
374 | (s (with-fluids ((%default-port-encoding #f)) | |
375 | ;; Restrict ourselves to TCP. | |
376 | (socket (addrinfo:fam ai) SOCK_STREAM IPPROTO_IP)))) | |
377 | (catch 'system-error | |
378 | (lambda () | |
379 | (connect* s (addrinfo:addr ai) timeout) | |
380 | ||
381 | ;; Buffer input and output on this port. | |
76832d34 | 382 | (setvbuf s 'block) |
60fd5122 LC |
383 | ;; If we're using a proxy, make a note of that. |
384 | (when http-proxy (set-http-proxy-port?! s #t)) | |
385 | s) | |
386 | (lambda args | |
387 | ;; Connection failed, so try one of the other addresses. | |
388 | (close s) | |
389 | (if (null? (cdr addresses)) | |
390 | (apply throw args) | |
391 | (loop (cdr addresses)))))))) | |
392 | ||
9bc8175c SB |
393 | (define (setup-http-tunnel port uri) |
394 | "Establish over PORT an HTTP tunnel to the destination server of URI." | |
395 | (define target | |
396 | (string-append (uri-host uri) ":" | |
397 | (number->string | |
398 | (or (uri-port uri) | |
399 | (match (uri-scheme uri) | |
400 | ('http 80) | |
401 | ('https 443)))))) | |
402 | (format port "CONNECT ~a HTTP/1.1\r\n" target) | |
403 | (format port "Host: ~a\r\n\r\n" target) | |
404 | (force-output port) | |
405 | (read-response port)) | |
406 | ||
bc3c41ce LC |
407 | (define* (open-connection-for-uri uri |
408 | #:key | |
409 | timeout | |
410 | (verify-certificate? #t)) | |
097a951e | 411 | "Like 'open-socket-for-uri', but also handle HTTPS connections. The |
bc3c41ce LC |
412 | resulting port must be closed with 'close-connection'. When |
413 | VERIFY-CERTIFICATE? is true, verify HTTPS server certificates." | |
4fd06a4d LC |
414 | ;; Note: Guile 2.2.0's (web client) has a same-named export that's actually |
415 | ;; undefined. See Guile commit 011669af3b428e5626f7bbf66b11d57d9768c047. | |
416 | ||
d17551d9 LC |
417 | (define https? |
418 | (eq? 'https (uri-scheme uri))) | |
419 | ||
9bc8175c SB |
420 | (define https-proxy (let ((proxy (getenv "https_proxy"))) |
421 | (and (not (equal? proxy "")) | |
422 | proxy))) | |
423 | ||
d17551d9 LC |
424 | (let-syntax ((with-https-proxy |
425 | (syntax-rules () | |
426 | ((_ exp) | |
427 | ;; For HTTPS URIs, honor 'https_proxy', not 'http_proxy'. | |
d17551d9 LC |
428 | (let ((thunk (lambda () exp))) |
429 | (if (and https? | |
430 | (module-variable | |
431 | (resolve-interface '(web client)) | |
432 | 'current-http-proxy)) | |
9bc8175c | 433 | (parameterize ((current-http-proxy https-proxy)) |
d17551d9 LC |
434 | (thunk)) |
435 | (thunk))))))) | |
436 | (with-https-proxy | |
60fd5122 | 437 | (let ((s (open-socket-for-uri uri #:timeout timeout))) |
c822fb8e | 438 | ;; Buffer input and output on this port. |
76832d34 | 439 | (setvbuf s 'block %http-receive-buffer-size) |
c822fb8e | 440 | |
9bc8175c SB |
441 | (when (and https? https-proxy) |
442 | (setup-http-tunnel s uri)) | |
443 | ||
d17551d9 | 444 | (if https? |
bc3c41ce LC |
445 | (tls-wrap s (uri-host uri) |
446 | #:verify-certificate? verify-certificate?) | |
d17551d9 | 447 | s))))) |
62cab99c | 448 | |
f4cde9ac | 449 | (define (close-connection port) ;deprecated |
097a951e | 450 | (unless (port-closed? port) |
f4cde9ac | 451 | (close-port port))) |
097a951e | 452 | |
62cab99c LC |
453 | ;; XXX: This is an awful hack to make sure the (set-port-encoding! p |
454 | ;; "ISO-8859-1") call in `read-response' passes, even during bootstrap | |
455 | ;; where iconv is not available. | |
456 | (module-define! (resolve-module '(web response)) | |
457 | 'set-port-encoding! | |
458 | (lambda (p e) #f)) | |
459 | ||
04dec194 MW |
460 | (define (resolve-uri-reference ref base) |
461 | "Resolve the URI reference REF, interpreted relative to the BASE URI, into a | |
462 | target URI, according to the algorithm specified in RFC 3986 section 5.2.2. | |
463 | Return the resulting target URI." | |
464 | ||
465 | (define (merge-paths base-path rel-path) | |
466 | (let* ((base-components (string-split base-path #\/)) | |
467 | (base-directory-components (match base-components | |
468 | ((components ... last) components) | |
469 | (() '()))) | |
470 | (base-directory (string-join base-directory-components "/"))) | |
471 | (string-append base-directory "/" rel-path))) | |
472 | ||
473 | (define (remove-dot-segments path) | |
474 | (let loop ((in | |
475 | ;; Drop leading "." and ".." components from a relative path. | |
476 | ;; (absolute paths will start with a "" component) | |
477 | (drop-while (match-lambda | |
478 | ((or "." "..") #t) | |
479 | (_ #f)) | |
480 | (string-split path #\/))) | |
481 | (out '())) | |
482 | (match in | |
483 | (("." . rest) | |
484 | (loop rest out)) | |
485 | ((".." . rest) | |
486 | (match out | |
487 | ((or () ("")) | |
488 | (error "remove-dot-segments: too many '..' components" path)) | |
489 | (_ | |
490 | (loop rest (cdr out))))) | |
491 | ((component . rest) | |
492 | (loop rest (cons component out))) | |
493 | (() | |
494 | (string-join (reverse out) "/"))))) | |
495 | ||
496 | (cond ((or (uri-scheme ref) | |
497 | (uri-host ref)) | |
498 | (build-uri (or (uri-scheme ref) | |
499 | (uri-scheme base)) | |
500 | #:userinfo (uri-userinfo ref) | |
501 | #:host (uri-host ref) | |
502 | #:port (uri-port ref) | |
503 | #:path (remove-dot-segments (uri-path ref)) | |
504 | #:query (uri-query ref) | |
505 | #:fragment (uri-fragment ref))) | |
506 | ((string-null? (uri-path ref)) | |
507 | (build-uri (uri-scheme base) | |
508 | #:userinfo (uri-userinfo base) | |
509 | #:host (uri-host base) | |
510 | #:port (uri-port base) | |
511 | #:path (remove-dot-segments (uri-path base)) | |
512 | #:query (or (uri-query ref) | |
513 | (uri-query base)) | |
514 | #:fragment (uri-fragment ref))) | |
515 | (else | |
516 | (build-uri (uri-scheme base) | |
517 | #:userinfo (uri-userinfo base) | |
518 | #:host (uri-host base) | |
519 | #:port (uri-port base) | |
520 | #:path (remove-dot-segments | |
521 | (if (string-prefix? "/" (uri-path ref)) | |
522 | (uri-path ref) | |
523 | (merge-paths (uri-path base) | |
524 | (uri-path ref)))) | |
525 | #:query (uri-query ref) | |
526 | #:fragment (uri-fragment ref))))) | |
527 | ||
347fa4ae LC |
528 | (define* (http-fetch uri #:key timeout (verify-certificate? #t)) |
529 | "Return an input port containing the data at URI, and the expected number of | |
530 | bytes available or #f. When TIMEOUT is true, bail out if the connection could | |
531 | not be established in less than TIMEOUT seconds. When VERIFY-CERTIFICATE? is | |
532 | true, verify HTTPS certificates; otherwise simply ignore them." | |
62cab99c | 533 | |
2de227af | 534 | (define headers |
242ad41c | 535 | `(;; Some web sites, such as http://dist.schmorp.de, would block you if |
38bf090e LC |
536 | ;; there's no 'User-Agent' header, presumably on the assumption that |
537 | ;; you're a spammer. So work around that. | |
538 | (User-Agent . "GNU Guile") | |
539 | ||
540 | ;; Some servers, such as https://alioth.debian.org, return "406 Not | |
541 | ;; Acceptable" when not explicitly told that everything is accepted. | |
242ad41c DT |
542 | (Accept . "*/*") |
543 | ||
544 | ;; Basic authentication, if needed. | |
545 | ,@(match (uri-userinfo uri) | |
546 | ((? string? str) | |
547 | `((Authorization . ,(string-append "Basic " | |
548 | (base64-encode | |
549 | (string->utf8 str)))))) | |
550 | (_ '())))) | |
2de227af | 551 | |
62cab99c | 552 | (let*-values (((connection) |
bc3c41ce LC |
553 | (open-connection-for-uri uri |
554 | #:timeout timeout | |
555 | #:verify-certificate? | |
556 | verify-certificate?)) | |
b3ac341d | 557 | ((resp port) |
36626c55 LC |
558 | (http-get uri #:port connection #:decode-body? #f |
559 | #:streaming? #t | |
560 | #:headers headers)) | |
62cab99c | 561 | ((code) |
347fa4ae | 562 | (response-code resp))) |
270246de LC |
563 | (case code |
564 | ((200) ; OK | |
347fa4ae | 565 | (values port (response-content-length resp))) |
67158a49 | 566 | ((301 ; moved permanently |
82fd23b8 | 567 | 302 ; found (redirection) |
57d28987 TGR |
568 | 303 ; see other |
569 | 307 ; temporary redirection | |
570 | 308) ; permanent redirection | |
04dec194 | 571 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
270246de LC |
572 | (format #t "following redirection to `~a'...~%" |
573 | (uri->string uri)) | |
574 | (close connection) | |
347fa4ae | 575 | (http-fetch uri |
bc3c41ce LC |
576 | #:timeout timeout |
577 | #:verify-certificate? verify-certificate?))) | |
270246de LC |
578 | (else |
579 | (error "download failed" (uri->string uri) | |
580 | code (response-reason-phrase resp)))))) | |
62cab99c LC |
581 | |
582 | \f | |
583 | (define-syntax-rule (false-if-exception* body ...) | |
584 | "Like `false-if-exception', but print the exception on the error port." | |
585 | (catch #t | |
586 | (lambda () | |
587 | body ...) | |
588 | (lambda (key . args) | |
589 | #f) | |
590 | (lambda (key . args) | |
591 | (print-exception (current-error-port) #f key args)))) | |
592 | ||
dd8ea244 LC |
593 | (define (uri-vicinity dir file) |
594 | "Concatenate DIR, slash, and FILE, keeping only one slash in between. | |
595 | This is required by some HTTP servers." | |
596 | (string-append (string-trim-right dir #\/) "/" | |
597 | (string-trim file #\/))) | |
598 | ||
599 | (define (maybe-expand-mirrors uri mirrors) | |
600 | "If URI uses the 'mirror' scheme, expand it according to the MIRRORS alist. | |
601 | Return a list of URIs." | |
602 | (case (uri-scheme uri) | |
603 | ((mirror) | |
604 | (let ((kind (string->symbol (uri-host uri))) | |
605 | (path (uri-path uri))) | |
606 | (match (assoc-ref mirrors kind) | |
607 | ((mirrors ..1) | |
608 | (map (compose string->uri (cut uri-vicinity <> path)) | |
609 | mirrors)) | |
610 | (_ | |
611 | (error "unsupported URL mirror kind" kind uri))))) | |
612 | (else | |
613 | (list uri)))) | |
614 | ||
cd436bf0 LC |
615 | (define* (url-fetch url file |
616 | #:key | |
bc3c41ce | 617 | (timeout 10) (verify-certificate? #t) |
cd436bf0 | 618 | (mirrors '()) (content-addressed-mirrors '()) |
240a9c69 LC |
619 | (hashes '()) |
620 | print-build-trace?) | |
62cab99c LC |
621 | "Fetch FILE from URL; URL may be either a single string, or a list of |
622 | string denoting alternate URLs for FILE. Return #f on failure, and FILE | |
cd436bf0 LC |
623 | on success. |
624 | ||
625 | When MIRRORS is defined, it must be an alist of mirrors; it is used to resolve | |
626 | 'mirror://' URIs. | |
627 | ||
628 | HASHES must be a list of algorithm/hash pairs, where each algorithm is a | |
629 | symbol such as 'sha256 and each hash is a bytevector. | |
630 | CONTENT-ADDRESSED-MIRRORS must be a list of procedures that, given a hash | |
631 | algorithm and a hash, return a URL where the specified data can be retrieved | |
bc3c41ce LC |
632 | or #f. |
633 | ||
634 | When VERIFY-CERTIFICATE? is true, validate HTTPS server certificates; | |
635 | otherwise simply ignore them." | |
62cab99c | 636 | (define uri |
dd8ea244 | 637 | (append-map (cut maybe-expand-mirrors <> mirrors) |
94d222ad LC |
638 | (match url |
639 | ((_ ...) (map string->uri url)) | |
640 | (_ (list (string->uri url)))))) | |
62cab99c LC |
641 | |
642 | (define (fetch uri file) | |
94628828 | 643 | (format #t "~%Starting download of ~a~%From ~a...~%" |
62cab99c LC |
644 | file (uri->string uri)) |
645 | (case (uri-scheme uri) | |
483f1158 | 646 | ((http https) |
347fa4ae LC |
647 | (false-if-exception* |
648 | (let-values (((port size) | |
649 | (http-fetch uri | |
650 | #:verify-certificate? verify-certificate? | |
651 | #:timeout timeout))) | |
652 | (call-with-output-file file | |
653 | (lambda (output) | |
654 | (dump-port* port output | |
655 | #:buffer-size %http-receive-buffer-size | |
240a9c69 LC |
656 | #:reporter (if print-build-trace? |
657 | (progress-reporter/trace | |
658 | file (uri->string uri) size) | |
659 | (progress-reporter/file | |
660 | (uri-abbreviation uri) size))) | |
347fa4ae | 661 | (newline))) |
8fbc1a22 | 662 | file))) |
483f1158 | 663 | ((ftp) |
bc3c41ce | 664 | (false-if-exception* (ftp-fetch uri file |
240a9c69 LC |
665 | #:timeout timeout |
666 | #:print-build-trace? | |
667 | print-build-trace?))) | |
62cab99c LC |
668 | (else |
669 | (format #t "skipping URI with unsupported scheme: ~s~%" | |
670 | uri) | |
671 | #f))) | |
672 | ||
dab2472c | 673 | (define content-addressed-uris |
cd436bf0 LC |
674 | (append-map (lambda (make-url) |
675 | (filter-map (match-lambda | |
676 | ((hash-algo . hash) | |
38f1cf8a LC |
677 | (let ((file (strip-store-file-name file))) |
678 | (string->uri (make-url file hash-algo hash))))) | |
cd436bf0 LC |
679 | hashes)) |
680 | content-addressed-mirrors)) | |
681 | ||
76832d34 | 682 | ;; Make this unbuffered so 'progress-report/file' works as expected. 'line |
79864851 | 683 | ;; means '\n', not '\r', so it's not appropriate here. |
76832d34 | 684 | (setvbuf (current-output-port) 'none) |
395bea2a | 685 | |
76832d34 | 686 | (setvbuf (current-error-port) 'line) |
62cab99c | 687 | |
dab2472c | 688 | (let try ((uri (append uri content-addressed-uris))) |
62cab99c LC |
689 | (match uri |
690 | ((uri tail ...) | |
691 | (or (fetch uri file) | |
692 | (try tail))) | |
693 | (() | |
694 | (format (current-error-port) "failed to download ~s from ~s~%" | |
695 | file url) | |
4a6ec23a LC |
696 | |
697 | ;; Remove FILE in case we made an incomplete download, for example due | |
698 | ;; to ENOSPC. | |
699 | (catch 'system-error | |
700 | (lambda () | |
701 | (delete-file file)) | |
702 | (const #f)) | |
62cab99c LC |
703 | #f)))) |
704 | ||
705 | ;;; download.scm ends here |