build-aux/download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 ;;;
  20 ;;; Download a binary file from an external source.
  21 ;;;
  22
  23 (use-modules (ice-9 match)
  24              (web uri)
  25              (web client)
  26              (rnrs io ports)
  27              (srfi srfi-11)
  28              (guix utils)
  29              (guix hash))
  30
  31 (define %url-base
  32   "http://alpha.gnu.org/gnu/guix/bootstrap"
  33
  34   ;; Alternately:
  35   ;;"http://www.fdn.fr/~lcourtes/software/guix/packages"
  36   )
  37
  38 ;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile
  39 ;; up to 2.0.7.
  40 (module-define! (resolve-module '(web client))
  41                 'shutdown (const #f))
  42
  43 (define (file-name->uri file)
  44   "Return the URI for FILE."
  45   (match (string-tokenize file (char-set-complement (char-set #\/)))
  46     ((_ ... system basename)
  47      (string->uri (string-append %url-base "/" system
  48                                  "/20131110/" basename)))))
  49
  50 (match (command-line)
  51   ((_ file expected-hash)
  52    (let ((uri (file-name->uri file)))
  53      (format #t "downloading file `~a' from `~a'...~%"
  54              file (uri->string uri))
  55      (let*-values (((resp data) (http-get uri #:decode-body? #f))
  56                    ((hash)      (bytevector->base16-string (sha256 data)))
  57                    ((part)      (string-append file ".part")))
  58        (if (string=? expected-hash hash)
  59            (begin
  60              (call-with-output-file part
  61                (lambda (port)
  62                  (put-bytevector port data)))
  63              (rename-file part file))
  64            (begin
  65              (format (current-error-port)
  66                      "file at `~a' has SHA256 ~a; expected ~a~%"
  67                      (uri->string uri) hash expected-hash)
  68              (exit 1)))))))