Commit | Line | Data |
---|---|---|
1c9e7d65 | 1 | ;;; GNU Guix --- Functional package management for GNU |
608a50b6 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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. |
1c9e7d65 LC |
5 | ;;; |
6 | ;;; This file is part of GNU Guix. | |
7 | ;;; | |
8 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
9 | ;;; under the terms of the GNU General Public License as published by | |
10 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
11 | ;;; your option) any later version. | |
12 | ;;; | |
13 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
14 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
15 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
16 | ;;; GNU General Public License for more details. | |
17 | ;;; | |
18 | ;;; You should have received a copy of the GNU General Public License | |
19 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
20 | ||
3b8258c5 | 21 | (define-module (guix http-client) |
1c9e7d65 | 22 | #:use-module (web uri) |
76238483 | 23 | #:use-module ((web client) #:hide (open-socket-for-uri)) |
1c9e7d65 LC |
24 | #:use-module (web response) |
25 | #:use-module (srfi srfi-11) | |
739ab68b LC |
26 | #:use-module (srfi srfi-19) |
27 | #:use-module (srfi srfi-26) | |
706e9e57 LC |
28 | #:use-module (srfi srfi-34) |
29 | #:use-module (srfi srfi-35) | |
15d5ca13 | 30 | #:use-module (ice-9 match) |
2535635f | 31 | #:use-module (ice-9 binary-ports) |
1c9e7d65 LC |
32 | #:use-module (rnrs bytevectors) |
33 | #:use-module (guix ui) | |
34 | #:use-module (guix utils) | |
0cb5bc2c | 35 | #:use-module (guix base64) |
a4e7083d | 36 | #:autoload (guix hash) (sha256) |
739ab68b LC |
37 | #:use-module ((guix build utils) |
38 | #:select (mkdir-p dump-port)) | |
76238483 | 39 | #:use-module ((guix build download) |
8a5063f7 LC |
40 | #:select (open-socket-for-uri |
41 | open-connection-for-uri resolve-uri-reference)) | |
76238483 | 42 | #:re-export (open-socket-for-uri) |
706e9e57 LC |
43 | #:export (&http-get-error |
44 | http-get-error? | |
45 | http-get-error-uri | |
46 | http-get-error-code | |
47 | http-get-error-reason | |
48 | ||
739ab68b LC |
49 | http-fetch |
50 | ||
51 | %http-cache-ttl | |
52 | http-fetch/cached)) | |
1c9e7d65 LC |
53 | |
54 | ;;; Commentary: | |
55 | ;;; | |
706e9e57 LC |
56 | ;;; HTTP client portable among Guile versions, and with proper error condition |
57 | ;;; reporting. | |
1c9e7d65 LC |
58 | ;;; |
59 | ;;; Code: | |
60 | ||
706e9e57 LC |
61 | ;; HTTP GET error. |
62 | (define-condition-type &http-get-error &error | |
63 | http-get-error? | |
64 | (uri http-get-error-uri) ; URI | |
65 | (code http-get-error-code) ; integer | |
66 | (reason http-get-error-reason)) ; string | |
67 | ||
68 | ||
776463ba | 69 | (define-syntax when-guile<=2.0.5-or-otherwise-broken |
1424a96e LC |
70 | (lambda (s) |
71 | (syntax-case s () | |
72 | ((_ body ...) | |
73 | ;; Always emit BODY, regardless of VERSION, because sometimes this code | |
74 | ;; might be compiled with a recent Guile and run with 2.0.5---e.g., | |
75 | ;; when using "guix pull". | |
76 | #'(begin body ...))))) | |
77 | ||
776463ba | 78 | (when-guile<=2.0.5-or-otherwise-broken |
c28606bd | 79 | ;; Backport of Guile commits 312e79f8 ("Add HTTP Chunked Encoding support to |
15d5ca13 LC |
80 | ;; web modules."), 00d3ecf2 ("http: Do not buffer HTTP chunks."), and 53b8d5f |
81 | ;; ("web: Gracefully handle premature EOF when reading chunk header.") | |
1424a96e LC |
82 | |
83 | (use-modules (ice-9 rdelim)) | |
84 | ||
776463ba LC |
85 | (define %web-http |
86 | (resolve-module '(web http))) | |
87 | ||
1424a96e LC |
88 | ;; Chunked Responses |
89 | (define (read-chunk-header port) | |
15d5ca13 LC |
90 | "Read a chunk header from PORT and return the size in bytes of the |
91 | upcoming chunk." | |
92 | (match (read-line port) | |
93 | ((? eof-object?) | |
94 | ;; Connection closed prematurely: there's nothing left to read. | |
95 | 0) | |
96 | (str | |
97 | (let ((extension-start (string-index str | |
98 | (lambda (c) | |
99 | (or (char=? c #\;) | |
100 | (char=? c #\return)))))) | |
101 | (string->number (if extension-start ; unnecessary? | |
102 | (substring str 0 extension-start) | |
103 | str) | |
104 | 16))))) | |
1424a96e | 105 | |
1424a96e LC |
106 | (define* (make-chunked-input-port port #:key (keep-alive? #f)) |
107 | "Returns a new port which translates HTTP chunked transfer encoded | |
108 | data from PORT into a non-encoded format. Returns eof when it has | |
109 | read the final chunk from PORT. This does not necessarily mean | |
110 | that there is no more data on PORT. When the returned port is | |
111 | closed it will also close PORT, unless the KEEP-ALIVE? is true." | |
1424a96e LC |
112 | (define (close) |
113 | (unless keep-alive? | |
114 | (close-port port))) | |
c28606bd LC |
115 | |
116 | (define chunk-size 0) ;size of the current chunk | |
117 | (define remaining 0) ;number of bytes left from the current chunk | |
118 | (define finished? #f) ;did we get all the chunks? | |
119 | ||
1424a96e LC |
120 | (define (read! bv idx to-read) |
121 | (define (loop to-read num-read) | |
122 | (cond ((or finished? (zero? to-read)) | |
123 | num-read) | |
c28606bd LC |
124 | ((zero? remaining) ;get a new chunk |
125 | (let ((size (read-chunk-header port))) | |
126 | (set! chunk-size size) | |
127 | (set! remaining size) | |
128 | (if (zero? size) | |
129 | (begin | |
130 | (set! finished? #t) | |
131 | num-read) | |
132 | (loop to-read num-read)))) | |
133 | (else ;read from the current chunk | |
134 | (let* ((ask-for (min to-read remaining)) | |
135 | (read (get-bytevector-n! port bv (+ idx num-read) | |
136 | ask-for))) | |
137 | (if (eof-object? read) | |
138 | (begin ;premature termination | |
139 | (set! finished? #t) | |
140 | num-read) | |
141 | (let ((left (- remaining read))) | |
142 | (set! remaining left) | |
143 | (when (zero? left) | |
144 | ;; We're done with this chunk; read CR and LF. | |
145 | (get-u8 port) (get-u8 port)) | |
146 | (loop (- to-read read) | |
147 | (+ num-read read)))))))) | |
1424a96e | 148 | (loop to-read 0)) |
c28606bd | 149 | |
1424a96e LC |
150 | (make-custom-binary-input-port "chunked input port" read! #f #f close)) |
151 | ||
776463ba LC |
152 | ;; Chunked encoding support in Guile <= 2.0.11 would load whole chunks in |
153 | ;; memory---see <http://bugs.gnu.org/19939>. | |
154 | (when (module-variable %web-http 'read-chunk-body) | |
155 | (module-set! %web-http 'make-chunked-input-port make-chunked-input-port)) | |
156 | ||
0cc0095f LC |
157 | (define (make-delimited-input-port port len keep-alive?) |
158 | "Return an input port that reads from PORT, and makes sure that | |
159 | exactly LEN bytes are available from PORT. Closing the returned port | |
160 | closes PORT, unless KEEP-ALIVE? is true." | |
161 | (define bytes-read 0) | |
162 | ||
163 | (define (fail) | |
164 | ((@@ (web response) bad-response) | |
165 | "EOF while reading response body: ~a bytes of ~a" | |
166 | bytes-read len)) | |
167 | ||
168 | (define (read! bv start count) | |
169 | ;; Read at most LEN bytes in total. HTTP/1.1 doesn't say what to do | |
170 | ;; when a server provides more than the Content-Length, but it seems | |
171 | ;; wise to just stop reading at LEN. | |
172 | (let ((count (min count (- len bytes-read)))) | |
173 | (let loop ((ret (get-bytevector-n! port bv start count))) | |
174 | (cond ((eof-object? ret) | |
175 | (if (= bytes-read len) | |
176 | 0 ; EOF | |
177 | (fail))) | |
178 | ((and (zero? ret) (> count 0)) | |
179 | ;; Do not return zero since zero means EOF, so try again. | |
180 | (loop (get-bytevector-n! port bv start count))) | |
181 | (else | |
182 | (set! bytes-read (+ bytes-read ret)) | |
183 | ret))))) | |
184 | ||
185 | (define close | |
186 | (and (not keep-alive?) | |
187 | (lambda () | |
6b02a448 | 188 | (close-port port)))) |
0cc0095f LC |
189 | |
190 | (make-custom-binary-input-port "delimited input port" read! #f #f close)) | |
191 | ||
793a43f4 LC |
192 | (define (read-header-line port) |
193 | "Read an HTTP header line and return it without its final CRLF or LF. | |
194 | Raise a 'bad-header' exception if the line does not end in CRLF or LF, | |
195 | or if EOF is reached." | |
196 | (match (%read-line port) | |
197 | (((? string? line) . #\newline) | |
198 | ;; '%read-line' does not consider #\return a delimiter; so if it's | |
199 | ;; there, remove it. We are more tolerant than the RFC in that we | |
200 | ;; tolerate LF-only endings. | |
201 | (if (string-suffix? "\r" line) | |
202 | (string-drop-right line 1) | |
203 | line)) | |
204 | ((line . _) ;EOF or missing delimiter | |
205 | ((@@ (web http) bad-header) 'read-header-line line)))) | |
206 | ||
6b02a448 | 207 | (unless (guile-version>? "2.0.11") |
0cc0095f LC |
208 | ;; Guile <= 2.0.9 had a bug whereby 'response-body-port' would read more |
209 | ;; than what 'content-length' says. See Guile commit 802a25b. | |
1c63dafc | 210 | ;; Guile <= 2.0.11 had a bug whereby the 'close' method of the response |
6b02a448 | 211 | ;; body port would fail with wrong-arg-num. See Guile commit 5a10e41. |
0cc0095f | 212 | (module-set! (resolve-module '(web response)) |
793a43f4 LC |
213 | 'make-delimited-input-port make-delimited-input-port) |
214 | ||
215 | ;; Guile <= 2.0.11 was affected by <http://bugs.gnu.org/22273>. See Guile | |
216 | ;; commit 4c7732c. | |
217 | (when (module-variable %web-http 'read-line*) | |
218 | (module-set! %web-http 'read-line* read-header-line)))) | |
1424a96e LC |
219 | |
220 | ||
d262a0f3 | 221 | (define* (http-fetch uri #:key port (text? #f) (buffered? #t) |
608a50b6 LC |
222 | keep-alive? (verify-certificate? #t) |
223 | (headers '((user-agent . "GNU Guile")))) | |
1c9e7d65 LC |
224 | "Return an input port containing the data at URI, and the expected number of |
225 | bytes available or #f. If TEXT? is true, the data at URI is considered to be | |
101d9f3f | 226 | textual. Follow any HTTP redirection. When BUFFERED? is #f, return an |
d262a0f3 LC |
227 | unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is |
228 | true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be | |
608a50b6 | 229 | reused for future HTTP requests. HEADERS is an alist of extra HTTP headers. |
706e9e57 | 230 | |
17cff9c6 LC |
231 | When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. |
232 | ||
706e9e57 | 233 | Raise an '&http-get-error' condition if downloading fails." |
25d188ce LC |
234 | (let loop ((uri (if (string? uri) |
235 | (string->uri uri) | |
236 | uri))) | |
17cff9c6 LC |
237 | (let ((port (or port (open-connection-for-uri uri |
238 | #:verify-certificate? | |
239 | verify-certificate?))) | |
608a50b6 LC |
240 | (headers (match (uri-userinfo uri) |
241 | ((? string? str) | |
242 | (cons (cons 'Authorization | |
243 | (string-append "Basic " | |
244 | (base64-encode | |
245 | (string->utf8 str)))) | |
246 | headers)) | |
247 | (_ headers)))) | |
409e4ac6 | 248 | (unless (or buffered? (not (file-port? port))) |
76238483 | 249 | (setvbuf port _IONBF)) |
bb7dcaea | 250 | (let*-values (((resp data) |
36626c55 LC |
251 | (http-get uri #:streaming? #t #:port port |
252 | #:keep-alive? #t | |
253 | #:headers headers)) | |
bb7dcaea LC |
254 | ((code) |
255 | (response-code resp))) | |
256 | (case code | |
257 | ((200) | |
005c8fc6 | 258 | (values data (response-content-length resp))) |
bb7dcaea LC |
259 | ((301 ; moved permanently |
260 | 302) ; found (redirection) | |
04dec194 | 261 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
bb7dcaea LC |
262 | (close-port port) |
263 | (format #t (_ "following redirection to `~a'...~%") | |
264 | (uri->string uri)) | |
265 | (loop uri))) | |
266 | (else | |
706e9e57 LC |
267 | (raise (condition (&http-get-error |
268 | (uri uri) | |
269 | (code code) | |
270 | (reason (response-reason-phrase resp))) | |
271 | (&message | |
dd1141eb LC |
272 | (message |
273 | (format | |
274 | #f | |
275 | (_ "~a: HTTP download failed: ~a (~s)") | |
276 | (uri->string uri) code | |
277 | (response-reason-phrase resp)))))))))))) | |
1c9e7d65 | 278 | |
739ab68b LC |
279 | \f |
280 | ;;; | |
281 | ;;; Caching. | |
282 | ;;; | |
283 | ||
cbaf0f11 | 284 | (define %http-cache-ttl |
739ab68b LC |
285 | ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix. |
286 | (make-parameter | |
287 | (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL") | |
288 | string->number*) | |
289 | 36)))) | |
290 | ||
a4e7083d LC |
291 | (define (cache-file-for-uri uri) |
292 | "Return the name of the file in the cache corresponding to URI." | |
293 | (let ((digest (sha256 (string->utf8 (uri->string uri))))) | |
294 | ;; Use the "URL" alphabet because it does not contain "/". | |
295 | (string-append (cache-directory) "/http/" | |
296 | (base64-encode digest 0 (bytevector-length digest) | |
297 | #f #f base64url-alphabet)))) | |
298 | ||
739ab68b LC |
299 | (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?) |
300 | "Like 'http-fetch', return an input port, but cache its contents in | |
301 | ~/.cache/guix. The cache remains valid for TTL seconds." | |
a4e7083d | 302 | (let ((file (cache-file-for-uri uri))) |
739ab68b LC |
303 | (define (update-cache) |
304 | ;; Update the cache and return an input port. | |
305 | (let ((port (http-fetch uri #:text? text?))) | |
a4e7083d | 306 | (mkdir-p (dirname file)) |
e72f50a7 | 307 | (with-atomic-file-output file |
739ab68b LC |
308 | (cut dump-port port <>)) |
309 | (close-port port) | |
310 | (open-input-file file))) | |
311 | ||
312 | (define (old? port) | |
313 | ;; Return true if PORT has passed TTL. | |
314 | (let* ((s (stat port)) | |
315 | (now (current-time time-utc))) | |
316 | (< (+ (stat:mtime s) ttl) (time-second now)))) | |
317 | ||
318 | (catch 'system-error | |
319 | (lambda () | |
320 | (let ((port (open-input-file file))) | |
321 | (if (old? port) | |
322 | (begin | |
323 | (close-port port) | |
324 | (update-cache)) | |
325 | port))) | |
326 | (lambda args | |
327 | (if (= ENOENT (system-error-errno args)) | |
328 | (update-cache) | |
329 | (apply throw args)))))) | |
330 | ||
3b8258c5 | 331 | ;;; http-client.scm ends here |