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).master
Ludovic Courtès
parent
56dbcb09d8
commit
1424a96e25
110
guix/web.scm
110
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)))
|
||||
|
|
|
|||
Reference in New Issue