-;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
-;;; 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 <http://www.gnu.org/licenses/>.
-
-(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 (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:use-module (rnrs io ports)
- #:use-module (rnrs bytevectors)
- #:use-module (guix ui)
- #:use-module (guix utils)
- #:export (&http-get-error
- http-get-error?
- http-get-error-uri
- http-get-error-code
- http-get-error-reason
-
- open-socket-for-uri
- http-fetch))
-
-;;; Commentary:
-;;;
-;;; HTTP client portable among Guile versions, and with proper error condition
-;;; reporting.
-;;;
-;;; Code:
-
-;; HTTP GET error.
-(define-condition-type &http-get-error &error
- http-get-error?
- (uri http-get-error-uri) ; URI
- (code http-get-error-code) ; integer
- (reason http-get-error-reason)) ; string
-
-
-(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.
- (unless (guile-version>? "2.0.5")
- (module-set! (resolve-module '(web response))
- 'read-response-body read-response-body*)))
-
-;; XXX: Work around <http://bugs.gnu.org/13095>, 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."
- (define rmem-max
- ;; The maximum size for a receive buffer on Linux, see socket(7).
- "/proc/sys/net/core/rmem_max")
-
- (define buffer-size
- (if (file-exists? rmem-max)
- (call-with-input-file rmem-max read)
- 126976)) ; the default for Linux, per 'rmem_default'
-
- (let ((s ((@ (web client) open-socket-for-uri) uri)))
- ;; Work around <http://bugs.gnu.org/15368> by restoring a decent
- ;; buffer size.
- (setsockopt s SOL_SOCKET SO_RCVBUF buffer-size)
- (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'.
-
-Raise an '&http-get-error' condition if downloading fails."
- (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 (guile-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
- ;; <http://lists.gnu.org/archive/html/guile-devel/2011-09/msg00089.html>).
- ;; 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
- (raise (condition (&http-get-error
- (uri uri)
- (code code)
- (reason (response-reason-phrase resp)))
- (&message
- (message "download failed"))))))))))
-
-;;; http-client.scm ends here
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 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>
+;;;
+;;; 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 <http://www.gnu.org/licenses/>.
+
+(define-module (guix http-client)
+ #:use-module (web uri)
+ #:use-module (web http)
+ #:use-module ((web client) #:hide (open-socket-for-uri))
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
+ #:use-module (srfi srfi-19)
+ #:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
+ #:use-module (srfi srfi-35)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (rnrs bytevectors)
+ #:use-module (guix ui)
+ #:use-module (guix utils)
+ #:use-module (guix base64)
+ #:autoload (gcrypt hash) (sha256)
+ #:autoload (gnutls) (error/invalid-session)
+ #:use-module ((guix build utils)
+ #:select (mkdir-p dump-port))
+ #:use-module ((guix build download)
+ #:select (open-socket-for-uri
+ (open-connection-for-uri
+ . guix:open-connection-for-uri)
+ resolve-uri-reference))
+ #:re-export (open-socket-for-uri)
+ #:export (&http-get-error
+ http-get-error?
+ http-get-error-uri
+ http-get-error-code
+ http-get-error-reason
+
+ http-fetch
+ http-multiple-get
+
+ %http-cache-ttl
+ http-fetch/cached))
+
+;;; Commentary:
+;;;
+;;; HTTP client portable among Guile versions, and with proper error condition
+;;; reporting.
+;;;
+;;; Code:
+
+;; HTTP GET error.
+(define-condition-type &http-get-error &error
+ http-get-error?
+ (uri http-get-error-uri) ; URI
+ (code http-get-error-code) ; integer
+ (reason http-get-error-reason)) ; string
+
+
+(define* (http-fetch uri #:key port (text? #f) (buffered? #t)
+ (open-connection guix:open-connection-for-uri)
+ (keep-alive? #f)
+ (verify-certificate? #t)
+ (headers '((user-agent . "GNU Guile")))
+ (log-port (current-error-port))
+ timeout)
+ "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'. HEADERS is an alist of
+extra HTTP headers.
+
+When KEEP-ALIVE? is true, the connection is marked as 'keep-alive' and PORT is
+not closed upon completion.
+
+When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
+
+TIMEOUT specifies the timeout in seconds for connection establishment; when
+TIMEOUT is #f, connection establishment never times out.
+
+Write information about redirects to LOG-PORT.
+
+Raise an '&http-get-error' condition if downloading fails."
+ (let loop ((uri (if (string? uri)
+ (string->uri uri)
+ uri)))
+ (let ((port (or port (open-connection uri
+ #:verify-certificate?
+ verify-certificate?
+ #:timeout timeout)))
+ (headers (match (uri-userinfo uri)
+ ((? string? str)
+ (cons (cons 'Authorization
+ (string-append "Basic "
+ (base64-encode
+ (string->utf8 str))))
+ headers))
+ (_ headers))))
+ (unless (or buffered? (not (file-port? port)))
+ (setvbuf port 'none))
+ (let*-values (((resp data)
+ (http-get uri #:streaming? #t #:port port
+ #:keep-alive? keep-alive?
+ #:headers headers))
+ ((code)
+ (response-code resp)))
+ (case code
+ ((200)
+ (values data (response-content-length resp)))
+ ((301 ; moved permanently
+ 302 ; found (redirection)
+ 303 ; see other
+ 307 ; temporary redirection
+ 308) ; permanent redirection
+ (let ((uri (resolve-uri-reference (response-location resp) uri)))
+ (close-port port)
+ (format log-port (G_ "following redirection to `~a'...~%")
+ (uri->string uri))
+ (loop uri)))
+ (else
+ (raise (condition (&http-get-error
+ (uri uri)
+ (code code)
+ (reason (response-reason-phrase resp)))
+ (&message
+ (message
+ (format
+ #f
+ (G_ "~a: HTTP download failed: ~a (~s)")
+ (uri->string uri) code
+ (response-reason-phrase resp))))))))))))
+
+(define-syntax-rule (false-if-networking-error exp)
+ "Return #f if EXP triggers a network related exception as can occur when
+reusing stale cached connections."
+ ;; FIXME: Duplicated from 'with-cached-connection'.
+ (catch #t
+ (lambda ()
+ exp)
+ (lambda (key . args)
+ ;; If PORT was cached and the server closed the connection in the
+ ;; meantime, we get EPIPE. In that case, open a fresh connection and
+ ;; retry. We might also get 'bad-response or a similar exception from
+ ;; (web response) later on, once we've sent the request, or a
+ ;; ERROR/INVALID-SESSION from GnuTLS.
+ (if (or (and (eq? key 'system-error)
+ (= EPIPE (system-error-errno `(,key ,@args))))
+ (and (eq? key 'gnutls-error)
+ (eq? (first args) error/invalid-session))
+ (memq key
+ '(bad-response bad-header bad-header-component)))
+ #f
+ (apply throw key args)))))
+
+(define* (http-multiple-get base-uri proc seed requests
+ #:key port (verify-certificate? #t)
+ (open-connection guix:open-connection-for-uri)
+ (keep-alive? #t)
+ (batch-size 1000))
+ "Send all of REQUESTS to the server at BASE-URI. Call PROC for each
+response, passing it the request object, the response, a port from which to
+read the response body, and the previous result, starting with SEED, à la
+'fold'. Return the final result.
+
+When PORT is specified, use it as the initial connection on which HTTP
+requests are sent; otherwise call OPEN-CONNECTION to open a new connection for
+a URI. When KEEP-ALIVE? is false, close the connection port before
+returning."
+ (let connect ((port port)
+ (requests requests)
+ (result seed))
+ (define batch
+ (if (>= batch-size (length requests))
+ requests
+ (take requests batch-size)))
+
+ ;; (format (current-error-port) "connecting (~a requests left)..."
+ ;; (length requests))
+ (let ((p (or port (open-connection base-uri
+ #:verify-certificate?
+ verify-certificate?))))
+ ;; For HTTPS, P is not a file port and does not support 'setvbuf'.
+ (when (file-port? p)
+ (setvbuf p 'block (expt 2 16)))
+
+ ;; Send BATCH in a row.
+ ;; XXX: Do our own caching to work around inefficiencies when
+ ;; communicating over TLS: <http://bugs.gnu.org/22966>.
+ (let-values (((buffer get) (open-bytevector-output-port)))
+ ;; Inherit the HTTP proxying property from P.
+ (set-http-proxy-port?! buffer (http-proxy-port? p))
+
+ (unless (false-if-networking-error
+ (begin
+ (for-each (cut write-request <> buffer) batch)
+ (put-bytevector p (get))
+ (force-output p)
+ #t))
+ ;; If PORT becomes unusable, open a fresh connection and retry.
+ (close-port p) ; close the broken port
+ (connect #f requests result)))
+
+ ;; Now start processing responses.
+ (let loop ((sent batch)
+ (processed 0)
+ (result result))
+ (match sent
+ (()
+ (match (drop requests processed)
+ (()
+ (unless keep-alive?
+ (close-port p))
+ (reverse result))
+ (remainder
+ (connect p remainder result))))
+ ((head tail ...)
+ (match (false-if-networking-error (read-response p))
+ ((? response? resp)
+ (let* ((body (response-body-port resp))
+ (result (proc head resp body result)))
+ ;; The server can choose to stop responding at any time,
+ ;; in which case we have to try again. Check whether
+ ;; that is the case. Note that even upon "Connection:
+ ;; close", we can read from BODY.
+ (match (assq 'connection (response-headers resp))
+ (('connection 'close)
+ (close-port p)
+ (connect #f ;try again
+ (drop requests (+ 1 processed))
+ result))
+ (_
+ (loop tail (+ 1 processed) result)))))
+ (#f
+ (close-port p)
+ (connect #f ; try again
+ (drop requests processed)
+ result)))))))))
+
+\f
+;;;
+;;; Caching.
+;;;
+
+(define %http-cache-ttl
+ ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
+ (make-parameter
+ (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
+ string->number*)
+ 36))))
+
+(define (cache-file-for-uri uri)
+ "Return the name of the file in the cache corresponding to URI."
+ (let ((digest (sha256 (string->utf8 (uri->string uri)))))
+ ;; Use the "URL" alphabet because it does not contain "/".
+ (string-append (cache-directory) "/http/"
+ (base64-encode digest 0 (bytevector-length digest)
+ #f #f base64url-alphabet))))
+
+(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
+ (write-cache dump-port)
+ (cache-miss (const #t))
+ (log-port (current-error-port))
+ (timeout 10))
+ "Like 'http-fetch', return an input port, but cache its contents in
+~/.cache/guix. The cache remains valid for TTL seconds.
+
+Call WRITE-CACHE with the HTTP input port and the cache output port to write
+the data to cache. Call CACHE-MISS with URI just before fetching data from
+URI.
+
+TIMEOUT specifies the timeout in seconds for connection establishment.
+
+Write information about redirects to LOG-PORT."
+ (let ((file (cache-file-for-uri uri)))
+ (define (update-cache cache-port)
+ (define cache-time
+ (and cache-port
+ (stat:mtime (stat cache-port))))
+
+ (define headers
+ `((user-agent . "GNU Guile")
+ ,@(if cache-time
+ `((if-modified-since
+ . ,(time-utc->date (make-time time-utc 0 cache-time))))
+ '())))
+
+ ;; Update the cache and return an input port.
+ (guard (c ((http-get-error? c)
+ (if (= 304 (http-get-error-code c)) ;"Not Modified"
+ (begin
+ (utime file) ;update FILE's mtime
+ cache-port)
+ (raise c))))
+ (let ((port (http-fetch uri #:text? text?
+ #:log-port log-port
+ #:headers headers #:timeout timeout)))
+ (cache-miss uri)
+ (mkdir-p (dirname file))
+ (when cache-port
+ (close-port cache-port))
+ (with-atomic-file-output file
+ (cut write-cache port <>))
+ (close-port port)
+ (open-input-file file))))
+
+ (define (old? port)
+ ;; Return true if PORT has passed TTL.
+ (let* ((s (stat port))
+ (now (current-time time-utc)))
+ (< (+ (stat:mtime s) ttl) (time-second now))))
+
+ (catch 'system-error
+ (lambda ()
+ (let ((port (open-input-file file)))
+ (if (old? port)
+ (update-cache port)
+ port)))
+ (lambda args
+ (if (= ENOENT (system-error-errno args))
+ (update-cache #f)
+ (apply throw args))))))
+
+;;; http-client.scm ends here
HCoop / jackhill / guix / guix.git / blobdiff