diff options
Diffstat (limited to 'guix/http-client.scm')
| -rw-r--r-- | guix/http-client.scm | 154 |
1 files changed, 1 insertions, 153 deletions
diff --git a/guix/http-client.scm b/guix/http-client.scm index bab31875d1..e8a2a23fc5 100644 --- a/guix/http-client.scm +++ b/guix/http-client.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> @@ -69,158 +69,6 @@ (reason http-get-error-reason)) ; string -(define-syntax when-guile<=2.0.5-or-otherwise-broken - (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-or-otherwise-broken - ;; Backport of Guile commits 312e79f8 ("Add HTTP Chunked Encoding support to - ;; web modules."), 00d3ecf2 ("http: Do not buffer HTTP chunks."), and 53b8d5f - ;; ("web: Gracefully handle premature EOF when reading chunk header.") - - (use-modules (ice-9 rdelim)) - - (define %web-http - (resolve-module '(web http))) - - ;; Chunked Responses - (define (read-chunk-header port) - "Read a chunk header from PORT and return the size in bytes of the - upcoming chunk." - (match (read-line port) - ((? eof-object?) - ;; Connection closed prematurely: there's nothing left to read. - 0) - (str - (let ((extension-start (string-index str - (lambda (c) - (or (char=? c #\;) - (char=? c #\return)))))) - (string->number (if extension-start ; unnecessary? - (substring str 0 extension-start) - str) - 16))))) - - (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 (close) - (unless keep-alive? - (close-port port))) - - (define chunk-size 0) ;size of the current chunk - (define remaining 0) ;number of bytes left from the current chunk - (define finished? #f) ;did we get all the chunks? - - (define (read! bv idx to-read) - (define (loop to-read num-read) - (cond ((or finished? (zero? to-read)) - num-read) - ((zero? remaining) ;get a new chunk - (let ((size (read-chunk-header port))) - (set! chunk-size size) - (set! remaining size) - (if (zero? size) - (begin - (set! finished? #t) - num-read) - (loop to-read num-read)))) - (else ;read from the current chunk - (let* ((ask-for (min to-read remaining)) - (read (get-bytevector-n! port bv (+ idx num-read) - ask-for))) - (if (eof-object? read) - (begin ;premature termination - (set! finished? #t) - num-read) - (let ((left (- remaining read))) - (set! remaining left) - (when (zero? left) - ;; We're done with this chunk; read CR and LF. - (get-u8 port) (get-u8 port)) - (loop (- to-read read) - (+ num-read read)))))))) - (loop to-read 0)) - - (make-custom-binary-input-port "chunked input port" read! #f #f close)) - - ;; Chunked encoding support in Guile <= 2.0.11 would load whole chunks in - ;; memory---see <http://bugs.gnu.org/19939>. - (when (module-variable %web-http 'read-chunk-body) - (module-set! %web-http 'make-chunked-input-port make-chunked-input-port)) - - (define (make-delimited-input-port port len keep-alive?) - "Return an input port that reads from PORT, and makes sure that -exactly LEN bytes are available from PORT. Closing the returned port -closes PORT, unless KEEP-ALIVE? is true." - (define bytes-read 0) - - (define (fail) - ((@@ (web response) bad-response) - "EOF while reading response body: ~a bytes of ~a" - bytes-read len)) - - (define (read! bv start count) - ;; Read at most LEN bytes in total. HTTP/1.1 doesn't say what to do - ;; when a server provides more than the Content-Length, but it seems - ;; wise to just stop reading at LEN. - (let ((count (min count (- len bytes-read)))) - (let loop ((ret (get-bytevector-n! port bv start count))) - (cond ((eof-object? ret) - (if (= bytes-read len) - 0 ; EOF - (fail))) - ((and (zero? ret) (> count 0)) - ;; Do not return zero since zero means EOF, so try again. - (loop (get-bytevector-n! port bv start count))) - (else - (set! bytes-read (+ bytes-read ret)) - ret))))) - - (define close - (and (not keep-alive?) - (lambda () - (close-port port)))) - - (make-custom-binary-input-port "delimited input port" read! #f #f close)) - - (define (read-header-line port) - "Read an HTTP header line and return it without its final CRLF or LF. -Raise a 'bad-header' exception if the line does not end in CRLF or LF, -or if EOF is reached." - (match (%read-line port) - (((? string? line) . #\newline) - ;; '%read-line' does not consider #\return a delimiter; so if it's - ;; there, remove it. We are more tolerant than the RFC in that we - ;; tolerate LF-only endings. - (if (string-suffix? "\r" line) - (string-drop-right line 1) - line)) - ((line . _) ;EOF or missing delimiter - ((@@ (web http) bad-header) 'read-header-line line)))) - - (unless (guile-version>? "2.0.11") - ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more - ;; than what 'content-length' says. See Guile commit 802a25b. - ;; Guile <= 2.0.11 had a bug whereby the 'close' method of the response - ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41. - (module-set! (resolve-module '(web response)) - 'make-delimited-input-port make-delimited-input-port) - - ;; Guile <= 2.0.11 was affected by <http://bugs.gnu.org/22273>. See Guile - ;; commit 4c7732c. - (when (module-variable %web-http 'read-line*) - (module-set! %web-http 'read-line* read-header-line)))) - - (define* (http-fetch uri #:key port (text? #f) (buffered? #t) keep-alive? (verify-certificate? #t) (headers '((user-agent . "GNU Guile")))) |