diff options
Diffstat (limited to 'guix/substitutes.scm')
-rw-r--r-- | guix/substitutes.scm | 366 |
1 files changed, 366 insertions, 0 deletions
diff --git a/guix/substitutes.scm b/guix/substitutes.scm new file mode 100644 index 0000000000..dc94ccc8e4 --- /dev/null +++ b/guix/substitutes.scm @@ -0,0 +1,366 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> +;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> +;;; Copyright © 2020 Christopher Baines <mail@cbaines.net> +;;; +;;; 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 +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; 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 <http://www.gnu.org/licenses/>. + +(define-module (guix substitutes) + #:use-module (guix narinfo) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix combinators) + #:use-module (guix config) + #:use-module (guix records) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (gcrypt hash) + #:use-module (guix base32) + #:use-module (guix base64) + #:use-module (guix cache) + #:use-module (gcrypt pk-crypto) + #:use-module (guix pki) + #:use-module ((guix build utils) #:select (mkdir-p dump-port)) + #:use-module ((guix build download) + #:select ((open-connection-for-uri + . guix:open-connection-for-uri))) + #:use-module (guix progress) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 vlist) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #: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 (web uri) + #:use-module (web request) + #:use-module (web response) + #:use-module (guix http-client) + #:export (%narinfo-cache-directory + + call-with-connection-error-handling + + lookup-narinfos + lookup-narinfos/diverse)) + +(define %narinfo-ttl + ;; Number of seconds during which cached narinfo lookups are considered + ;; valid for substitute servers that do not advertise a TTL via the + ;; 'Cache-Control' response header. + (* 36 3600)) + +(define %narinfo-negative-ttl + ;; Likewise, but for negative lookups---i.e., cached lookup failures (404). + (* 1 3600)) + +(define %narinfo-transient-error-ttl + ;; Likewise, but for transient errors such as 504 ("Gateway timeout"). + (* 10 60)) + +(define %narinfo-cache-directory + ;; A local cache of narinfos, to avoid going to the network. Most of the + ;; time, 'guix substitute' is called by guix-daemon as root and stores its + ;; cached data in /var/guix/…. However, when invoked from 'guix challenge' + ;; as a user, it stores its cache in ~/.cache. + (if (zero? (getuid)) + (or (and=> (getenv "XDG_CACHE_HOME") + (cut string-append <> "/guix/substitute")) + (string-append %state-directory "/substitute/cache")) + (string-append (cache-directory #:ensure? #f) "/substitute"))) + +(define (narinfo-cache-file cache-url path) + "Return the name of the local file that contains an entry for PATH. The +entry is stored in a sub-directory specific to CACHE-URL." + ;; The daemon does not sanitize its input, so PATH could be something like + ;; "/gnu/store/foo". Gracefully handle that. + (match (store-path-hash-part path) + (#f + (leave (G_ "'~a' does not name a store item~%") path)) + ((? string? hash-part) + (string-append %narinfo-cache-directory "/" + (bytevector->base32-string (sha256 (string->utf8 cache-url))) + "/" hash-part)))) + +(define (cache-narinfo! cache-url path narinfo ttl) + "Cache locally NARNIFO for PATH, which originates from CACHE-URL, with the +given TTL (a number of seconds or #f). NARINFO may be #f, in which case it +indicates that PATH is unavailable at CACHE-URL." + (define now + (current-time time-monotonic)) + + (define (cache-entry cache-uri narinfo) + `(narinfo (version 2) + (cache-uri ,cache-uri) + (date ,(time-second now)) + (ttl ,(or ttl + (if narinfo %narinfo-ttl %narinfo-negative-ttl))) + (value ,(and=> narinfo narinfo->string)))) + + (let ((file (narinfo-cache-file cache-url path))) + (mkdir-p (dirname file)) + (with-atomic-file-output file + (lambda (out) + (write (cache-entry cache-url narinfo) out)))) + + narinfo) + +(define %unreachable-hosts + ;; Set of names of unreachable hosts. + (make-hash-table)) + +(define* (call-with-connection-error-handling uri proc) + "Call PROC, and catch if a connection fails, print a warning and return #f." + (define host + (uri-host uri)) + + (catch #t + proc + (match-lambda* + (('getaddrinfo-error error) + (unless (hash-ref %unreachable-hosts host) + (hash-set! %unreachable-hosts host #t) ;warn only once + (warning (G_ "~a: host not found: ~a~%") + host (gai-strerror error))) + #f) + (('system-error . args) + (unless (hash-ref %unreachable-hosts host) + (hash-set! %unreachable-hosts host #t) + (warning (G_ "~a: connection failed: ~a~%") host + (strerror + (system-error-errno `(system-error ,@args))))) + #f) + (args + (apply throw args))))) + +(define (narinfo-request cache-url path) + "Return an HTTP request for the narinfo of PATH at CACHE-URL." + (let ((url (string-append cache-url "/" (store-path-hash-part path) + ".narinfo")) + (headers '((User-Agent . "GNU Guile")))) + (build-request (string->uri url) #:method 'GET #:headers headers))) + +(define (narinfo-from-file file url) + "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f +if file doesn't exist, and the narinfo otherwise." + (catch 'system-error + (lambda () + (call-with-input-file file + (cut read-narinfo <> url))) + (lambda args + (if (= ENOENT (system-error-errno args)) + #f + (apply throw args))))) + +(define* (fetch-narinfos url paths + #:key (open-connection guix:open-connection-for-uri)) + "Retrieve all the narinfos for PATHS from the cache at URL and return them." + (define update-progress! + (let ((done 0) + (total (length paths))) + (lambda () + (display "\r\x1b[K" (current-error-port)) ;erase current line + (force-output (current-error-port)) + (format (current-error-port) + (G_ "updating substitutes from '~a'... ~5,1f%") + url (* 100. (/ done total))) + (set! done (+ 1 done))))) + + (define hash-part->path + (let ((mapping (fold (lambda (path result) + (vhash-cons (store-path-hash-part path) path + result)) + vlist-null + paths))) + (lambda (hash) + (match (vhash-assoc hash mapping) + (#f #f) + ((_ . path) path))))) + + (define (read-to-eof port) + "Read from PORT until EOF is reached. The data are discarded." + (dump-port port (%make-void-port "w"))) + + (define (handle-narinfo-response request response port result) + (let* ((code (response-code response)) + (len (response-content-length response)) + (cache (response-cache-control response)) + (ttl (and cache (assoc-ref cache 'max-age)))) + (update-progress!) + + ;; Make sure to read no more than LEN bytes since subsequent bytes may + ;; belong to the next response. + (if (= code 200) ; hit + (let ((narinfo (read-narinfo port url #:size len))) + (if (string=? (dirname (narinfo-path narinfo)) + (%store-prefix)) + (begin + (cache-narinfo! url (narinfo-path narinfo) narinfo ttl) + (cons narinfo result)) + result)) + (let* ((path (uri-path (request-uri request))) + (hash-part (basename + (string-drop-right path 8)))) ;drop ".narinfo" + (if len + (get-bytevector-n port len) + (read-to-eof port)) + (cache-narinfo! url (hash-part->path hash-part) #f + (if (or (= 404 code) (= 202 code)) + ttl + %narinfo-transient-error-ttl)) + result)))) + + (define (do-fetch uri) + (case (and=> uri uri-scheme) + ((http https) + ;; Note: Do not check HTTPS server certificates to avoid depending + ;; on the X.509 PKI. We can do it because we authenticate + ;; narinfos, which provides a much stronger guarantee. + (let* ((requests (map (cut narinfo-request url <>) paths)) + (result (begin + (update-progress!) + (call-with-connection-error-handling + uri + (lambda () + (http-multiple-get uri + handle-narinfo-response '() + requests + #:open-connection open-connection + #:verify-certificate? #f)))))) + (newline (current-error-port)) + result)) + ((file #f) + (let* ((base (string-append (uri-path uri) "/")) + (files (map (compose (cut string-append base <> ".narinfo") + store-path-hash-part) + paths))) + (filter-map (cut narinfo-from-file <> url) files))) + (else + (leave (G_ "~s: unsupported server URI scheme~%") + (if uri (uri-scheme uri) url))))) + + (do-fetch (string->uri url))) + +(define (cached-narinfo cache-url path) + "Check locally if we have valid info about PATH coming from CACHE-URL. +Return two values: a Boolean indicating whether we have valid cached info, and +that info, which may be either #f (when PATH is unavailable) or the narinfo +for PATH." + (define now + (current-time time-monotonic)) + + (define cache-file + (narinfo-cache-file cache-url path)) + + (catch 'system-error + (lambda () + (call-with-input-file cache-file + (lambda (p) + (match (read p) + (('narinfo ('version 2) + ('cache-uri cache-uri) + ('date date) ('ttl ttl) ('value #f)) + ;; A cached negative lookup. + (if (obsolete? date now ttl) + (values #f #f) + (values #t #f))) + (('narinfo ('version 2) + ('cache-uri cache-uri) + ('date date) ('ttl ttl) ('value value)) + ;; A cached positive lookup + (if (obsolete? date now ttl) + (values #f #f) + (values #t (string->narinfo value cache-uri)))) + (('narinfo ('version v) _ ...) + (values #f #f)))))) + (lambda _ + (values #f #f)))) + +(define* (lookup-narinfos cache paths + #:key (open-connection guix:open-connection-for-uri)) + "Return the narinfos for PATHS, invoking the server at CACHE when no +information is available locally." + (let-values (((cached missing) + (fold2 (lambda (path cached missing) + (let-values (((valid? value) + (cached-narinfo cache path))) + (if valid? + (if value + (values (cons value cached) missing) + (values cached missing)) + (values cached (cons path missing))))) + '() + '() + paths))) + (if (null? missing) + cached + (let ((missing (fetch-narinfos cache missing + #:open-connection open-connection))) + (append cached (or missing '())))))) + +(define* (lookup-narinfos/diverse caches paths authorized? + #:key (open-connection + guix:open-connection-for-uri)) + "Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order. +That is, when a cache lacks an AUTHORIZED? narinfo, look it up in the next +cache, and so on. + +Return a list of narinfos for PATHS or a subset thereof. The returned +narinfos are either AUTHORIZED?, or they claim a hash that matches an +AUTHORIZED? narinfo." + (define (select-hit result) + (lambda (path) + (match (vhash-fold* cons '() path result) + ((one) + one) + ((several ..1) + (let ((authorized (find authorized? (reverse several)))) + (and authorized + (find (cut equivalent-narinfo? <> authorized) + several))))))) + + (let loop ((caches caches) + (paths paths) + (result vlist-null) ;path->narinfo vhash + (hits '())) ;paths + (match paths + (() ;we're done + ;; Now iterate on all the HITS, and return exactly one match for each + ;; hit: the first narinfo that is authorized, or that has the same hash + ;; as an authorized narinfo, in the order of CACHES. + (filter-map (select-hit result) hits)) + (_ + (match caches + ((cache rest ...) + (let* ((narinfos (lookup-narinfos cache paths + #:open-connection open-connection)) + (definite (map narinfo-path (filter authorized? narinfos))) + (missing (lset-difference string=? paths definite))) ;XXX: perf + (loop rest missing + (fold vhash-cons result + (map narinfo-path narinfos) narinfos) + (append definite hits)))) + (() ;that's it + (filter-map (select-hit result) hits))))))) + +;;; substitutes.scm ends here |