ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix: Split (guix substitutes) from (guix scripts substitute).

Browse source 
This means there's a module for working with substitutes, rather than all the
code sitting in the script. The need for this can be seen with the weather and
challenge scripts, that now don't have to use code from the substitute script,
but can instead use the substitute module.

The separation here between the actual functionality of the substitute script
and the underlying functionality used both there and elsewhere should make
maintenance easier moving forward.

This commit just moves code, none of the code should have been changed
significantly.

* guix/scripts/substitute.scm (%narinfo-cache-directory, %narinfo-ttl,
%narinfo-negative-ttl, %narinfo-transient-error-ttl, %unreachable-hosts): Move
variables to guix/substitutes.scm.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
read-to-eof, call-with-connection-error-handling, fetch-narinfos,
lookup-narinfos, lookup-narinfos/diverse): Move procedures to
guix/substitutes.scm.
* guix/substitutes.scm: New file.
* Makefile.am: Add it.
* guix/narinfo.scm: Remove redundant module.
* guix/scripts/challenge.scm: Change (guix scripts substitute) to (guix
substitutes).
* guix/scripts/weather.scm: Change (guix scripts substitute) to (guix
substitutes).
This commit is contained in:
Christopher Baines 2021-02-22 22:42:03 +00:00
parent 23c6be1d3d
commit 112692c0d5
No known key found for this signature in database
GPG key ID: 5E28A33B0B84F577
6 changed files with 376 additions and 308 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -114,6 +114,7 @@ MODULES = \
guix/channels.scm \ guix/channels.scm \
guix/gnu-maintenance.scm \ guix/gnu-maintenance.scm \
guix/self.scm \ guix/self.scm \
guix/substitutes.scm \
guix/upstream.scm \ guix/upstream.scm \
guix/licenses.scm \ guix/licenses.scm \
guix/lint.scm \ guix/lint.scm \

1
guix/narinfo.scm
View file

