summaryrefslogtreecommitdiff
path: root/guix/web.scm
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2013-04-27 11:37:31 +0200
committerLudovic Courtès <ludo@gnu.org>2013-04-27 11:37:31 +0200
commit1424a96e2592041bb995889c8214497b65b41511 (patch)
treebf08f2a7aaef5adef3c1fdecff991b332838149a /guix/web.scm
parent56dbcb09d8979964cae35f24933def115f360e94 (diff)
web: Backport chunked encoding support for Guile <= 2.0.5.
* guix/web.scm (when-guile<=2.0.5): New macro. (read-chunk-header, read-chunk, read-chunk-body, make-chunked-input-port, read-response-body*)[when-guile<=2.0.5]: New procedures. (http-fetch): Clarify message when (not data).
Diffstat (limited to 'guix/web.scm')
-rw-r--r--guix/web.scm110
1 files changed, 105 insertions, 5 deletions
diff --git a/guix/web.scm b/guix/web.scm
index 9d0ee40624..3348d42b47 100644
--- a/guix/web.scm
+++ b/guix/web.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012 Free Software Foundation, Inc.
;;;
;;; This file is part of GNU Guix.
;;;
@@ -17,6 +18,7 @@
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix web)
+ #:use-module (guix utils)
#:use-module (web uri)
#:use-module (web client)
#:use-module (web response)
@@ -33,6 +35,105 @@
;;;
;;; Code:
+(define-syntax when-guile<=2.0.5
+ (lambda (s)
+ (syntax-case s ()
+ ((_ body ...)
+ ;; Always emit BODY, regardless of VERSION, because sometimes this code
+ ;; might be compiled with a recent Guile and run with 2.0.5---e.g.,
+ ;; when using "guix pull".
+ #'(begin body ...)))))
+
+(when-guile<=2.0.5
+ ;; Backport of Guile commit 312e79f8 ("Add HTTP Chunked Encoding support to
+ ;; web modules.").
+
+ (use-modules (ice-9 rdelim))
+
+ ;; Chunked Responses
+ (define (read-chunk-header port)
+ (let* ((str (read-line port))
+ (extension-start (string-index str (lambda (c) (or (char=? c #\;)
+ (char=? c #\return)))))
+ (size (string->number (if extension-start ; unnecessary?
+ (substring str 0 extension-start)
+ str)
+ 16)))
+ size))
+
+ (define (read-chunk port)
+ (let ((size (read-chunk-header port)))
+ (read-chunk-body port size)))
+
+ (define (read-chunk-body port size)
+ (let ((bv (get-bytevector-n port size)))
+ (get-u8 port) ; CR
+ (get-u8 port) ; LF
+ bv))
+
+ (define* (make-chunked-input-port port #:key (keep-alive? #f))
+ "Returns a new port which translates HTTP chunked transfer encoded
+data from PORT into a non-encoded format. Returns eof when it has
+read the final chunk from PORT. This does not necessarily mean
+that there is no more data on PORT. When the returned port is
+closed it will also close PORT, unless the KEEP-ALIVE? is true."
+ (define (next-chunk)
+ (read-chunk port))
+ (define finished? #f)
+ (define (close)
+ (unless keep-alive?
+ (close-port port)))
+ (define buffer #vu8())
+ (define buffer-size 0)
+ (define buffer-pointer 0)
+ (define (read! bv idx to-read)
+ (define (loop to-read num-read)
+ (cond ((or finished? (zero? to-read))
+ num-read)
+ ((<= to-read (- buffer-size buffer-pointer))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ to-read)
+ (set! buffer-pointer (+ buffer-pointer to-read))
+ (loop 0 (+ num-read to-read)))
+ (else
+ (let ((n (- buffer-size buffer-pointer)))
+ (bytevector-copy! buffer buffer-pointer
+ bv (+ idx num-read)
+ n)
+ (set! buffer (next-chunk))
+ (set! buffer-pointer 0)
+ (set! buffer-size (bytevector-length buffer))
+ (set! finished? (= buffer-size 0))
+ (loop (- to-read n)
+ (+ num-read n))))))
+ (loop to-read 0))
+ (make-custom-binary-input-port "chunked input port" read! #f #f close))
+
+ (define (read-response-body* r)
+ "Reads the response body from @var{r}, as a bytevector. Returns
+ @code{#f} if there was no response body."
+ (define bad-response
+ (@@ (web response) bad-response))
+
+ (if (member '(chunked) (response-transfer-encoding r))
+ (let ((chunk-port (make-chunked-input-port (response-port r)
+ #:keep-alive? #t)))
+ (get-bytevector-all chunk-port))
+ (let ((nbytes (response-content-length r)))
+ (and nbytes
+ (let ((bv (get-bytevector-n (response-port r) nbytes)))
+ (if (= (bytevector-length bv) nbytes)
+ bv
+ (bad-response "EOF while reading response body: ~a bytes of ~a"
+ (bytevector-length bv) nbytes)))))))
+
+ ;; Install this patch only on Guile 2.0.5.
+ (when (version>? "2.0.6" (version))
+ (module-set! (resolve-module '(web response))
+ 'read-response-body read-response-body*)))
+
+
(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
@@ -54,15 +155,14 @@ textual. Follow any HTTP redirection."
(let ((len (response-content-length resp)))
(cond ((not data)
(begin
- ;; XXX: Guile 2.0.5 and earlier did not support chunked
+ ;; 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~%")
+ ;; Normally the `when-guile<=2.0.5' block above fixes
+ ;; that, but who knows what could happen.
+ (warning (_ "using Guile ~a, which does not support ~s encoding~%")
(version)
- "which does not support HTTP"
(response-transfer-encoding resp))
(leave (_ "download failed; use a newer Guile~%")
uri resp)))