build-aux/download.scm

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