guix/scripts/download.scm

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