From 3b8258c569635ad89bf6d78081172aa9f5d171dc Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 14 Jul 2013 16:35:37 +0200 Subject: Rename (guix web) to (guix http-client). * guix/web.scm: Rename to... * guix/http-client.scm: ... this. * guix/gnu-maintenance.scm, guix/scripts/substitute-binary.scm, Makefile.am, po/POTFILES.in: Update accordingly. --- Makefile.am | 2 +- guix/gnu-maintenance.scm | 2 +- guix/http-client.scm | 208 +++++++++++++++++++++++++++++++++++++ guix/scripts/substitute-binary.scm | 2 +- guix/web.scm | 208 ------------------------------------- po/POTFILES.in | 2 +- 6 files changed, 212 insertions(+), 212 deletions(-) create mode 100644 guix/http-client.scm delete mode 100644 guix/web.scm diff --git a/Makefile.am b/Makefile.am index 4236de4fce..dd087bf442 100644 --- a/Makefile.am +++ b/Makefile.am @@ -53,7 +53,7 @@ MODULES = \ guix/build-system/python.scm \ guix/build-system/trivial.scm \ guix/ftp-client.scm \ - guix/web.scm \ + guix/http-client.scm \ guix/gnupg.scm \ guix/store.scm \ guix/ui.scm \ diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index 06baa1e97b..8ef7cc7292 100644 --- a/guix/gnu-maintenance.scm +++ b/guix/gnu-maintenance.scm @@ -27,7 +27,7 @@ #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (system foreign) - #:use-module (guix web) + #:use-module (guix http-client) #:use-module (guix ftp-client) #:use-module (guix ui) #:use-module (guix utils) diff --git a/guix/http-client.scm b/guix/http-client.scm new file mode 100644 index 0000000000..898b1669e5 --- /dev/null +++ b/guix/http-client.scm @@ -0,0 +1,208 @@ +;;; 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. +;;; +;;; 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 . + +(define-module (guix http-client) + #:use-module (guix utils) + #: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 (open-socket-for-uri + http-fetch)) + +;;; Commentary: +;;; +;;; HTTP client portable among Guile versions. +;;; +;;; 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))) + ;; Backport of Guile commit 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 + ;; ("fix response-body-port for responses without content-length"). + (if 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))) + (get-bytevector-all (response-port r)))))) + + ;; 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*))) + +;; XXX: Work around , present in Guile +;; up to 2.0.7. +(module-define! (resolve-module '(web client)) + 'shutdown (const #f)) + +(define* (open-socket-for-uri uri #:key (buffered? #t)) + "Return an open port for URI. When BUFFERED? is false, the returned port is +unbuffered." + (let ((s ((@ (web client) open-socket-for-uri) uri))) + (unless buffered? + (setvbuf s _IONBF)) + s)) + +(define* (http-fetch uri #:key port (text? #f) (buffered? #t)) + "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. When BUFFERED? is #f, return an +unbuffered port, suitable for use in `filtered-port'." + (let loop ((uri uri)) + (let ((port (or port + (open-socket-for-uri uri + #:buffered? buffered?)))) + (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>? (version) "2.0.7") + (http-get uri #:streaming? #t #:port port) ; 2.0.9+ + (if (defined? 'http-get*) + (http-get* uri #:decode-body? text? + #:port port) ; 2.0.7 + (http-get uri #:decode-body? text? + #:port port)))) ; 2.0.5- + ((code) + (response-code resp))) + (case code + ((200) + (let ((len (response-content-length resp))) + (cond ((not data) + (begin + ;; Guile 2.0.5 and earlier did not support chunked + ;; transfer encoding, which is required for instance when + ;; fetching %PACKAGE-LIST-URL (see + ;; ). + ;; 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) + (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))) + (close-port port) + (format #t (_ "following redirection to `~a'...~%") + (uri->string uri)) + (loop uri))) + (else + (error "download failed" uri code + (response-reason-phrase resp)))))))) + +;;; http-client.scm ends here diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index fbb5cf8337..7398d59957 100755 --- a/guix/scripts/substitute-binary.scm +++ b/guix/scripts/substitute-binary.scm @@ -39,7 +39,7 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (web uri) - #:use-module (guix web) + #:use-module (guix http-client) #:export (guix-substitute-binary)) ;;; Comment: diff --git a/guix/web.scm b/guix/web.scm deleted file mode 100644 index 321c38391d..0000000000 --- a/guix/web.scm +++ /dev/null @@ -1,208 +0,0 @@ -;;; 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. -;;; -;;; 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 . - -(define-module (guix web) - #:use-module (guix utils) - #: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 (open-socket-for-uri - http-fetch)) - -;;; Commentary: -;;; -;;; Web client portable among Guile versions. -;;; -;;; 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))) - ;; Backport of Guile commit 84dfde82ae8f6ec247c1c147c1e2ae50b207bad9 - ;; ("fix response-body-port for responses without content-length"). - (if 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))) - (get-bytevector-all (response-port r)))))) - - ;; 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*))) - -;; XXX: Work around , present in Guile -;; up to 2.0.7. -(module-define! (resolve-module '(web client)) - 'shutdown (const #f)) - -(define* (open-socket-for-uri uri #:key (buffered? #t)) - "Return an open port for URI. When BUFFERED? is false, the returned port is -unbuffered." - (let ((s ((@ (web client) open-socket-for-uri) uri))) - (unless buffered? - (setvbuf s _IONBF)) - s)) - -(define* (http-fetch uri #:key port (text? #f) (buffered? #t)) - "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. When BUFFERED? is #f, return an -unbuffered port, suitable for use in `filtered-port'." - (let loop ((uri uri)) - (let ((port (or port - (open-socket-for-uri uri - #:buffered? buffered?)))) - (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>? (version) "2.0.7") - (http-get uri #:streaming? #t #:port port) ; 2.0.9+ - (if (defined? 'http-get*) - (http-get* uri #:decode-body? text? - #:port port) ; 2.0.7 - (http-get uri #:decode-body? text? - #:port port)))) ; 2.0.5- - ((code) - (response-code resp))) - (case code - ((200) - (let ((len (response-content-length resp))) - (cond ((not data) - (begin - ;; Guile 2.0.5 and earlier did not support chunked - ;; transfer encoding, which is required for instance when - ;; fetching %PACKAGE-LIST-URL (see - ;; ). - ;; 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) - (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))) - (close-port port) - (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 diff --git a/po/POTFILES.in b/po/POTFILES.in index 839b069704..0e30bb0880 100644 --- a/po/POTFILES.in +++ b/po/POTFILES.in @@ -13,4 +13,4 @@ guix/scripts/pull.scm guix/scripts/substitute-binary.scm guix/gnu-maintenance.scm guix/ui.scm -guix/web.scm +guix/http-client.scm -- cgit 1.4.1