diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | distro/packages/bootstrap.scm | 3 | ||||
| -rw-r--r-- | guix/build/download.scm | 157 | ||||
| -rw-r--r-- | guix/download.scm | 73 | ||||
| -rw-r--r-- | guix/snix.scm | 2 | ||||
| -rw-r--r-- | tests/builders.scm | 12 |
6 files changed, 248 insertions, 1 deletions
diff --git a/Makefile.am b/Makefile.am index b29bf6584b..c4e03a2d6a 100644 --- a/Makefile.am +++ b/Makefile.am @@ -26,6 +26,7 @@ MODULES = \ guix/base32.scm \ guix/utils.scm \ guix/derivations.scm \ + guix/download.scm \ guix/build-system.scm \ guix/build-system/gnu.scm \ guix/build-system/trivial.scm \ @@ -34,6 +35,7 @@ MODULES = \ guix/http.scm \ guix/store.scm \ guix/ui.scm \ + guix/build/download.scm \ guix/build/gnu-build-system.scm \ guix/build/ftp.scm \ guix/build/http.scm \ diff --git a/distro/packages/bootstrap.scm b/distro/packages/bootstrap.scm index 533ff42987..95a7de444c 100644 --- a/distro/packages/bootstrap.scm +++ b/distro/packages/bootstrap.scm @@ -21,6 +21,7 @@ #:use-module (guix packages) #:use-module (guix ftp) #:use-module (guix http) + #:use-module (guix download) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix build-system trivial) @@ -70,6 +71,8 @@ (boot http-fetch)) ((eq? orig-method ftp-fetch) (boot ftp-fetch)) + ((eq? orig-method url-fetch) + (boot url-fetch)) (else orig-method)))))) (define (package-from-tarball name* source* program-to-test description*) diff --git a/guix/build/download.scm b/guix/build/download.scm new file mode 100644 index 0000000000..f3487ce9a0 --- /dev/null +++ b/guix/build/download.scm @@ -0,0 +1,157 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; 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 build download) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (guix ftp-client) + #:use-module (guix build utils) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-11) + #:use-module (ice-9 match) + #:export (url-fetch)) + +;;; Commentary: +;;; +;;; Fetch data such as tarballs over HTTP or FTP (builder-side code). +;;; +;;; Code: + +(define (ftp-fetch uri file) + "Fetch data from URI and write it to FILE. Return FILE on success." + (let* ((conn (ftp-open (uri-host uri))) + (in (ftp-retr conn (basename (uri-path uri)) + (dirname (uri-path uri))))) + (call-with-output-file file + (lambda (out) + ;; TODO: Show a progress bar. + (dump-port in out))) + + (ftp-close conn)) + file) + +(define (open-connection-for-uri uri) + "Return an open input/output port for a connection to URI. + +This is the same as Guile's `open-socket-for-uri', except that we always +use a numeric port argument, to avoid the need to go through libc's NSS, +which is not available during bootstrap." + (define addresses + (let ((port (or (uri-port uri) + (case (uri-scheme uri) + ((http) 80) ; /etc/services, not for me! + (else + (error "unsupported URI scheme" uri)))))) + (getaddrinfo (uri-host uri) + (number->string port) + AI_NUMERICSERV))) + + (let loop ((addresses addresses)) + (let* ((ai (car addresses)) + (s (with-fluids ((%default-port-encoding #f)) + (socket (addrinfo:fam ai) (addrinfo:socktype ai) + (addrinfo:protocol ai))))) + (catch 'system-error + (lambda () + (connect s (addrinfo:addr ai)) + + ;; Buffer input and output on this port. + (setvbuf s _IOFBF) + ;; Enlarge the receive buffer. + (setsockopt s SOL_SOCKET SO_RCVBUF (* 12 1024)) + s) + (lambda args + ;; Connection failed, so try one of the other addresses. + (close s) + (if (null? addresses) + (apply throw args) + (loop (cdr addresses)))))))) + +;; XXX: This is an awful hack to make sure the (set-port-encoding! p +;; "ISO-8859-1") call in `read-response' passes, even during bootstrap +;; where iconv is not available. +(module-define! (resolve-module '(web response)) + 'set-port-encoding! + (lambda (p e) #f)) + +(define (http-fetch uri file) + "Fetch data from URI and write it to FILE. Return FILE on success." + + ;; FIXME: Use a variant of `http-get' that returns a port instead of + ;; loading everything in memory. + (let*-values (((connection) + (open-connection-for-uri uri)) + ((resp bv) + (http-get uri #:port connection #:decode-body? #f)) + ((code) + (response-code resp))) + (if (= 200 code) + (begin + (call-with-output-file file + (lambda (p) + (put-bytevector p bv))) + file) + (error "download failed" (uri->string uri) + code (response-reason-phrase resp))))) + + +(define-syntax-rule (false-if-exception* body ...) + "Like `false-if-exception', but print the exception on the error port." + (catch #t + (lambda () + body ...) + (lambda (key . args) + #f) + (lambda (key . args) + (print-exception (current-error-port) #f key args)))) + +(define (url-fetch url file) + "Fetch FILE from URL; URL may be either a single string, or a list of +string denoting alternate URLs for FILE. Return #f on failure, and FILE +on success." + (define uri + (match url + ((_ ...) (map string->uri url)) + (_ (list (string->uri url))))) + + (define (fetch uri file) + (format #t "starting download of `~a' from `~a'...~%" + file (uri->string uri)) + (case (uri-scheme uri) + ((http) (false-if-exception* (http-fetch uri file))) + ((ftp) (false-if-exception* (ftp-fetch uri file))) + (else + (format #t "skipping URI with unsupported scheme: ~s~%" + uri) + #f))) + + (setvbuf (current-output-port) _IOLBF) + (setvbuf (current-error-port) _IOLBF) + + (let try ((uri uri)) + (match uri + ((uri tail ...) + (or (fetch uri file) + (try tail))) + (() + (format (current-error-port) "failed to download ~s from ~s~%" + file url) + #f)))) + +;;; download.scm ends here diff --git a/guix/download.scm b/guix/download.scm new file mode 100644 index 0000000000..b5e8c675ac --- /dev/null +++ b/guix/download.scm @@ -0,0 +1,73 @@ +;;; Guix --- Nix package management from Guile. -*- coding: utf-8 -*- +;;; 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 (ice-9 match) + #:use-module (guix derivations) + #:use-module (guix packages) + #:use-module ((guix store) #:select (derivation-path?)) + #:use-module (guix utils) + #:export (url-fetch)) + +;;; Commentary: +;;; +;;; Produce fixed-output derivations with data fetched over HTTP or FTP. +;;; +;;; Code: + +(define* (url-fetch store url hash-algo hash + #:optional name + #:key (system (%current-system)) guile) + "Return the path of a fixed-output derivation in STORE that fetches +URL (a string, or a list of strings denoting alternate URLs), which is +expected to have hash HASH of type HASH-ALGO (a symbol). By default, +the file name is the base name of URL; optionally, NAME can specify a +different file name." + (define builder + `(begin + (use-modules (guix build download)) + (url-fetch ',url %output))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system)) + ((and (? string?) (? derivation-path?)) + guile) + (#f ; the default + (let* ((distro (resolve-interface '(distro packages base))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system))))) + + (define file-name + (match url + ((head _ ...) + (basename head)) + (_ + (basename url)))) + + (build-expression->derivation store (or name file-name) system + builder '() + #:hash-algo hash-algo + #:hash hash + #:modules '((guix build download) + (guix build utils) + (guix ftp-client)) + #:guile-for-build guile-for-build)) + +;;; download.scm ends here diff --git a/guix/snix.scm b/guix/snix.scm index c6a9bee6a7..a5b8447470 100644 --- a/guix/snix.scm +++ b/guix/snix.scm @@ -400,7 +400,7 @@ location of DERIVATION." (name ,name) (version ,version) (source (origin - (method http-fetch) + (method url-fetch) (uri ,(pretty-uri (car urls) version)) (sha256 (base32 diff --git a/tests/builders.scm b/tests/builders.scm index d9dc5afa20..9cc86ef1c2 100644 --- a/tests/builders.scm +++ b/tests/builders.scm @@ -19,6 +19,7 @@ (define-module (test-builders) #:use-module (guix http) + #:use-module (guix download) #:use-module (guix build-system) #:use-module (guix build-system gnu) #:use-module (guix store) @@ -63,6 +64,17 @@ (file-exists? out-path) (valid-path? %store out-path)))) +(test-assert "url-fetch" + (let* ((url '("http://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz" + "ftp://ftp.gnu.org/gnu/hello/hello-2.8.tar.gz")) + (hash (nix-base32-string->bytevector + "0wqd8sjmxfskrflaxywc7gqw7sfawrfvdxd9skxawzfgyy0pzdz6")) + (drv-path (url-fetch %store url 'sha256 hash)) + (out-path (derivation-path->output-path drv-path))) + (and (build-derivations %store (list drv-path)) + (file-exists? out-path) + (valid-path? %store out-path)))) + (test-assert "gnu-build-system" (and (build-system? gnu-build-system) (eq? gnu-build (build-system-builder gnu-build-system)))) |