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