You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

210 lines
8.2 KiB

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <>
;;; Copyright © 2015 Mark H Weaver <>
;;; Copyright © 2012, 2015 Free Software Foundation, Inc.
;;; Copyright © 2017 Tobias Geerinckx-Rice <>
;;; This file is part of GNU Guix.
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; GNU General Public License for more details.
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <>.
(define-module (guix http-client)
#:use-module (web uri)
#:use-module ((web client) #:hide (open-socket-for-uri))
#:use-module (web response)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-34)
#:use-module (srfi srfi-35)
#:use-module (ice-9 match)
#:use-module (ice-9 binary-ports)
#:use-module (rnrs bytevectors)
#:use-module (guix ui)
#:use-module (guix utils)
#:use-module (guix base64)
#:autoload (gcrypt hash) (sha256)
#:use-module ((guix build utils)
#:select (mkdir-p dump-port))
#:use-module ((guix build download)
#:select (open-socket-for-uri
. guix:open-connection-for-uri)
#:re-export (open-socket-for-uri)
#:export (&http-get-error
;;; Commentary:
;;; HTTP client portable among Guile versions, and with proper error condition
;;; reporting.
;;; Code:
;; HTTP GET error.
(define-condition-type &http-get-error &error
(uri http-get-error-uri) ; URI
(code http-get-error-code) ; integer
(reason http-get-error-reason)) ; string
(define* (http-fetch uri #:key port (text? #f) (buffered? #t)
keep-alive? (verify-certificate? #t)
(headers '((user-agent . "GNU Guile"))))
"Return an input port containing the data at URI, and the expected number of
bytes available or #f. If TEXT? is true, the data at URI is considered to be
textual. Follow any HTTP redirection. When BUFFERED? is #f, return an
unbuffered port, suitable for use in `filtered-port'. When KEEP-ALIVE? is
true, send a 'Connection: keep-alive' HTTP header, in which case PORT may be
reused for future HTTP requests. HEADERS is an alist of extra HTTP headers.
When VERIFY-CERTIFICATE? is true, verify HTTPS server certificates.
Raise an '&http-get-error' condition if downloading fails."
(let loop ((uri (if (string? uri)
(string->uri uri)
(let ((port (or port (guix:open-connection-for-uri uri
(headers (match (uri-userinfo uri)
((? string? str)
(cons (cons 'Authorization
(string-append "Basic "
(string->utf8 str))))
(_ headers))))
(unless (or buffered? (not (file-port? port)))
(setvbuf port _IONBF))
(let*-values (((resp data)
(http-get uri #:streaming? #t #:port port
#:keep-alive? #t
#:headers headers))
(response-code resp)))
(case code
(values data (response-content-length resp)))
((301 ; moved permanently
302 ; found (redirection)
303 ; see other
307 ; temporary redirection
308) ; permanent redirection
(let ((uri (resolve-uri-reference (response-location resp) uri)))
(close-port port)
(format (current-error-port) (G_ "following redirection to `~a'...~%")
(uri->string uri))
(loop uri)))
(raise (condition (&http-get-error
(uri uri)
(code code)
(reason (response-reason-phrase resp)))
(G_ "~a: HTTP download failed: ~a (~s)")
(uri->string uri) code
(response-reason-phrase resp))))))))))))
;;; Caching.
(define %http-cache-ttl
;; Time-to-live in seconds of the HTTP cache of in ~/.cache/guix.
(* 3600 (or (and=> (getenv "GUIX_HTTP_CACHE_TTL")
(define (cache-file-for-uri uri)
"Return the name of the file in the cache corresponding to URI."
(let ((digest (sha256 (string->utf8 (uri->string uri)))))
;; Use the "URL" alphabet because it does not contain "/".
(string-append (cache-directory) "/http/"
(base64-encode digest 0 (bytevector-length digest)
#f #f base64url-alphabet))))
(define* (http-fetch/cached uri #:key (ttl (%http-cache-ttl)) text?
(write-cache dump-port)
(cache-miss (const #t)))
"Like 'http-fetch', return an input port, but cache its contents in
~/.cache/guix. The cache remains valid for TTL seconds.
Call WRITE-CACHE with the HTTP input port and the cache output port to write
the data to cache. Call CACHE-MISS with URI just before fetching data from
(let ((file (cache-file-for-uri uri)))
(define (update-cache cache-port)
(define cache-time
(and cache-port
(stat:mtime (stat cache-port))))
(define headers
`((user-agent . "GNU Guile")
,@(if cache-time
. ,(time-utc->date (make-time time-utc 0 cache-time))))
;; Update the cache and return an input port.
(guard (c ((http-get-error? c)
(if (= 304 (http-get-error-code c)) ;"Not Modified"
(utime file) ;update FILE's mtime
(raise c))))
(let ((port (http-fetch uri #:text? text?
#:headers headers)))
(cache-miss uri)
(mkdir-p (dirname file))
(when cache-port
(close-port cache-port))
(with-atomic-file-output file
(cut write-cache port <>))
(close-port port)
(open-input-file file))))
(define (old? port)
;; Return true if PORT has passed TTL.
(let* ((s (stat port))
(now (current-time time-utc)))
(< (+ (stat:mtime s) ttl) (time-second now))))
(catch 'system-error
(lambda ()
(let ((port (open-input-file file)))
(if (old? port)
(update-cache port)
(lambda args
(if (= ENOENT (system-error-errno args))
(update-cache #f)
(apply throw args))))))
;;; http-client.scm ends here