guix/build/download.scm

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