@ -25,7 +25,6 @@ (define-module (guix narinfo)
#:use-module (guix base64) #:use-module (guix base64)
#:use-module (guix records) #:use-module (guix records)
#:use-module (guix diagnostics) #:use-module (guix diagnostics)
#:use-module (guix scripts substitute)
#:use-module (gcrypt hash) #:use-module (gcrypt hash)
#:use-module (gcrypt pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)

2
guix/scripts/challenge.scm
View file

@ -27,7 +27,7 @@ (define-module (guix scripts challenge)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module ((guix progress) #:hide (dump-port*)) #:use-module ((guix progress) #:hide (dump-port*))
#:use-module (guix serialization) #:use-module (guix serialization)
#:use-module (guix scripts substitute) #:use-module (guix substitutes)
#:use-module (guix narinfo) #:use-module (guix narinfo)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:autoload (guix http-client) (http-fetch) #:autoload (guix http-client) (http-fetch)

312
guix/scripts/substitute.scm
View file

@ -24,6 +24,7 @@ (define-module (guix scripts substitute)
#:use-module (guix scripts) #:use-module (guix scripts)
#:use-module (guix narinfo) #:use-module (guix narinfo)
#:use-module (guix store) #:use-module (guix store)
#:use-module (guix substitutes)
#:use-module (guix utils) #:use-module (guix utils)
#:use-module (guix combinators) #:use-module (guix combinators)
#:use-module (guix config) #:use-module (guix config)
@ -39,40 +40,28 @@ (define-module (guix scripts substitute)
#:use-module (guix cache) #:use-module (guix cache)
#:use-module (gcrypt pk-crypto) #:use-module (gcrypt pk-crypto)
#:use-module (guix pki) #:use-module (guix pki)
#:use-module ((guix build utils) #:select (mkdir-p dump-port)) #:use-module ((guix build utils) #:select (mkdir-p))
#:use-module ((guix build download) #:use-module ((guix build download)
#:select (uri-abbreviation nar-uri-abbreviation #:select (uri-abbreviation nar-uri-abbreviation
(open-connection-for-uri (open-connection-for-uri
. guix:open-connection-for-uri) . guix:open-connection-for-uri)))
store-path-abbreviation byte-count->string))
#:autoload (gnutls) (error/invalid-session)
#:use-module (guix progress) #:use-module (guix progress)
#:use-module ((guix build syscalls) #:use-module ((guix build syscalls)
#:select (set-thread-name)) #:select (set-thread-name))
#:use-module (ice-9 rdelim) #:use-module (ice-9 rdelim)
#:use-module (ice-9 regex)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:use-module (ice-9 ftw) #:use-module (ice-9 ftw)
#:use-module (ice-9 binary-ports)
#:use-module (ice-9 vlist)
#:use-module (rnrs bytevectors) #:use-module (rnrs bytevectors)
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-19) #:use-module (srfi srfi-19)
#:use-module (srfi srfi-26) #:use-module (srfi srfi-26)
#:use-module (srfi srfi-34) #:use-module (srfi srfi-34)
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (web uri) #:use-module (web uri)
#:use-module (web http)
#:use-module (web request)
#:use-module (web response)
#:use-module (guix http-client) #:use-module (guix http-client)
#:export (lookup-narinfos #:export (%allow-unauthenticated-substitutes?
lookup-narinfos/diverse
%allow-unauthenticated-substitutes?
%error-to-file-descriptor-4? %error-to-file-descriptor-4?
substitute-urls substitute-urls
@ -89,16 +78,9 @@ (define-module (guix scripts substitute)
;;; ;;;
;;; Code: ;;; Code:
(define %narinfo-cache-directory (define %narinfo-expired-cache-entry-removal-delay
;; A local cache of narinfos, to avoid going to the network. Most of the ;; How often we want to remove files corresponding to expired cache entries.
;; time, 'guix substitute' is called by guix-daemon as root and stores its (* 7 24 3600))
;; 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 (warn-about-missing-authentication) (define (warn-about-missing-authentication)
(warning (G_ "authentication and authorization of substitutes \ (warning (G_ "authentication and authorization of substitutes \
@ -112,24 +94,6 @@ (define %allow-unauthenticated-substitutes?
(and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES") (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
(cut string-ci=? <> "yes")))) (cut string-ci=? <> "yes"))))
(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-expired-cache-entry-removal-delay
;; How often we want to remove files corresponding to expired cache entries.
(* 7 24 3600))
(define %fetch-timeout (define %fetch-timeout
;; Number of seconds after which networking is considered "slow". ;; Number of seconds after which networking is considered "slow".
5) 5)
@ -169,84 +133,6 @@ (define-syntax-rule (with-timeout duration handler body ...)
(sigaction SIGALRM SIG_DFL) (sigaction SIGALRM SIG_DFL)
(apply values result))))) (apply values result)))))
(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 (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 (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 (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 (at-most max-length lst) (define (at-most max-length lst)
"If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise "If LST is shorter than MAX-LENGTH, return it and the empty list; otherwise
return its MAX-LENGTH first elements and its tail." return its MAX-LENGTH first elements and its tail."
@ -261,10 +147,6 @@ (define (at-most max-length lst)
(values (reverse result) lst) (values (reverse result) lst)
(loop (+ 1 len) tail (cons head result))))))) (loop (+ 1 len) tail (cons head result)))))))
(define (read-to-eof port)
"Read from PORT until EOF is reached. The data are discarded."
(dump-port port (%make-void-port "w")))
(define (narinfo-from-file file url) (define (narinfo-from-file file url)
"Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f "Attempt to read a narinfo from FILE, using URL as the cache URL. Return #f
if file doesn't exist, and the narinfo otherwise." if file doesn't exist, and the narinfo otherwise."
@ -277,186 +159,6 @@ (define (narinfo-from-file file url)
#f #f
(apply throw args))))) (apply throw args)))))
(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* (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 (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* (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)))))))
(define (lookup-narinfo caches path authorized?) (define (lookup-narinfo caches path authorized?)
"Return the narinfo for PATH in CACHES, or #f when no substitute for PATH "Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
was found." was found."

2
guix/scripts/weather.scm
View file

@ -32,7 +32,7 @@ (define-module (guix scripts weather)
#:use-module (guix gexp) #:use-module (guix gexp)
#:use-module ((guix build syscalls) #:select (terminal-columns)) #:use-module ((guix build syscalls) #:select (terminal-columns))
#:use-module ((guix build utils) #:select (every*)) #:use-module ((guix build utils) #:select (every*))
#:use-module (guix scripts substitute) #:use-module (guix substitutes)
#:use-module (guix narinfo) #:use-module (guix narinfo)
#:use-module (guix http-client) #:use-module (guix http-client)
#:use-module (guix ci) #:use-module (guix ci)

366
guix/substitutes.scm Normal file
View file

@ -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