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