| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> |
| 4 | ;;; Copyright © 2012, 2015 Free Software Foundation, Inc. |
| 5 | ;;; Copyright © 2017 Tobias Geerinckx-Rice <me@tobias.gr> |
| 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 | |
| 22 | (define-module (guix http-client) |
| 23 | #:use-module (web uri) |
| 24 | #:use-module ((web client) #:hide (open-socket-for-uri)) |
| 25 | #:use-module (web response) |
| 26 | #:use-module (srfi srfi-11) |
| 27 | #:use-module (srfi srfi-19) |
| 28 | #:use-module (srfi srfi-26) |
| 29 | #:use-module (srfi srfi-34) |
| 30 | #:use-module (srfi srfi-35) |
| 31 | #:use-module (ice-9 match) |
| 32 | #:use-module (ice-9 binary-ports) |
| 33 | #:use-module (rnrs bytevectors) |
| 34 | #:use-module (guix ui) |
| 35 | #:use-module (guix utils) |
| 36 | #:use-module (guix base64) |
| 37 | #:autoload (gcrypt hash) (sha256) |
| 38 | #:use-module ((guix build utils) |
| 39 | #:select (mkdir-p dump-port)) |
| 40 | #:use-module ((guix build download) |
| 41 | #:select (open-socket-for-uri |
| 42 | (open-connection-for-uri |
| 43 | . guix:open-connection-for-uri) |
| 44 | resolve-uri-reference)) |
| 45 | #:re-export (open-socket-for-uri) |
| 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 | |
| 52 | http-fetch |
| 53 | |
| 54 | %http-cache-ttl |
| 55 | http-fetch/cached)) |
| 56 | |
| 57 | ;;; Commentary: |
| 58 | ;;; |
| 59 | ;;; HTTP client portable among Guile versions, and with proper error condition |
| 60 | ;;; reporting. |
| 61 | ;;; |
| 62 | ;;; Code: |
| 63 | |
| 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 | |
| 72 | (define* (http-fetch uri #:key port (text? #f) (buffered? #t) |
| 73 | (verify-certificate? #t) |
| 74 | (headers '((user-agent . "GNU Guile")))) |
| 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 |
| 77 | textual. Follow any HTTP redirection. When BUFFERED? is #f, return an |
| 78 | unbuffered port, suitable for use in `filtered-port'. HEADERS is an alist of |
| 79 | extra HTTP headers. |
| 80 | |
| 81 | When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates. |
| 82 | |
| 83 | Raise an '&http-get-error' condition if downloading fails." |
| 84 | (let loop ((uri (if (string? uri) |
| 85 | (string->uri uri) |
| 86 | uri))) |
| 87 | (let ((port (or port (guix:open-connection-for-uri uri |
| 88 | #:verify-certificate? |
| 89 | verify-certificate?))) |
| 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)))) |
| 98 | (unless (or buffered? (not (file-port? port))) |
| 99 | (setvbuf port 'none)) |
| 100 | (let*-values (((resp data) |
| 101 | (http-get uri #:streaming? #t #:port port |
| 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 |
| 107 | #:headers headers)) |
| 108 | ((code) |
| 109 | (response-code resp))) |
| 110 | (case code |
| 111 | ((200) |
| 112 | (values data (response-content-length resp))) |
| 113 | ((301 ; moved permanently |
| 114 | 302 ; found (redirection) |
| 115 | 303 ; see other |
| 116 | 307 ; temporary redirection |
| 117 | 308) ; permanent redirection |
| 118 | (let ((uri (resolve-uri-reference (response-location resp) uri))) |
| 119 | (close-port port) |
| 120 | (format (current-error-port) (G_ "following redirection to `~a'...~%") |
| 121 | (uri->string uri)) |
| 122 | (loop uri))) |
| 123 | (else |
| 124 | (raise (condition (&http-get-error |
| 125 | (uri uri) |
| 126 | (code code) |
| 127 | (reason (response-reason-phrase resp))) |
| 128 | (&message |
| 129 | (message |
| 130 | (format |
| 131 | #f |
| 132 | (G_ "~a: HTTP download failed: ~a (~s)") |
| 133 | (uri->string uri) code |
| 134 | (response-reason-phrase resp)))))))))))) |
| 135 | |
| 136 | \f |
| 137 | ;;; |
| 138 | ;;; Caching. |
| 139 | ;;; |
| 140 | |
| 141 | (define %http-cache-ttl |
| 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 | |
| 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 | |
| 156 | (define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text? |
| 157 | (write-cache dump-port) |
| 158 | (cache-miss (const #t))) |
| 159 | "Like 'http-fetch', return an input port, but cache its contents in |
| 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." |
| 165 | (let ((file (cache-file-for-uri uri))) |
| 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 | |
| 178 | ;; Update the cache and return an input port. |
| 179 | (guard (c ((http-get-error? c) |
| 180 | (if (= 304 (http-get-error-code c)) ;"Not Modified" |
| 181 | (begin |
| 182 | (utime file) ;update FILE's mtime |
| 183 | cache-port) |
| 184 | (raise c)))) |
| 185 | (let ((port (http-fetch uri #:text? text? |
| 186 | #:headers headers))) |
| 187 | (cache-miss uri) |
| 188 | (mkdir-p (dirname file)) |
| 189 | (when cache-port |
| 190 | (close-port cache-port)) |
| 191 | (with-atomic-file-output file |
| 192 | (cut write-cache port <>)) |
| 193 | (close-port port) |
| 194 | (open-input-file file)))) |
| 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) |
| 206 | (update-cache port) |
| 207 | port))) |
| 208 | (lambda args |
| 209 | (if (= ENOENT (system-error-errno args)) |
| 210 | (update-cache #f) |
| 211 | (apply throw args)))))) |
| 212 | |
| 213 | ;;; http-client.scm ends here |