Commit | Line | Data |
---|---|---|
1c9e7d65 | 1 | ;;; GNU Guix --- Functional package management for GNU |
5ff52145 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2020 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 LC |
81 | (headers '((user-agent . "GNU Guile"))) |
82 | timeout) | |
1c9e7d65 LC |
83 | "Return an input port containing the data at URI, and the expected number of |
84 | bytes available or #f. If TEXT? is true, the data at URI is considered to be | |
101d9f3f | 85 | textual. Follow any HTTP redirection. When BUFFERED? is #f, return an |
f4cde9ac LC |
86 | unbuffered port, suitable for use in `filtered-port'. HEADERS is an alist of |
87 | extra HTTP headers. | |
706e9e57 | 88 | |
5ff52145 LC |
89 | When KEEP-ALIVE? is true, the connection is marked as 'keep-alive' and PORT is |
90 | not closed upon completion. | |
91 | ||
17cff9c6 LC |
92 | When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. |
93 | ||
d11f7f62 LC |
94 | TIMEOUT specifies the timeout in seconds for connection establishment; when |
95 | TIMEOUT is #f, connection establishment never times out. | |
96 | ||
706e9e57 | 97 | Raise an '&http-get-error' condition if downloading fails." |
25d188ce LC |
98 | (let loop ((uri (if (string? uri) |
99 | (string->uri uri) | |
100 | uri))) | |
05f38ca8 CB |
101 | (let ((port (or port (open-connection uri |
102 | #:verify-certificate? | |
103 | verify-certificate? | |
104 | #:timeout timeout))) | |
608a50b6 LC |
105 | (headers (match (uri-userinfo uri) |
106 | ((? string? str) | |
107 | (cons (cons 'Authorization | |
108 | (string-append "Basic " | |
109 | (base64-encode | |
110 | (string->utf8 str)))) | |
111 | headers)) | |
112 | (_ headers)))) | |
409e4ac6 | 113 | (unless (or buffered? (not (file-port? port))) |
76832d34 | 114 | (setvbuf port 'none)) |
bb7dcaea | 115 | (let*-values (((resp data) |
36626c55 | 116 | (http-get uri #:streaming? #t #:port port |
5ff52145 | 117 | #:keep-alive? keep-alive? |
36626c55 | 118 | #:headers headers)) |
bb7dcaea LC |
119 | ((code) |
120 | (response-code resp))) | |
121 | (case code | |
122 | ((200) | |
005c8fc6 | 123 | (values data (response-content-length resp))) |
bb7dcaea | 124 | ((301 ; moved permanently |
57d28987 TGR |
125 | 302 ; found (redirection) |
126 | 303 ; see other | |
127 | 307 ; temporary redirection | |
128 | 308) ; permanent redirection | |
04dec194 | 129 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
bb7dcaea | 130 | (close-port port) |
9572d2b4 | 131 | (format (current-error-port) (G_ "following redirection to `~a'...~%") |
bb7dcaea LC |
132 | (uri->string uri)) |
133 | (loop uri))) | |
134 | (else | |
706e9e57 LC |
135 | (raise (condition (&http-get-error |
136 | (uri uri) | |
137 | (code code) | |
138 | (reason (response-reason-phrase resp))) | |
139 | (&message | |
dd1141eb LC |
140 | (message |
141 | (format | |
142 | #f | |
69daee23 | 143 | (G_ "~a: HTTP download failed: ~a (~s)") |
dd1141eb LC |
144 | (uri->string uri) code |
145 | (response-reason-phrase resp)))))))))))) | |
1c9e7d65 | 146 | |
e2e853dd CB |
147 | (define* (http-multiple-get base-uri proc seed requests |
148 | #:key port (verify-certificate? #t) | |
149 | (open-connection guix:open-connection-for-uri) | |
150 | (keep-alive? #t) | |
151 | (batch-size 1000)) | |
152 | "Send all of REQUESTS to the server at BASE-URI. Call PROC for each | |
153 | response, passing it the request object, the response, a port from which to | |
154 | read the response body, and the previous result, starting with SEED, à la | |
155 | 'fold'. Return the final result. | |
156 | ||
157 | When PORT is specified, use it as the initial connection on which HTTP | |
158 | requests are sent; otherwise call OPEN-CONNECTION to open a new connection for | |
159 | a URI. When KEEP-ALIVE? is false, close the connection port before | |
160 | returning." | |
161 | (let connect ((port port) | |
162 | (requests requests) | |
163 | (result seed)) | |
164 | (define batch | |
165 | (if (>= batch-size (length requests)) | |
166 | requests | |
167 | (take requests batch-size))) | |
168 | ||
169 | ;; (format (current-error-port) "connecting (~a requests left)..." | |
170 | ;; (length requests)) | |
171 | (let ((p (or port (open-connection base-uri | |
172 | #:verify-certificate? | |
173 | verify-certificate?)))) | |
174 | ;; For HTTPS, P is not a file port and does not support 'setvbuf'. | |
175 | (when (file-port? p) | |
176 | (setvbuf p 'block (expt 2 16))) | |
177 | ||
178 | ;; Send BATCH in a row. | |
179 | ;; XXX: Do our own caching to work around inefficiencies when | |
180 | ;; communicating over TLS: <http://bugs.gnu.org/22966>. | |
181 | (let-values (((buffer get) (open-bytevector-output-port))) | |
182 | ;; Inherit the HTTP proxying property from P. | |
183 | (set-http-proxy-port?! buffer (http-proxy-port? p)) | |
184 | ||
205833b7 CB |
185 | (catch #t |
186 | (lambda () | |
187 | (for-each (cut write-request <> buffer) | |
188 | batch) | |
189 | (put-bytevector p (get)) | |
190 | (force-output p)) | |
191 | (lambda (key . args) | |
192 | ;; If PORT becomes unusable, open a fresh connection and | |
193 | ;; retry. | |
194 | (if (or (and (eq? key 'system-error) | |
195 | (= EPIPE (system-error-errno `(,key ,@args)))) | |
196 | (and (eq? key 'gnutls-error) | |
197 | (eq? (first args) error/invalid-session))) | |
198 | (begin | |
199 | (close-port p) ; close the broken port | |
200 | (connect #f | |
201 | requests | |
202 | result)) | |
203 | (apply throw key args))))) | |
e2e853dd CB |
204 | |
205 | ;; Now start processing responses. | |
206 | (let loop ((sent batch) | |
207 | (processed 0) | |
208 | (result result)) | |
209 | (match sent | |
210 | (() | |
211 | (match (drop requests processed) | |
212 | (() | |
213 | (unless keep-alive? | |
214 | (close-port p)) | |
215 | (reverse result)) | |
216 | (remainder | |
217 | (connect p remainder result)))) | |
218 | ((head tail ...) | |
205833b7 CB |
219 | (catch #t |
220 | (lambda () | |
221 | (let* ((resp (read-response p)) | |
222 | (body (response-body-port resp)) | |
223 | (result (proc head resp body result))) | |
224 | ;; The server can choose to stop responding at any time, | |
225 | ;; in which case we have to try again. Check whether | |
226 | ;; that is the case. Note that even upon "Connection: | |
227 | ;; close", we can read from BODY. | |
228 | (match (assq 'connection (response-headers resp)) | |
229 | (('connection 'close) | |
230 | (close-port p) | |
231 | (connect #f ;try again | |
232 | (drop requests (+ 1 processed)) | |
233 | result)) | |
234 | (_ | |
235 | (loop tail (+ 1 processed) result))))) ;keep going | |
236 | (lambda (key . args) | |
237 | ;; If PORT was cached and the server closed the connection | |
238 | ;; in the meantime, we get EPIPE. In that case, open a | |
239 | ;; fresh connection and retry. We might also get | |
240 | ;; 'bad-response or a similar exception from (web response) | |
241 | ;; later on, once we've sent the request, or a | |
242 | ;; ERROR/INVALID-SESSION from GnuTLS. | |
243 | (if (or (and (eq? key 'system-error) | |
244 | (= EPIPE (system-error-errno `(,key ,@args)))) | |
245 | (and (eq? key 'gnutls-error) | |
246 | (eq? (first args) error/invalid-session)) | |
247 | (memq key | |
248 | '(bad-response bad-header bad-header-component))) | |
249 | (begin | |
250 | (close-port p) | |
251 | (connect #f ; try again | |
252 | (drop requests (+ 1 processed)) | |
253 | result)) | |
254 | (apply throw key args)))))))))) | |
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 LC |
278 | (cache-miss (const #t)) |
279 | (timeout 10)) | |
739ab68b | 280 | "Like 'http-fetch', return an input port, but cache its contents in |
7482b981 LC |
281 | ~/.cache/guix. The cache remains valid for TTL seconds. |
282 | ||
283 | Call WRITE-CACHE with the HTTP input port and the cache output port to write | |
284 | the data to cache. Call CACHE-MISS with URI just before fetching data from | |
d11f7f62 LC |
285 | URI. |
286 | ||
287 | TIMEOUT specifies the timeout in seconds for connection establishment." | |
a4e7083d | 288 | (let ((file (cache-file-for-uri uri))) |
3ce1b902 LC |
289 | (define (update-cache cache-port) |
290 | (define cache-time | |
291 | (and cache-port | |
292 | (stat:mtime (stat cache-port)))) | |
293 | ||
294 | (define headers | |
295 | `((user-agent . "GNU Guile") | |
296 | ,@(if cache-time | |
297 | `((if-modified-since | |
298 | . ,(time-utc->date (make-time time-utc 0 cache-time)))) | |
299 | '()))) | |
300 | ||
739ab68b | 301 | ;; Update the cache and return an input port. |
3ce1b902 LC |
302 | (guard (c ((http-get-error? c) |
303 | (if (= 304 (http-get-error-code c)) ;"Not Modified" | |
06acf6b5 LC |
304 | (begin |
305 | (utime file) ;update FILE's mtime | |
306 | cache-port) | |
3ce1b902 LC |
307 | (raise c)))) |
308 | (let ((port (http-fetch uri #:text? text? | |
d11f7f62 | 309 | #:headers headers #:timeout timeout))) |
7482b981 | 310 | (cache-miss uri) |
3ce1b902 LC |
311 | (mkdir-p (dirname file)) |
312 | (when cache-port | |
313 | (close-port cache-port)) | |
314 | (with-atomic-file-output file | |
7482b981 | 315 | (cut write-cache port <>)) |
3ce1b902 LC |
316 | (close-port port) |
317 | (open-input-file file)))) | |
739ab68b LC |
318 | |
319 | (define (old? port) | |
320 | ;; Return true if PORT has passed TTL. | |
321 | (let* ((s (stat port)) | |
322 | (now (current-time time-utc))) | |
323 | (< (+ (stat:mtime s) ttl) (time-second now)))) | |
324 | ||
325 | (catch 'system-error | |
326 | (lambda () | |
327 | (let ((port (open-input-file file))) | |
328 | (if (old? port) | |
3ce1b902 | 329 | (update-cache port) |
739ab68b LC |
330 | port))) |
331 | (lambda args | |
332 | (if (= ENOENT (system-error-errno args)) | |
3ce1b902 | 333 | (update-cache #f) |
739ab68b LC |
334 | (apply throw args)))))) |
335 | ||
3b8258c5 | 336 | ;;; http-client.scm ends here |