guix/build/download.scm

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