Commit | Line | Data |
---|---|---|
1c9e7d65 | 1 | ;;; GNU Guix --- Functional package management for GNU |
1d84d7bf | 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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) |
76238483 | 24 | #:use-module ((web client) #:hide (open-socket-for-uri)) |
1c9e7d65 LC |
25 | #:use-module (web response) |
26 | #:use-module (srfi srfi-11) | |
739ab68b LC |
27 | #:use-module (srfi srfi-19) |
28 | #:use-module (srfi srfi-26) | |
706e9e57 LC |
29 | #:use-module (srfi srfi-34) |
30 | #:use-module (srfi srfi-35) | |
15d5ca13 | 31 | #:use-module (ice-9 match) |
2535635f | 32 | #:use-module (ice-9 binary-ports) |
1c9e7d65 LC |
33 | #:use-module (rnrs bytevectors) |
34 | #:use-module (guix ui) | |
35 | #:use-module (guix utils) | |
0cb5bc2c | 36 | #:use-module (guix base64) |
ca719424 | 37 | #:autoload (gcrypt hash) (sha256) |
739ab68b LC |
38 | #:use-module ((guix build utils) |
39 | #:select (mkdir-p dump-port)) | |
76238483 | 40 | #:use-module ((guix build download) |
8a5063f7 | 41 | #:select (open-socket-for-uri |
4fd06a4d LC |
42 | (open-connection-for-uri |
43 | . guix:open-connection-for-uri) | |
44 | resolve-uri-reference)) | |
76238483 | 45 | #:re-export (open-socket-for-uri) |
706e9e57 LC |
46 | #:export (&http-get-error |
47 | http-get-error? | |
48 | http-get-error-uri | |
49 | http-get-error-code | |
50 | http-get-error-reason | |
51 | ||
739ab68b LC |
52 | http-fetch |
53 | ||
54 | %http-cache-ttl | |
55 | http-fetch/cached)) | |
1c9e7d65 LC |
56 | |
57 | ;;; Commentary: | |
58 | ;;; | |
706e9e57 LC |
59 | ;;; HTTP client portable among Guile versions, and with proper error condition |
60 | ;;; reporting. | |
1c9e7d65 LC |
61 | ;;; |
62 | ;;; Code: | |
63 | ||
706e9e57 LC |
64 | ;; HTTP GET error. |
65 | (define-condition-type &http-get-error &error | |
66 | http-get-error? | |
67 | (uri http-get-error-uri) ; URI | |
68 | (code http-get-error-code) ; integer | |
69 | (reason http-get-error-reason)) ; string | |
70 | ||
71 | ||
d262a0f3 | 72 | (define* (http-fetch uri #:key port (text? #f) (buffered? #t) |
f4cde9ac | 73 | (verify-certificate? #t) |
608a50b6 | 74 | (headers '((user-agent . "GNU Guile")))) |
1c9e7d65 LC |
75 | "Return an input port containing the data at URI, and the expected number of |
76 | bytes available or #f. If TEXT? is true, the data at URI is considered to be | |
101d9f3f | 77 | textual. Follow any HTTP redirection. When BUFFERED? is #f, return an |
f4cde9ac LC |
78 | unbuffered port, suitable for use in `filtered-port'. HEADERS is an alist of |
79 | extra HTTP headers. | |
706e9e57 | 80 | |
17cff9c6 LC |
81 | When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. |
82 | ||
706e9e57 | 83 | Raise an '&http-get-error' condition if downloading fails." |
25d188ce LC |
84 | (let loop ((uri (if (string? uri) |
85 | (string->uri uri) | |
86 | uri))) | |
4fd06a4d LC |
87 | (let ((port (or port (guix:open-connection-for-uri uri |
88 | #:verify-certificate? | |
89 | verify-certificate?))) | |
608a50b6 LC |
90 | (headers (match (uri-userinfo uri) |
91 | ((? string? str) | |
92 | (cons (cons 'Authorization | |
93 | (string-append "Basic " | |
94 | (base64-encode | |
95 | (string->utf8 str)))) | |
96 | headers)) | |
97 | (_ headers)))) | |
409e4ac6 | 98 | (unless (or buffered? (not (file-port? port))) |
76832d34 | 99 | (setvbuf port 'none)) |
bb7dcaea | 100 | (let*-values (((resp data) |
36626c55 | 101 | (http-get uri #:streaming? #t #:port port |
f4cde9ac LC |
102 | ;; XXX: When #:keep-alive? is true, if DATA is |
103 | ;; a chunked-encoding port, closing DATA won't | |
104 | ;; close PORT, leading to a file descriptor | |
105 | ;; leak. | |
106 | #:keep-alive? #f | |
36626c55 | 107 | #:headers headers)) |
bb7dcaea LC |
108 | ((code) |
109 | (response-code resp))) | |
110 | (case code | |
111 | ((200) | |
005c8fc6 | 112 | (values data (response-content-length resp))) |
bb7dcaea | 113 | ((301 ; moved permanently |
57d28987 TGR |
114 | 302 ; found (redirection) |
115 | 303 ; see other | |
116 | 307 ; temporary redirection | |
117 | 308) ; permanent redirection | |
04dec194 | 118 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
bb7dcaea | 119 | (close-port port) |
9572d2b4 | 120 | (format (current-error-port) (G_ "following redirection to `~a'...~%") |
bb7dcaea LC |
121 | (uri->string uri)) |
122 | (loop uri))) | |
123 | (else | |
706e9e57 LC |
124 | (raise (condition (&http-get-error |
125 | (uri uri) | |
126 | (code code) | |
127 | (reason (response-reason-phrase resp))) | |
128 | (&message | |
dd1141eb LC |
129 | (message |
130 | (format | |
131 | #f | |
69daee23 | 132 | (G_ "~a: HTTP download failed: ~a (~s)") |
dd1141eb LC |
133 | (uri->string uri) code |
134 | (response-reason-phrase resp)))))))))))) | |
1c9e7d65 | 135 | |
739ab68b LC |
136 | \f |
137 | ;;; | |
138 | ;;; Caching. | |
139 | ;;; | |
140 | ||
cbaf0f11 | 141 | (define %http-cache-ttl |
739ab68b LC |
142 | ;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix. |
143 | (make-parameter | |
144 | (* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL") | |
145 | string->number*) | |
146 | 36)))) | |
147 | ||
a4e7083d LC |
148 | (define (cache-file-for-uri uri) |
149 | "Return the name of the file in the cache corresponding to URI." | |
150 | (let ((digest (sha256 (string->utf8 (uri->string uri))))) | |
151 | ;; Use the "URL" alphabet because it does not contain "/". | |
152 | (string-append (cache-directory) "/http/" | |
153 | (base64-encode digest 0 (bytevector-length digest) | |
154 | #f #f base64url-alphabet)))) | |
155 | ||
7482b981 LC |
156 | (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text? |
157 | (write-cache dump-port) | |
158 | (cache-miss (const #t))) | |
739ab68b | 159 | "Like 'http-fetch', return an input port, but cache its contents in |
7482b981 LC |
160 | ~/.cache/guix. The cache remains valid for TTL seconds. |
161 | ||
162 | Call WRITE-CACHE with the HTTP input port and the cache output port to write | |
163 | the data to cache. Call CACHE-MISS with URI just before fetching data from | |
164 | URI." | |
a4e7083d | 165 | (let ((file (cache-file-for-uri uri))) |
3ce1b902 LC |
166 | (define (update-cache cache-port) |
167 | (define cache-time | |
168 | (and cache-port | |
169 | (stat:mtime (stat cache-port)))) | |
170 | ||
171 | (define headers | |
172 | `((user-agent . "GNU Guile") | |
173 | ,@(if cache-time | |
174 | `((if-modified-since | |
175 | . ,(time-utc->date (make-time time-utc 0 cache-time)))) | |
176 | '()))) | |
177 | ||
739ab68b | 178 | ;; Update the cache and return an input port. |
3ce1b902 LC |
179 | (guard (c ((http-get-error? c) |
180 | (if (= 304 (http-get-error-code c)) ;"Not Modified" | |
06acf6b5 LC |
181 | (begin |
182 | (utime file) ;update FILE's mtime | |
183 | cache-port) | |
3ce1b902 LC |
184 | (raise c)))) |
185 | (let ((port (http-fetch uri #:text? text? | |
186 | #:headers headers))) | |
7482b981 | 187 | (cache-miss uri) |
3ce1b902 LC |
188 | (mkdir-p (dirname file)) |
189 | (when cache-port | |
190 | (close-port cache-port)) | |
191 | (with-atomic-file-output file | |
7482b981 | 192 | (cut write-cache port <>)) |
3ce1b902 LC |
193 | (close-port port) |
194 | (open-input-file file)))) | |
739ab68b LC |
195 | |
196 | (define (old? port) | |
197 | ;; Return true if PORT has passed TTL. | |
198 | (let* ((s (stat port)) | |
199 | (now (current-time time-utc))) | |
200 | (< (+ (stat:mtime s) ttl) (time-second now)))) | |
201 | ||
202 | (catch 'system-error | |
203 | (lambda () | |
204 | (let ((port (open-input-file file))) | |
205 | (if (old? port) | |
3ce1b902 | 206 | (update-cache port) |
739ab68b LC |
207 | port))) |
208 | (lambda args | |
209 | (if (= ENOENT (system-error-errno args)) | |
3ce1b902 | 210 | (update-cache #f) |
739ab68b LC |
211 | (apply throw args)))))) |
212 | ||
3b8258c5 | 213 | ;;; http-client.scm ends here |