diff options
| -rw-r--r-- | Makefile.am | 1 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 45 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 26 | ||||
| -rw-r--r-- | guix/web.scm | 85 | ||||
| -rw-r--r-- | po/POTFILES.in | 1 |
5 files changed, 95 insertions, 63 deletions
diff --git a/Makefile.am b/Makefile.am index 442e53e7f6..907be9e141 100644 --- a/Makefile.am +++ b/Makefile.am @@ -48,6 +48,7 @@ MODULES = \ guix/build-system/perl.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ + guix/web.scm \ guix/gnupg.scm \ guix/store.scm \ guix/ui.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 36aad7a987..4c7241fc88 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -28,6 +28,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (system foreign) + #:use-module (guix web) #:use-module (guix ftp-client) #:use-module (guix ui) #:use-module (guix utils) @@ -73,45 +74,11 @@ ;;; List of GNU packages. ;;; -(define (http-fetch uri) - "Return an input port containing the textual data at URI, a string." - (let*-values (((resp data) - (let ((uri (string->uri uri))) - ;; Try hard to use the API du jour to get an input port. - (if (version>? "2.0.7" (version)) - (if (defined? 'http-get*) - (http-get* uri) - (http-get uri)) ; old Guile, returns a string - (http-get uri #:streaming? #t)))) ; 2.0.8 or later - ((code) - (response-code resp))) - (case code - ((200) - (cond ((not data) - (begin - ;; XXX: Guile 2.0.5 and earlier did not support chunked transfer - ;; encoding, which is required when fetching %PACKAGE-LIST-URL - ;; (see <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). - ;; Since users may still be using these versions, warn them and - ;; bail out. - (warning (_ "using Guile ~a, ~a ~s encoding~%") - (version) - "which does not support HTTP" - (response-transfer-encoding resp)) - (leave (_ "download failed; use a newer Guile~%") - uri resp))) - ((string? data) ; old `http-get' returns a string - (open-input-string data)) - (else ; input port - data))) - (else - (error "download failed" uri code - (response-reason-phrase resp)))))) - (define %package-list-url - (string-append "http://cvs.savannah.gnu.org/" - "viewvc/*checkout*/gnumaint/" - "gnupackages.txt?root=womb")) + (string->uri + (string-append "http://cvs.savannah.gnu.org/" + "viewvc/*checkout*/gnumaint/" + "gnupackages.txt?root=womb"))) (define-record-type* <gnu-package-descriptor> gnu-package-descriptor @@ -197,7 +164,7 @@ "savannah" "fsd" "language" "logo" "doc-category" "doc-summary" "doc-urls" "download-url"))) - (group-package-fields (http-fetch %package-list-url) + (group-package-fields (http-fetch %package-list-url #:text? #t) '(()))))) (define (find-packages regexp) diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 7e059be596..87561db4b3 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -35,8 +35,7 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (web uri) - #:use-module (web client) - #:use-module (web response) + #:use-module (guix web) #:export (guix-substitute-binary)) ;;; Comment: @@ -128,28 +127,7 @@ provide." (let ((port (open-input-file (uri-path uri)))) (values port (stat:size (stat port))))) ((http) - (let*-values (((resp port) - ;; XXX: `http-get*' was introduced in 2.0.7, and deprecated - ;; in 2.0.8 (!). Assume it is available here. - (if (version>? "2.0.7" (version)) - (http-get* uri #:decode-body? #f) - (http-get uri #:streaming? #t))) - ((code) - (response-code resp)) - ((size) - (response-content-length resp))) - (case code - ((200) ; OK - (values port size)) - ((301 ; moved permanently - 302) ; found (redirection) - (let ((uri (response-location resp))) - (format #t "following redirection to `~a'...~%" - (uri->string uri)) - (fetch uri))) - (else - (error "download failed" (uri->string uri) - code (response-reason-phrase resp)))))))) + (http-fetch uri #:text? #f)))) (define-record-type <cache> (%make-cache url store-directory wants-mass-query?) diff --git a/guix/web.scm b/guix/web.scm new file mode 100644 index 0000000000..9d0ee40624 --- /dev/null +++ b/guix/web.scm @@ -0,0 +1,85 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU 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. +;;; +;;; GNU 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 GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix web) + #:use-module (web uri) + #:use-module (web client) + #:use-module (web response) + #:use-module (srfi srfi-11) + #:use-module (rnrs io ports) + #:use-module (rnrs bytevectors) + #:use-module (guix ui) + #:use-module (guix utils) + #:export (http-fetch)) + +;;; Commentary: +;;; +;;; Web client portable among Guile versions. +;;; +;;; Code: + +(define* (http-fetch uri #:key (text? #f)) + "Return an input port containing the data at URI, and the expected number of +bytes available or #f. If TEXT? is true, the data at URI is considered to be +textual. Follow any HTTP redirection." + (let loop ((uri uri)) + (let*-values (((resp data) + ;; Try hard to use the API du jour to get an input port. + ;; On Guile 2.0.5 and before, we can only get a string or + ;; bytevector, and not an input port. Work around that. + (if (version>? "2.0.7" (version)) + (if (defined? 'http-get*) + (http-get* uri #:decode-body? text?) ; 2.0.7 + (http-get uri #:decode-body? text?)) ; 2.0.5- + (http-get uri #:streaming? #t))) ; 2.0.9+ + ((code) + (response-code resp))) + (case code + ((200) + (let ((len (response-content-length resp))) + (cond ((not data) + (begin + ;; XXX: Guile 2.0.5 and earlier did not support chunked + ;; transfer encoding, which is required for instance when + ;; fetching %PACKAGE-LIST-URL (see + ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>). + ;; Since users may still be using these versions, warn them + ;; and bail out. + (warning (_ "using Guile ~a, ~a ~s encoding~%") + (version) + "which does not support HTTP" + (response-transfer-encoding resp)) + (leave (_ "download failed; use a newer Guile~%") + uri resp))) + ((string? data) ; `http-get' from 2.0.5- + (values (open-input-string data) len)) + ((bytevector? data) ; likewise + (values (open-bytevector-input-port data) len)) + (else ; input port + (values data len))))) + ((301 ; moved permanently + 302) ; found (redirection) + (let ((uri (response-location resp))) + (format #t "following redirection to `~a'...~%" + (uri->string uri)) + (loop uri))) + (else + (error "download failed" uri code + (response-reason-phrase resp))))))) + +;;; web.scm ends here diff --git a/po/POTFILES.in b/po/POTFILES.in index 3b01e2a2a5..6e1ba82951 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -12,3 +12,4 @@ guix/scripts/hash.scm guix/scripts/pull.scm guix/gnu-maintenance.scm guix/ui.scm +guix/web.scm |