guix/scripts/download.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2015, 2016, 2017 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 (define-module (guix scripts download)
  20   #:use-module (guix ui)
  21   #:use-module (guix scripts)
  22   #:use-module (guix store)
  23   #:use-module (gcrypt hash)
  24   #:use-module (guix base16)
  25   #:use-module (guix base32)
  26   #:use-module ((guix download) #:hide (url-fetch))
  27   #:use-module ((guix build download)
  28                 #:select (url-fetch))
  29   #:use-module ((guix progress)
  30                 #:select (current-terminal-columns))
  31   #:use-module ((guix build syscalls)
  32                 #:select (terminal-columns))
  33   #:use-module (web uri)
  34   #:use-module (ice-9 match)
  35   #:use-module (srfi srfi-1)
  36   #:use-module (srfi srfi-26)
  37   #:use-module (srfi srfi-37)
  38   #:use-module (rnrs bytevectors)
  39   #:use-module (ice-9 binary-ports)
  40   #:export (guix-download))
  41
  42 \f
  43 ;;;
  44 ;;; Command-line options.
  45 ;;;
  46
  47 (define (download-to-file url file)
  48   "Download the file at URI to FILE.  Return FILE."
  49   (let ((uri (string->uri url)))
  50     (match (uri-scheme uri)
  51       ((or 'file #f)
  52        (copy-file (uri-path uri) file))
  53       (_
  54        (url-fetch url file #:mirrors %mirrors)))
  55     file))
  56
  57 (define* (download-to-store* url #:key (verify-certificate? #t))
  58   (with-store store
  59     (download-to-store store url
  60                        #:verify-certificate? verify-certificate?)))
  61
  62 (define %default-options
  63   ;; Alist of default option values.
  64   `((format . ,bytevector->nix-base32-string)
  65     (verify-certificate? . #t)
  66     (download-proc . ,download-to-store*)))
  67
  68 (define (show-help)
  69   (display (G_ "Usage: guix download [OPTION] URL
  70 Download the file at URL to the store or to the given file, and print its
  71 file name and the hash of its contents.
  72
  73 Supported formats: 'nix-base32' (default), 'base32', and 'base16'
  74 ('hex' and 'hexadecimal' can be used as well).\n"))
  75   (format #t (G_ "
  76   -f, --format=FMT       write the hash in the given format"))
  77   (format #t (G_ "
  78       --no-check-certificate
  79                          do not validate the certificate of HTTPS servers "))
  80   (format #t (G_ "
  81   -o, --output=FILE      download to FILE"))
  82   (newline)
  83   (display (G_ "
  84   -h, --help             display this help and exit"))
  85   (display (G_ "
  86   -V, --version          display version information and exit"))
  87   (newline)
  88   (show-bug-report-information))
  89
  90 (define %options
  91   ;; Specifications of the command-line options.
  92   (list (option '(#\f "format") #t #f
  93                 (lambda (opt name arg result)
  94                   (define fmt-proc
  95                     (match arg
  96                       ("nix-base32"
  97                        bytevector->nix-base32-string)
  98                       ("base32"
  99                        bytevector->base32-string)
 100                       ((or "base16" "hex" "hexadecimal")
 101                        bytevector->base16-string)
 102                       (x
 103                        (leave (G_ "unsupported hash format: ~a~%") arg))))
 104
 105                   (alist-cons 'format fmt-proc
 106                               (alist-delete 'format result))))
 107         (option '("no-check-certificate") #f #f
 108                 (lambda (opt name arg result)
 109                   (alist-cons 'verify-certificate? #f result)))
 110         (option '(#\o "output") #t #f
 111                 (lambda (opt name arg result)
 112                   (alist-cons 'download-proc
 113                               (lambda* (url #:key verify-certificate?)
 114                                 (download-to-file url arg))
 115                               (alist-delete 'download result))))
 116
 117         (option '(#\h "help") #f #f
 118                 (lambda args
 119                   (show-help)
 120                   (exit 0)))
 121         (option '(#\V "version") #f #f
 122                 (lambda args
 123                   (show-version-and-exit "guix download")))))
 124
 125 \f
 126 ;;;
 127 ;;; Entry point.
 128 ;;;
 129
 130 (define (guix-download . args)
 131   (define (parse-options)
 132     ;; Return the alist of option values.
 133     (args-fold* args %options
 134                 (lambda (opt name arg result)
 135                   (leave (G_ "~A: unrecognized option~%") name))
 136                 (lambda (arg result)
 137                   (when (assq 'argument result)
 138                     (leave (G_ "~A: extraneous argument~%") arg))
 139
 140                   (alist-cons 'argument arg result))
 141                 %default-options))
 142
 143   (with-error-handling
 144     (let* ((opts  (parse-options))
 145            (arg   (or (assq-ref opts 'argument)
 146                       (leave (G_ "no download URI was specified~%"))))
 147            (uri   (or (string->uri arg)
 148                       (false-if-exception
 149                        (string->uri
 150                         (string-append "file://" (canonicalize-path arg))))
 151                       (leave (G_ "~a: failed to parse URI~%")
 152                              arg)))
 153            (fetch (assq-ref opts 'download-proc))
 154            (path  (parameterize ((current-terminal-columns
 155                                   (terminal-columns)))
 156                     (fetch (uri->string uri)
 157                            #:verify-certificate?
 158                            (assq-ref opts 'verify-certificate?))))
 159            (hash  (call-with-input-file
 160                       (or path
 161                           (leave (G_ "~a: download failed~%")
 162                                  arg))
 163                     port-sha256))
 164            (fmt   (assq-ref opts 'format)))
 165       (format #t "~a~%~a~%" path (fmt hash))
 166       #t)))