diff options
Diffstat (limited to 'guix-download.in')
| -rw-r--r-- | guix-download.in | 184 |
1 files changed, 184 insertions, 0 deletions
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)) |