build-aux/download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2014, 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 ;;;
  21 ;;; Download a binary file from an external source.
  22 ;;;
  23
  24 (use-modules (ice-9 match)
  25              (web uri)
  26              (web client)
  27              (rnrs io ports)
  28              (srfi srfi-11)
  29              (guix utils)
  30              (guix hash))
  31
  32 (define %url-base
  33   "http://alpha.gnu.org/gnu/guix/bootstrap"
  34
  35   ;; Alternately:
  36   ;;"http://www.fdn.fr/~lcourtes/software/guix/packages"
  37   )
  38
  39 ;; XXX: Work around <http://bugs.gnu.org/13095>, present in Guile
  40 ;; up to 2.0.7.
  41 (module-define! (resolve-module '(web client))
  42                 'shutdown (const #f))
  43
  44 (define (file-name->uri file)
  45   "Return the URI for FILE."
  46   (match (string-tokenize file (char-set-complement (char-set #\/)))
  47     ((_ ... system basename)
  48      (string->uri (string-append %url-base "/" system
  49                                  (match system
  50                                    ("armhf-linux"
  51                                     "/20150101/")
  52                                    (_
  53                                     "/20131110/"))
  54                                  basename)))))
  55
  56 (match (command-line)
  57   ((_ file expected-hash)
  58    (let ((uri (file-name->uri file)))
  59      (format #t "downloading file `~a' from `~a'...~%"
  60              file (uri->string uri))
  61      (let*-values (((resp data) (http-get uri #:decode-body? #f))
  62                    ((hash)      (bytevector->base16-string (sha256 data)))
  63                    ((part)      (string-append file ".part")))
  64        (if (string=? expected-hash hash)
  65            (begin
  66              (call-with-output-file part
  67                (lambda (port)
  68                  (put-bytevector port data)))
  69              (rename-file part file))
  70            (begin
  71              (format (current-error-port)
  72                      "file at `~a' has SHA256 ~a; expected ~a~%"
  73                      (uri->string uri) hash expected-hash)
  74              (exit 1)))))))