diff options
Diffstat (limited to 'guix/build/download.scm')
| -rw-r--r-- | guix/build/download.scm | 84 |
1 files changed, 70 insertions, 14 deletions
diff --git a/guix/build/download.scm b/guix/build/download.scm index 074315cc9f..09c62541de 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -1,20 +1,20 @@ -;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- -;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> ;;; -;;; This file is part of Guix. +;;; This file is part of GNU Guix. ;;; -;;; Guix is free software; you can redistribute it and/or modify it +;;; GNU Guix is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or (at ;;; your option) any later version. ;;; -;;; Guix is distributed in the hope that it will be useful, but +;;; GNU Guix is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;;; GNU General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License -;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix build download) #:use-module (web uri) @@ -27,6 +27,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module (ice-9 format) #:export (url-fetch)) ;;; Commentary: @@ -35,17 +36,58 @@ ;;; ;;; Code: +(define* (progress-proc file size #:optional (log-port (current-output-port))) + "Return a procedure to show the progress of FILE's download, which is +SIZE byte long. The returned procedure is suitable for use as an +argument to `dump-port'. The progress report is written to LOG-PORT." + (if (number? size) + (lambda (transferred cont) + (let ((% (* 100.0 (/ transferred size)))) + (display #\cr log-port) + (format log-port "~a\t~5,1f% of ~,1f KiB" + file % (/ size 1024.0)) + (flush-output-port log-port) + (cont))) + (lambda (transferred cont) + (display #\cr log-port) + (format log-port "~a\t~6,1f KiB transferred" + file (/ transferred 1024.0)) + (flush-output-port log-port) + (cont)))) + +(define* (uri-abbreviation uri #:optional (max-length 42)) + "If URI's string representation is larger than MAX-LENGTH, return an +abbreviation of URI showing the scheme, host, and basename of the file." + (define uri-as-string + (uri->string uri)) + + (define (elide-path) + (let ((path (uri-path uri))) + (string-append (symbol->string (uri-scheme uri)) + "://" (uri-host uri) + (string-append "/.../" (basename path))))) + + (if (> (string-length uri-as-string) max-length) + (let ((short (elide-path))) + (if (< (string-length short) (string-length uri-as-string)) + short + uri-as-string)) + uri-as-string)) + (define (ftp-fetch uri file) "Fetch data from URI and write it to FILE. Return FILE on success." (let* ((conn (ftp-open (uri-host uri))) + (size (false-if-exception (ftp-size conn (uri-path uri)))) (in (ftp-retr conn (basename (uri-path uri)) (dirname (uri-path uri))))) (call-with-output-file file (lambda (out) - ;; TODO: Show a progress bar. - (dump-port in out))) + (dump-port in out + #:buffer-size 65536 ; don't flood the log + #:progress (progress-proc (uri-abbreviation uri) size)))) (ftp-close conn)) + (newline) file) (define (open-connection-for-uri uri) @@ -103,20 +145,34 @@ which is not available during bootstrap." (define (http-fetch uri file) "Fetch data from URI and write it to FILE. Return FILE on success." - ;; FIXME: Use a variant of `http-get' that returns a port instead of - ;; loading everything in memory. (let*-values (((connection) (open-connection-for-uri uri)) - ((resp bv) - (http-get uri #:port connection #:decode-body? #f)) + ((resp bv-or-port) + ;; XXX: `http-get*' was introduced in 2.0.7. We know + ;; we're using it within the chroot, but + ;; `guix-download' might be using a different version. + ;; So keep this compatibility hack for now. + (if (module-defined? (resolve-interface '(web client)) + 'http-get*) + (http-get* uri #:port connection #:decode-body? #f) + (http-get uri #:port connection #:decode-body? #f))) ((code) - (response-code resp))) + (response-code resp)) + ((size) + (response-content-length resp))) (case code ((200) ; OK (begin (call-with-output-file file (lambda (p) - (put-bytevector p bv))) + (if (port? bv-or-port) + (begin + (dump-port bv-or-port p + #:buffer-size 65536 ; don't flood the log + #:progress (progress-proc (uri-abbreviation uri) + size)) + (newline)) + (put-bytevector p bv-or-port)))) file)) ((302) ; found (redirection) (let ((uri (response-location resp))) |