diff options
author | Ludovic Courtès <ludo@gnu.org> | 2012-10-24 23:10:09 +0200 |
---|---|---|
committer | Ludovic Courtès <ludo@gnu.org> | 2012-10-25 00:58:37 +0200 |
commit | c52a5bf09a5eea8fa4f75f979f5349b743c73d25 (patch) | |
tree | 49bb4dee719a9fddd2cfcbada704eb9b09bbde82 | |
parent | 82058eff591866085633679ecfc108020dd99820 (diff) | |
download | gnu-guix-c52a5bf09a5eea8fa4f75f979f5349b743c73d25.tar gnu-guix-c52a5bf09a5eea8fa4f75f979f5349b743c73d25.tar.gz |
Add `guix-download'.
* guix-download.in: New file.
* configure.ac: Emit `guix-download' and make it executable.
* Makefile.am (bin_SCRIPTS): Add `guix-download'.
* po/POTFILES.in: Add `guix-download.in'.
-rw-r--r-- | .gitignore | 1 | ||||
-rw-r--r-- | Makefile.am | 4 | ||||
-rw-r--r-- | configure.ac | 4 | ||||
-rw-r--r-- | guix-download.in | 184 | ||||
-rw-r--r-- | po/POTFILES.in | 1 |
5 files changed, 192 insertions, 2 deletions
diff --git a/.gitignore b/.gitignore index d4c24c209e..0298a697f4 100644 --- a/.gitignore +++ b/.gitignore @@ -45,3 +45,4 @@ config.cache /doc/stamp-vti /doc/version.texi /distro/packages/bootstrap/x86_64-linux/guile-bootstrap-2.0.6.tar.xz +/guix-download diff --git a/Makefile.am b/Makefile.am index 277ac4277e..e2c1cfd218 100644 --- a/Makefile.am +++ b/Makefile.am @@ -16,7 +16,9 @@ # You should have received a copy of the GNU General Public License # along with Guix. If not, see <http://www.gnu.org/licenses/>. -bin_SCRIPTS = guix-build +bin_SCRIPTS = \ + guix-build \ + guix-download MODULES = \ guix/utils.scm \ diff --git a/configure.ac b/configure.ac index b718330178..a95d2b80be 100644 --- a/configure.ac +++ b/configure.ac @@ -81,8 +81,10 @@ AC_SUBST([LIBGCRYPT]) AC_CONFIG_FILES([Makefile po/Makefile.in guix-build + guix-download pre-inst-env]) -AC_CONFIG_COMMANDS([commands-exec], [chmod +x guix-build pre-inst-env]) +AC_CONFIG_COMMANDS([commands-exec], + [chmod +x guix-build guix-download pre-inst-env]) AC_OUTPUT diff --git a/guix-download.in b/guix-download.in new file mode 100644 index 0000000000..6ebb5148f8 --- /dev/null +++ b/guix-download.in @@ -0,0 +1,184 @@ +#!/bin/sh +# aside from this initial boilerplate, this is actually -*- scheme -*- code + +GUILE_LOAD_COMPILED_PATH="@guilemoduledir@:$GUILE_LOAD_COMPILED_PATH" +export GUILE_LOAD_COMPILED_PATH + +main='(module-ref (resolve-interface '\''(guix-download)) '\'guix-download')' +exec ${GUILE-@GUILE@} -L "@guilemoduledir@" -l "$0" \ + -c "(apply $main (cdr (command-line)))" "$@" +!# +;;; Guix --- Nix package management from Guile. +;;; Copyright (C) 2012 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of Guix. +;;; +;;; Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix-download) + #:use-module (web uri) + #:use-module (web client) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix ftp-client) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-37) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports) + #:export (guix-download)) + +(define _ (cut gettext <> "guix")) +(define N_ (cut ngettext <> <> <> "guix")) + +(define (call-with-temporary-output-file proc) + (let* ((template (string-copy "guix-download.XXXXXX")) + (out (mkstemp! template))) + (dynamic-wind + (lambda () + #t) + (lambda () + (proc template out)) + (lambda () + (false-if-exception (delete-file template)))))) + +(define (http-fetch url port) + "Fetch from URL over HTTP and write the result to PORT." + (let-values (((response data) (http-get url #:decode-body? #f))) + (put-bytevector port data))) + +(define (ftp-fetch url port) + "Fetch from URL over FTP and write the result to PORT." + (let* ((conn (ftp-open (uri-host url) + (or (uri-port url) 21))) + (dir (dirname (uri-path url))) + (file (basename (uri-path url))) + (in (ftp-retr conn file dir))) + (define len 65536) + (define buffer + (make-bytevector len)) + + (let loop ((count (get-bytevector-n! in buffer 0 len))) + (if (eof-object? count) + (ftp-close conn) + (begin + (put-bytevector port buffer 0 count) + (loop (get-bytevector-n! in buffer 0 len))))))) + + +;;; +;;; Command-line options. +;;; + +(define %default-options + ;; Alist of default option values. + `((format . ,bytevector->nix-base32-string))) + +(define-syntax-rule (leave fmt args ...) + "Format FMT and ARGS to the error port and exit." + (begin + (format (current-error-port) fmt args ...) + (exit 1))) + +(define (show-version) + (display "guix-download (@PACKAGE_NAME@) @PACKAGE_VERSION@\n")) + +(define (show-help) + (display (_ "Usage: guix-download [OPTION]... URL +Download the file at URL, add it to the store, and print its store path +and the hash of its contents.\n")) + (format #t (_ " + -f, --format=FMT write the hash in the given format (default: `nix-base32')")) + (newline) + (display (_ " + -h, --help display this help and exit")) + (display (_ " + -V, --version display version information and exit")) + (newline) + (format #t (_ " +Report bugs to: ~a.~%") "@PACKAGE_BUGREPORT@")) + +(define %options + ;; Specifications of the command-line options. + (list (option '(#\f "format") #t #f + (lambda (opt name arg result) + (define fmt-proc + (match arg + ("nix-base32" + bytevector->nix-base32-string) + ("base32" + bytevector->base32-string) + ((or "base16" "hex" "hexadecimal") + bytevector->base16-string) + (x + (format (current-error-port) + "unsupported hash format: ~a~%" arg)))) + + (alist-cons 'format fmt-proc + (alist-delete 'format result)))) + + (option '(#\h "help") #f #f + (lambda args + (show-help) + (exit 0))) + (option '(#\V "version") #f #f + (lambda args + (show-version) + (exit 0))))) + + +;;; +;;; Entry point. +;;; + +(define (guix-download . args) + (define (parse-options) + ;; Return the alist of option values. + (args-fold args %options + (lambda (opt name arg result) + (leave (_ "~A: unrecognized option~%") name)) + (lambda (arg result) + (alist-cons 'argument arg result)) + %default-options)) + + (setlocale LC_ALL "") + (textdomain "guix") + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let* ((opts (parse-options)) + (store (open-connection)) + (uri (string->uri (assq-ref opts 'argument))) + (fetch (case (uri-scheme uri) + ((http) http-fetch) + ((ftp) ftp-fetch) + (else + (begin + (format (current-error-port) + (_ "guix-download: ~a: unsupported URI scheme~%") + (uri-scheme uri)) + (exit 1))))) + (path (call-with-temporary-output-file + (lambda (name port) + (fetch uri port) + (close port) + (add-to-store store (basename (uri-path uri)) + #f #f "sha256" name)))) + (fmt (assq-ref opts 'format))) + (format #t "~a~%~a~%" + path + (fmt (query-path-hash store path))) + #t)) diff --git a/po/POTFILES.in b/po/POTFILES.in index 605711e2da..b0dc7ac4c4 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -5,3 +5,4 @@ distro/packages/databases.scm distro/packages/guile.scm distro/packages/typesetting.scm guix-build.in +guix-download.in |