| 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 | ;;; GNU Guix --- Functional package management for GNU |
| 15 | ;;; Copyright © 2012, 2013 Ludovic Courtès <[email protected]> |
| 16 | ;;; |
| 17 | ;;; This file is part of GNU Guix. |
| 18 | ;;; |
| 19 | ;;; GNU 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 | ;;; GNU 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 GNU 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 | |
| 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 | (show-bug-report-information)) |
| 94 | |
| 95 | (define %options |
| 96 | ;; Specifications of the command-line options. |
| 97 | (list (option '(#\f "format") #t #f |
| 98 | (lambda (opt name arg result) |
| 99 | (define fmt-proc |
| 100 | (match arg |
| 101 | ("nix-base32" |
| 102 | bytevector->nix-base32-string) |
| 103 | ("base32" |
| 104 | bytevector->base32-string) |
| 105 | ((or "base16" "hex" "hexadecimal") |
| 106 | bytevector->base16-string) |
| 107 | (x |
| 108 | (format (current-error-port) |
| 109 | "unsupported hash format: ~a~%" arg)))) |
| 110 | |
| 111 | (alist-cons 'format fmt-proc |
| 112 | (alist-delete 'format result)))) |
| 113 | |
| 114 | (option '(#\h "help") #f #f |
| 115 | (lambda args |
| 116 | (show-help) |
| 117 | (exit 0))) |
| 118 | (option '(#\V "version") #f #f |
| 119 | (lambda args |
| 120 | (show-version-and-exit "guix-download"))))) |
| 121 | |
| 122 | |
| 123 | ;;; |
| 124 | ;;; Entry point. |
| 125 | ;;; |
| 126 | |
| 127 | (define (guix-download . args) |
| 128 | (define (parse-options) |
| 129 | ;; Return the alist of option values. |
| 130 | (args-fold args %options |
| 131 | (lambda (opt name arg result) |
| 132 | (leave (_ "~A: unrecognized option~%") name)) |
| 133 | (lambda (arg result) |
| 134 | (alist-cons 'argument arg result)) |
| 135 | %default-options)) |
| 136 | |
| 137 | (setlocale LC_ALL "") |
| 138 | (textdomain "guix") |
| 139 | (setvbuf (current-output-port) _IOLBF) |
| 140 | (setvbuf (current-error-port) _IOLBF) |
| 141 | |
| 142 | (let* ((opts (parse-options)) |
| 143 | (store (open-connection)) |
| 144 | (arg (assq-ref opts 'argument)) |
| 145 | (uri (or (string->uri arg) |
| 146 | (leave (_ "guix-download: ~a: failed to parse URI~%") |
| 147 | arg))) |
| 148 | (path (case (uri-scheme uri) |
| 149 | ((file) |
| 150 | (add-to-store store (basename (uri-path uri)) |
| 151 | #t #f "sha256" (uri-path uri))) |
| 152 | (else |
| 153 | (fetch-and-store store |
| 154 | (cut url-fetch arg <> |
| 155 | #:mirrors %mirrors) |
| 156 | (basename (uri-path uri)))))) |
| 157 | (hash (call-with-input-file |
| 158 | (or path |
| 159 | (leave (_ "guix-download: ~a: download failed~%") |
| 160 | arg)) |
| 161 | (compose sha256 get-bytevector-all))) |
| 162 | (fmt (assq-ref opts 'format))) |
| 163 | (format #t "~a~%~a~%" path (fmt hash)) |
| 164 | #t)) |