web: Factorize `http-get' hackery.

This should fix `substitute-binary --query' on Guile 2.0.5.

* guix/web.scm: New file.
* Makefile.am (MODULES): Add it.
* po/POTFILES.in: Add it.
* guix/gnu-maintenance.scm (http-fetch): Remove.
  (%package-list-url): Turn into a URI.
  (official-gnu-packages): Add #:text? #t to `http-fetch' call.
* guix/scripts/substitute-binary.scm (fetch): Remove `http' case, and
  use `http-fetch' instead.

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					\

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->uri
    (string-append "http://cvs.savannah.gnu.org/"
                   "viewvc/*checkout*/gnumaint/"
-                 "gnupackages.txt?root=womb"))
+                  "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)

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 (guix web)
-  #:use-module (web response)
   #: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)
+     (http-fetch uri #:text? #f))))
-                    ;; 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))))))))
 
 (define-record-type <cache>
   (%make-cache url store-directory wants-mass-query?)

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

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