guix-download.in

   1 #!/bin/sh
   2 # aside from this initial boilerplate, this is actually -*- scheme -*- code
   3
   4 prefix="@prefix@"
   5 datarootdir="@datarootdir@"
   6
   7 GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH"
   8 export GUILE_LOAD_COMPILED_PATH
   9
  10 main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')'
  11 exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0"    \
  12          -c "(apply $main (cdr (command-line)))" "$@"
  13 !#
  14 ;;; Guix --- Nix package management from Guile.
  15 ;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org>
  16 ;;;
  17 ;;; This file is part of Guix.
  18 ;;;
  19 ;;; Guix is free software; you can redistribute it and/or modify it
  20 ;;; under the terms of the GNU General Public License as published by
  21 ;;; the Free Software Foundation; either version 3 of the License, or (at
  22 ;;; your option) any later version.
  23 ;;;
  24 ;;; Guix is distributed in the hope that it will be useful, but
  25 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  26 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  27 ;;; GNU General Public License for more details.
  28 ;;;
  29 ;;; You should have received a copy of the GNU General Public License
  30 ;;; along with Guix.  If not, see <http://www.gnu.org/licenses/>.
  31
  32 (define-module (guix-download)
  33   #:use-module (guix ui)
  34   #:use-module (guix store)
  35   #:use-module (guix utils)
  36   #:use-module (guix base32)
  37   #:use-module ((guix download) #:select (%mirrors))
  38   #:use-module (guix build download)
  39   #:use-module (web uri)
  40   #:use-module (ice-9 match)
  41   #:use-module (srfi srfi-1)
  42   #:use-module (srfi srfi-11)
  43   #:use-module (srfi srfi-26)
  44   #:use-module (srfi srfi-37)
  45   #:use-module (rnrs bytevectors)
  46   #:use-module (rnrs io ports)
  47   #:export (guix-download))
  48
  49 (define (call-with-temporary-output-file proc)
  50   (let* ((template (string-copy "guix-download.XXXXXX"))
  51          (out      (mkstemp! template)))
  52     (dynamic-wind
  53       (lambda ()
  54         #t)
  55       (lambda ()
  56         (proc template out))
  57       (lambda ()
  58         (false-if-exception (delete-file template))))))
  59
  60 (define (fetch-and-store store fetch name)
  61   "Call FETCH for URI, and pass it the name of a file to write to; eventually,
  62 copy data from that port to STORE, under NAME.  Return the resulting
  63 store path."
  64   (call-with-temporary-output-file
  65    (lambda (temp port)
  66      (let ((result
  67             (parameterize ((current-output-port (current-error-port)))
  68               (fetch temp))))
  69        (close port)
  70        (and result
  71             (add-to-store store name #t #f "sha256" temp))))))
  72 \f
  73 ;;;
  74 ;;; Command-line options.
  75 ;;;
  76
  77 (define %default-options
  78   ;; Alist of default option values.
  79   `((format . ,bytevector->nix-base32-string)))
  80
  81 (define (show-help)
  82   (display (_ "Usage: guix-download [OPTION]... URL
  83 Download the file at URL, add it to the store, and print its store path
  84 and the hash of its contents.\n"))
  85   (format #t (_ "
  86   -f, --format=FMT       write the hash in the given format (default: `nix-base32')"))
  87   (newline)
  88   (display (_ "
  89   -h, --help             display this help and exit"))
  90   (display (_ "
  91   -V, --version          display version information and exit"))
  92   (newline)
  93   (format #t (_ "
  94 Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@"))
  95
  96 (define %options
  97   ;; Specifications of the command-line options.
  98   (list (option '(#\f "format") #t #f
  99                 (lambda (opt name arg result)
 100                   (define fmt-proc
 101                     (match arg
 102                       ("nix-base32"
 103                        bytevector->nix-base32-string)
 104                       ("base32"
 105                        bytevector->base32-string)
 106                       ((or "base16" "hex" "hexadecimal")
 107                        bytevector->base16-string)
 108                       (x
 109                        (format (current-error-port)
 110                                "unsupported hash format: ~a~%" arg))))
 111
 112                   (alist-cons 'format fmt-proc
 113                               (alist-delete 'format 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 (_ "~A: unrecognized option~%") name))
 134                (lambda (arg result)
 135                  (alist-cons 'argument arg result))
 136                %default-options))
 137
 138   (setlocale LC_ALL "")
 139   (textdomain "guix")
 140   (setvbuf (current-output-port) _IOLBF)
 141   (setvbuf (current-error-port) _IOLBF)
 142
 143   (let* ((opts  (parse-options))
 144          (store (open-connection))
 145          (arg   (assq-ref opts 'argument))
 146          (uri   (or (string->uri arg)
 147                     (leave (_ "guix-download: ~a: failed to parse URI~%")
 148                            arg)))
 149          (path  (case (uri-scheme uri)
 150                   ((file)
 151                    (add-to-store store (basename (uri-path uri))
 152                                  #t #f "sha256" (uri-path uri)))
 153                   (else
 154                    (fetch-and-store store
 155                                     (cut url-fetch arg <>
 156                                          #:mirrors %mirrors)
 157                                     (basename (uri-path uri))))))
 158          (hash  (call-with-input-file
 159                     (or path
 160                         (leave (_ "guix-download: ~a: download failed~%")
 161                                arg))
 162                   (compose sha256 get-bytevector-all)))
 163          (fmt   (assq-ref opts 'format)))
 164     (format #t "~a~%~a~%" path (fmt hash))
 165     #t))