From 1424a96e2592041bb995889c8214497b65b41511 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sat, 27 Apr 2013 11:37:31 +0200 Subject: 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). --- guix/web.scm | 110 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 105 insertions(+), 5 deletions(-) (limited to 'guix') 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 +;;; Copyright © 2012 Free Software Foundation, Inc. ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +18,7 @@ ;;; along with GNU Guix. If not, see . (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 ;; ). - ;; 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))) -- cgit v1.2.3