Commit | Line | Data |
---|---|---|
1c9e7d65 | 1 | ;;; GNU Guix --- Functional package management for GNU |
45fce38f | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020, 2021 Ludovic Courtès <ludo@gnu.org> |
04dec194 | 3 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
c28606bd | 4 | ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. |
57d28987 | 5 | ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> |
1c9e7d65 LC |
6 | ;;; |
7 | ;;; This file is part of GNU Guix. | |
8 | ;;; | |
9 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
10 | ;;; under the terms of the GNU General Public License as published by | |
11 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
12 | ;;; your option) any later version. | |
13 | ;;; | |
14 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
15 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
16 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
17 | ;;; GNU General Public License for more details. | |
18 | ;;; | |
19 | ;;; You should have received a copy of the GNU General Public License | |
20 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
21 | ||
3b8258c5 | 22 | (define-module (guix http-client) |
1c9e7d65 | 23 | #:use-module (web uri) |
e2e853dd | 24 | #:use-module (web http) |
76238483 | 25 | #:use-module ((web client) #:hide (open-socket-for-uri)) |
e2e853dd | 26 | #:use-module (web request) |
1c9e7d65 | 27 | #:use-module (web response) |
e2e853dd | 28 | #:use-module (srfi srfi-1) |
1c9e7d65 | 29 | #:use-module (srfi srfi-11) |
739ab68b LC |
30 | #:use-module (srfi srfi-19) |
31 | #:use-module (srfi srfi-26) | |
706e9e57 LC |
32 | #:use-module (srfi srfi-34) |
33 | #:use-module (srfi srfi-35) | |
15d5ca13 | 34 | #:use-module (ice-9 match) |
2535635f | 35 | #:use-module (ice-9 binary-ports) |
1c9e7d65 LC |
36 | #:use-module (rnrs bytevectors) |
37 | #:use-module (guix ui) | |
38 | #:use-module (guix utils) | |
0cb5bc2c | 39 | #:use-module (guix base64) |
ca719424 | 40 | #:autoload (gcrypt hash) (sha256) |
205833b7 | 41 | #:autoload (gnutls) (error/invalid-session) |
739ab68b LC |
42 | #:use-module ((guix build utils) |
43 | #:select (mkdir-p dump-port)) | |
76238483 | 44 | #:use-module ((guix build download) |
8a5063f7 | 45 | #:select (open-socket-for-uri |
4fd06a4d LC |
46 | (open-connection-for-uri |
47 | . guix:open-connection-for-uri) | |
48 | resolve-uri-reference)) | |
76238483 | 49 | #:re-export (open-socket-for-uri) |
706e9e57 LC |
50 | #:export (&http-get-error |
51 | http-get-error? | |
52 | http-get-error-uri | |
53 | http-get-error-code | |
54 | http-get-error-reason | |
55 | ||
739ab68b | 56 | http-fetch |
e2e853dd | 57 | http-multiple-get |
739ab68b LC |
58 | |
59 | %http-cache-ttl | |
60 | http-fetch/cached)) | |
1c9e7d65 LC |
61 | |
62 | ;;; Commentary: | |
63 | ;;; | |
706e9e57 LC |
64 | ;;; HTTP client portable among Guile versions, and with proper error condition |
65 | ;;; reporting. | |
1c9e7d65 LC |
66 | ;;; |
67 | ;;; Code: | |
68 | ||
706e9e57 LC |
69 | ;; HTTP GET error. |
70 | (define-condition-type &http-get-error &error | |
71 | http-get-error? | |
72 | (uri http-get-error-uri) ; URI | |
73 | (code http-get-error-code) ; integer | |
74 | (reason http-get-error-reason)) ; string | |
75 | ||
76 | ||
d262a0f3 | 77 | (define* (http-fetch uri #:key port (text? #f) (buffered? #t) |
05f38ca8 | 78 | (open-connection guix:open-connection-for-uri) |
5ff52145 | 79 | (keep-alive? #f) |
f4cde9ac | 80 | (verify-certificate? #t) |
d11f7f62 | 81 | (headers '((user-agent . "GNU Guile"))) |
dbfc6a32 | 82 | (log-port (current-error-port)) |
d11f7f62 | 83 | timeout) |
1c9e7d65 LC |
84 | "Return an input port containing the data at URI, and the expected number of |
85 | bytes available or #f. If TEXT? is true, the data at URI is considered to be | |
101d9f3f | 86 | textual. Follow any HTTP redirection. When BUFFERED? is #f, return an |
f4cde9ac LC |
87 | unbuffered port, suitable for use in `filtered-port'. HEADERS is an alist of |
88 | extra HTTP headers. | |
706e9e57 | 89 | |
5ff52145 LC |
90 | When KEEP-ALIVE? is true, the connection is marked as 'keep-alive' and PORT is |
91 | not closed upon completion. | |
92 | ||
17cff9c6 LC |
93 | When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. |
94 | ||
d11f7f62 LC |
95 | TIMEOUT specifies the timeout in seconds for connection establishment; when |
96 | TIMEOUT is #f, connection establishment never times out. | |
97 | ||
dbfc6a32 LC |
98 | Write information about redirects to LOG-PORT. |
99 | ||
706e9e57 | 100 | Raise an '&http-get-error' condition if downloading fails." |
25d188ce LC |
101 | (let loop ((uri (if (string? uri) |
102 | (string->uri uri) | |
103 | uri))) | |
05f38ca8 CB |
104 | (let ((port (or port (open-connection uri |
105 | #:verify-certificate? | |
106 | verify-certificate? | |
107 | #:timeout timeout))) | |
608a50b6 LC |
108 | (headers (match (uri-userinfo uri) |
109 | ((? string? str) | |
110 | (cons (cons 'Authorization | |
111 | (string-append "Basic " | |
112 | (base64-encode | |
113 | (string->utf8 str)))) | |
114 | headers)) | |
115 | (_ headers)))) | |
409e4ac6 | 116 | (unless (or buffered? (not (file-port? port))) |
76832d34 | 117 | (setvbuf port 'none)) |
bb7dcaea | 118 | (let*-values (((resp data) |
36626c55 | 119 | (http-get uri #:streaming? #t #:port port |
5ff52145 | 120 | #:keep-alive? keep-alive? |
36626c55 | 121 | #:headers headers)) |
bb7dcaea LC |
122 | ((code) |
123 | (response-code resp))) | |
124 | (case code | |
125 | ((200) | |
005c8fc6 | 126 | (values data (response-content-length resp))) |
bb7dcaea | 127 | ((301 ; moved permanently |
57d28987 TGR |
128 | 302 ; found (redirection) |
129 | 303 ; see other | |
130 | 307 ; temporary redirection | |
131 | 308) ; permanent redirection | |
04dec194 | 132 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
bb7dcaea | 133 | (close-port port) |
dbfc6a32 | 134 | (format log-port (G_ "following redirection to `~a'...~%") |
bb7dcaea LC |
135 | (uri->string uri)) |
136 | (loop uri))) | |
137 | (else | |
706e9e57 LC |
138 | (raise (condition (&http-get-error |
139 | (uri uri) | |
140 | (code code) | |
141 | (reason (response-reason-phrase resp))) | |
142 | (&message | |
dd1141eb LC |
143 | (message |
144 | (format | |
145 | #f | |
69daee23 | 146 | (G_ "~a: HTTP download failed: ~a (~s)") |
dd1141eb LC |
147 | (uri->string uri) code |
148 | (response-reason-phrase resp)))))))))))) | |
1c9e7d65 | 149 | |
45fce38f LC |
150 | (define-syntax-rule (false-if-networking-error exp) |
151 | "Return #f if EXP triggers a network related exception as can occur when | |
152 | reusing stale cached connections." | |
153 | ;; FIXME: Duplicated from 'with-cached-connection'. | |
154 | (catch #t | |
155 | (lambda () | |
156 | exp) | |
157 | (lambda (key . args) | |
158 | ;; If PORT was cached and the server closed the connection in the | |
159 | ;; meantime, we get EPIPE. In that case, open a fresh connection and | |
160 | ;; retry. We might also get 'bad-response or a similar exception from | |
161 | ;; (web response) later on, once we've sent the request, or a | |
162 | ;; ERROR/INVALID-SESSION from GnuTLS. | |
163 | (if (or (and (eq? key 'system-error) | |
164 | (= EPIPE (system-error-errno `(,key ,@args)))) | |
165 | (and (eq? key 'gnutls-error) | |
166 | (eq? (first args) error/invalid-session)) | |
167 | (memq key | |
168 | '(bad-response bad-header bad-header-component))) | |
169 | #f | |
170 | (apply throw key args))))) | |
171 | ||
e2e853dd CB |
172 | (define* (http-multiple-get base-uri proc seed requests |
173 | #:key port (verify-certificate? #t) | |
174 | (open-connection guix:open-connection-for-uri) | |
175 | (keep-alive? #t) | |
176 | (batch-size 1000)) | |
177 | "Send all of REQUESTS to the server at BASE-URI. Call PROC for each | |
178 | response, passing it the request object, the response, a port from which to | |
179 | read the response body, and the previous result, starting with SEED, à la | |
180 | 'fold'. Return the final result. | |
181 | ||
182 | When PORT is specified, use it as the initial connection on which HTTP | |
183 | requests are sent; otherwise call OPEN-CONNECTION to open a new connection for | |
184 | a URI. When KEEP-ALIVE? is false, close the connection port before | |
185 | returning." | |
186 | (let connect ((port port) | |
187 | (requests requests) | |
188 | (result seed)) | |
189 | (define batch | |
190 | (if (>= batch-size (length requests)) | |
191 | requests | |
192 | (take requests batch-size))) | |
193 | ||
194 | ;; (format (current-error-port) "connecting (~a requests left)..." | |
195 | ;; (length requests)) | |
196 | (let ((p (or port (open-connection base-uri | |
197 | #:verify-certificate? | |
198 | verify-certificate?)))) | |
199 | ;; For HTTPS, P is not a file port and does not support 'setvbuf'. | |
200 | (when (file-port? p) | |
201 | (setvbuf p 'block (expt 2 16))) | |
202 | ||
203 | ;; Send BATCH in a row. | |
204 | ;; XXX: Do our own caching to work around inefficiencies when | |
205 | ;; communicating over TLS: <http://bugs.gnu.org/22966>. | |
206 | (let-values (((buffer get) (open-bytevector-output-port))) | |
207 | ;; Inherit the HTTP proxying property from P. | |
208 | (set-http-proxy-port?! buffer (http-proxy-port? p)) | |
209 | ||
45fce38f LC |
210 | (unless (false-if-networking-error |
211 | (begin | |
212 | (for-each (cut write-request <> buffer) batch) | |
213 | (put-bytevector p (get)) | |
214 | (force-output p) | |
215 | #t)) | |
216 | ;; If PORT becomes unusable, open a fresh connection and retry. | |
217 | (close-port p) ; close the broken port | |
218 | (connect #f requests result))) | |
e2e853dd CB |
219 | |
220 | ;; Now start processing responses. | |
221 | (let loop ((sent batch) | |
222 | (processed 0) | |
223 | (result result)) | |
224 | (match sent | |
225 | (() | |
226 | (match (drop requests processed) | |
227 | (() | |
228 | (unless keep-alive? | |
229 | (close-port p)) | |
230 | (reverse result)) | |
231 | (remainder | |
232 | (connect p remainder result)))) | |
233 | ((head tail ...) | |
45fce38f LC |
234 | (match (false-if-networking-error (read-response p)) |
235 | ((? response? resp) | |
236 | (let* ((body (response-body-port resp)) | |
237 | (result (proc head resp body result))) | |
238 | ;; The server can choose to stop responding at any time, | |
239 | ;; in which case we have to try again. Check whether | |
240 | ;; that is the case. Note that even upon "Connection: | |
241 | ;; close", we can read from BODY. | |
242 | (match (assq 'connection (response-headers resp)) | |
243 | (('connection 'close) | |
244 | (close-port p) | |
245 | (connect #f ;try again | |
246 | (drop requests (+ 1 processed)) | |
247 | result)) | |
248 | (_ | |
249 | (loop tail (+ 1 processed) result))))) | |
250 | (#f | |
251 | (close-port p) | |
252 | (connect #f ; try again | |
673e5276 | 253 | (drop requests processed) |
45fce38f | 254 | result))))))))) |
e2e853dd | 255 | |
739ab68b LC |
256 | \f |
257 | ;;; | |
258 | ;;; Caching. | |
259 | ;;; | |
260 | ||
cbaf0f11 | 261 | (define %http-cache-ttl |
739ab68b LC |
262 | ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix. |
263 | (make-parameter | |
264 | (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL") | |
265 | string->number*) | |
266 | 36)))) | |
267 | ||
a4e7083d LC |
268 | (define (cache-file-for-uri uri) |
269 | "Return the name of the file in the cache corresponding to URI." | |
270 | (let ((digest (sha256 (string->utf8 (uri->string uri))))) | |
271 | ;; Use the "URL" alphabet because it does not contain "/". | |
272 | (string-append (cache-directory) "/http/" | |
273 | (base64-encode digest 0 (bytevector-length digest) | |
274 | #f #f base64url-alphabet)))) | |
275 | ||
7482b981 LC |
276 | (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text? |
277 | (write-cache dump-port) | |
d11f7f62 | 278 | (cache-miss (const #t)) |
dbfc6a32 | 279 | (log-port (current-error-port)) |
d11f7f62 | 280 | (timeout 10)) |
739ab68b | 281 | "Like 'http-fetch', return an input port, but cache its contents in |
7482b981 LC |
282 | ~/.cache/guix. The cache remains valid for TTL seconds. |
283 | ||
284 | Call WRITE-CACHE with the HTTP input port and the cache output port to write | |
285 | the data to cache. Call CACHE-MISS with URI just before fetching data from | |
d11f7f62 LC |
286 | URI. |
287 | ||
dbfc6a32 LC |
288 | TIMEOUT specifies the timeout in seconds for connection establishment. |
289 | ||
290 | Write information about redirects to LOG-PORT." | |
a4e7083d | 291 | (let ((file (cache-file-for-uri uri))) |
3ce1b902 LC |
292 | (define (update-cache cache-port) |
293 | (define cache-time | |
294 | (and cache-port | |
295 | (stat:mtime (stat cache-port)))) | |
296 | ||
297 | (define headers | |
298 | `((user-agent . "GNU Guile") | |
299 | ,@(if cache-time | |
300 | `((if-modified-since | |
301 | . ,(time-utc->date (make-time time-utc 0 cache-time)))) | |
302 | '()))) | |
303 | ||
739ab68b | 304 | ;; Update the cache and return an input port. |
3ce1b902 LC |
305 | (guard (c ((http-get-error? c) |
306 | (if (= 304 (http-get-error-code c)) ;"Not Modified" | |
06acf6b5 LC |
307 | (begin |
308 | (utime file) ;update FILE's mtime | |
309 | cache-port) | |
3ce1b902 LC |
310 | (raise c)))) |
311 | (let ((port (http-fetch uri #:text? text? | |
dbfc6a32 | 312 | #:log-port log-port |
d11f7f62 | 313 | #:headers headers #:timeout timeout))) |
7482b981 | 314 | (cache-miss uri) |
3ce1b902 LC |
315 | (mkdir-p (dirname file)) |
316 | (when cache-port | |
317 | (close-port cache-port)) | |
318 | (with-atomic-file-output file | |
7482b981 | 319 | (cut write-cache port <>)) |
3ce1b902 LC |
320 | (close-port port) |
321 | (open-input-file file)))) | |
739ab68b LC |
322 | |
323 | (define (old? port) | |
324 | ;; Return true if PORT has passed TTL. | |
325 | (let* ((s (stat port)) | |
326 | (now (current-time time-utc))) | |
327 | (< (+ (stat:mtime s) ttl) (time-second now)))) | |
328 | ||
329 | (catch 'system-error | |
330 | (lambda () | |
331 | (let ((port (open-input-file file))) | |
332 | (if (old? port) | |
3ce1b902 | 333 | (update-cache port) |
739ab68b LC |
334 | port))) |
335 | (lambda args | |
336 | (if (= ENOENT (system-error-errno args)) | |
3ce1b902 | 337 | (update-cache #f) |
739ab68b LC |
338 | (apply throw args)))))) |
339 | ||
3b8258c5 | 340 | ;;; http-client.scm ends here |