2013-04-02 10:44:20 +02:00
|
|
|
|
;;; GNU Guix --- Functional package management for GNU
|
2016-03-09 18:34:04 +01:00
|
|
|
|
;;; Copyright © 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
2014-03-29 00:06:41 +01:00
|
|
|
|
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
|
2013-04-02 10:44:20 +02:00
|
|
|
|
;;;
|
|
|
|
|
;;; 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/>.
|
|
|
|
|
|
2015-03-25 10:34:27 +01:00
|
|
|
|
(define-module (guix scripts substitute)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
#:use-module (guix ui)
|
2016-03-17 21:57:15 +01:00
|
|
|
|
#:use-module ((guix store) #:hide (close-connection))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
#:use-module (guix utils)
|
2013-04-12 17:30:27 +02:00
|
|
|
|
#:use-module (guix config)
|
2013-05-12 15:46:16 +02:00
|
|
|
|
#:use-module (guix records)
|
Break module cycle involving (guix store) and (guix ui).
Before, there was a cycle along the lines of:
(guix store) -> (guix nar) -> (guix ui) -> (guix store)
This caused problems, as discussed at:
http://lists.gnu.org/archive/html/guix-devel/2014-10/msg00109.html
This patch removes cycles in the (guix ...) modules.
* guix/nar.scm (&nar-error, &nar-read-error, dump, write-contents,
read-contents, %archive-version-1, write-file, restore-file): Move to...
* guix/serialization.scm: ... here.
* guix/store.scm: Remove dependency on (guix nar).
* guix/scripts/hash.scm, guix/scripts/offload.scm,
guix/scripts/substitute-binary.scm, tests/nar.scm, tests/store.scm,
tests/substitute-binary.scm: Adjust accordingly.
2014-10-09 23:46:13 +02:00
|
|
|
|
#:use-module (guix serialization)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
#:use-module (guix hash)
|
2015-07-13 15:52:29 +02:00
|
|
|
|
#:use-module (guix base32)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
#:use-module (guix base64)
|
|
|
|
|
#:use-module (guix pk-crypto)
|
|
|
|
|
#:use-module (guix pki)
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
#:use-module ((guix build utils) #:select (mkdir-p dump-port))
|
2013-06-20 23:41:11 +02:00
|
|
|
|
#:use-module ((guix build download)
|
2015-09-15 07:31:11 +02:00
|
|
|
|
#:select (progress-proc uri-abbreviation
|
2016-03-10 11:53:03 +01:00
|
|
|
|
open-connection-for-uri
|
2016-03-17 21:57:15 +01:00
|
|
|
|
close-connection
|
2015-09-15 07:31:11 +02:00
|
|
|
|
store-path-abbreviation byte-count->string))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
#:use-module (ice-9 rdelim)
|
|
|
|
|
#:use-module (ice-9 regex)
|
|
|
|
|
#:use-module (ice-9 match)
|
2013-04-12 17:30:27 +02:00
|
|
|
|
#:use-module (ice-9 format)
|
2013-04-20 15:12:24 +02:00
|
|
|
|
#:use-module (ice-9 ftw)
|
2013-06-20 23:41:11 +02:00
|
|
|
|
#:use-module (ice-9 binary-ports)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
#:use-module (rnrs io ports)
|
|
|
|
|
#:use-module (rnrs bytevectors)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
#:use-module (srfi srfi-1)
|
|
|
|
|
#:use-module (srfi srfi-9)
|
|
|
|
|
#:use-module (srfi srfi-11)
|
2013-04-15 23:42:27 +02:00
|
|
|
|
#:use-module (srfi srfi-19)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
#:use-module (srfi srfi-26)
|
2014-03-01 15:38:11 +01:00
|
|
|
|
#:use-module (srfi srfi-34)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
#:use-module (srfi srfi-35)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
#:use-module (web uri)
|
2016-03-10 11:53:03 +01:00
|
|
|
|
#:use-module (web http)
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
#:use-module (web request)
|
|
|
|
|
#:use-module (web response)
|
2013-07-14 16:35:37 +02:00
|
|
|
|
#:use-module (guix http-client)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
#:export (narinfo-signature->canonical-sexp
|
2015-10-19 23:12:34 +02:00
|
|
|
|
|
|
|
|
|
narinfo?
|
|
|
|
|
narinfo-path
|
|
|
|
|
narinfo-uri
|
|
|
|
|
narinfo-uri-base
|
|
|
|
|
narinfo-compression
|
|
|
|
|
narinfo-file-hash
|
|
|
|
|
narinfo-file-size
|
|
|
|
|
narinfo-hash
|
|
|
|
|
narinfo-size
|
|
|
|
|
narinfo-references
|
|
|
|
|
narinfo-deriver
|
|
|
|
|
narinfo-system
|
|
|
|
|
narinfo-signature
|
|
|
|
|
|
|
|
|
|
narinfo-hash->sha256
|
|
|
|
|
assert-valid-narinfo
|
|
|
|
|
|
|
|
|
|
lookup-narinfos
|
2015-10-28 10:11:43 +01:00
|
|
|
|
lookup-narinfos/diverse
|
2014-03-29 00:06:41 +01:00
|
|
|
|
read-narinfo
|
|
|
|
|
write-narinfo
|
2015-03-25 10:34:27 +01:00
|
|
|
|
guix-substitute))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
|
|
|
|
;;; Comment:
|
|
|
|
|
;;;
|
|
|
|
|
;;; This is the "binary substituter". It is invoked by the daemon do check
|
|
|
|
|
;;; for the existence of available "substitutes" (pre-built binaries), and to
|
|
|
|
|
;;; actually use them as a substitute to building things locally.
|
|
|
|
|
;;;
|
|
|
|
|
;;; If possible, substitute a binary for the requested store path, using a Nix
|
|
|
|
|
;;; "binary cache". This program implements the Nix "substituter" protocol.
|
|
|
|
|
;;;
|
|
|
|
|
;;; Code:
|
|
|
|
|
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(define %narinfo-cache-directory
|
|
|
|
|
;; A local cache of narinfos, to avoid going to the network.
|
|
|
|
|
(or (and=> (getenv "XDG_CACHE_HOME")
|
2015-03-25 10:44:19 +01:00
|
|
|
|
(cut string-append <> "/guix/substitute"))
|
|
|
|
|
(string-append %state-directory "/substitute/cache")))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
|
2014-03-29 00:06:41 +01:00
|
|
|
|
(define %allow-unauthenticated-substitutes?
|
|
|
|
|
;; Whether to allow unchecked substitutes. This is useful for testing
|
|
|
|
|
;; purposes, and should be avoided otherwise.
|
|
|
|
|
(and (and=> (getenv "GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES")
|
|
|
|
|
(cut string-ci=? <> "yes"))
|
|
|
|
|
(begin
|
|
|
|
|
(warning (_ "authentication and authorization of substitutes \
|
|
|
|
|
disabled!~%"))
|
|
|
|
|
#t)))
|
|
|
|
|
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(define %narinfo-ttl
|
|
|
|
|
;; Number of seconds during which cached narinfo lookups are considered
|
2016-03-16 15:31:18 +01:00
|
|
|
|
;; valid for substitute servers that do not advertise a TTL via the
|
|
|
|
|
;; 'Cache-Control' response header.
|
2015-05-04 15:38:30 +02:00
|
|
|
|
(* 36 3600))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
|
|
|
|
|
(define %narinfo-negative-ttl
|
2016-03-17 21:49:05 +01:00
|
|
|
|
;; Likewise, but for negative lookups---i.e., cached lookup failures (404).
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(* 3 3600))
|
|
|
|
|
|
2016-03-17 21:49:05 +01:00
|
|
|
|
(define %narinfo-transient-error-ttl
|
|
|
|
|
;; Likewise, but for transient errors such as 504 ("Gateway timeout").
|
|
|
|
|
(* 10 60))
|
|
|
|
|
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(define %narinfo-expired-cache-entry-removal-delay
|
|
|
|
|
;; How often we want to remove files corresponding to expired cache entries.
|
|
|
|
|
(* 7 24 3600))
|
|
|
|
|
|
2013-07-11 22:42:41 +02:00
|
|
|
|
(define fields->alist
|
|
|
|
|
;; The narinfo format is really just like recutils.
|
|
|
|
|
recutils->alist)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2013-06-18 00:11:40 +02:00
|
|
|
|
(define %fetch-timeout
|
|
|
|
|
;; Number of seconds after which networking is considered "slow".
|
2013-07-11 22:22:22 +02:00
|
|
|
|
5)
|
2013-06-18 00:11:40 +02:00
|
|
|
|
|
2013-06-29 22:10:06 +02:00
|
|
|
|
(define %random-state
|
|
|
|
|
(seed->random-state (+ (ash (cdr (gettimeofday)) 32) (getpid))))
|
|
|
|
|
|
2013-06-18 00:11:40 +02:00
|
|
|
|
(define-syntax-rule (with-timeout duration handler body ...)
|
|
|
|
|
"Run BODY; when DURATION seconds have expired, call HANDLER, and run BODY
|
|
|
|
|
again."
|
|
|
|
|
(begin
|
|
|
|
|
(sigaction SIGALRM
|
|
|
|
|
(lambda (signum)
|
|
|
|
|
(sigaction SIGALRM SIG_DFL)
|
|
|
|
|
handler))
|
|
|
|
|
(alarm duration)
|
|
|
|
|
(call-with-values
|
|
|
|
|
(lambda ()
|
|
|
|
|
(let try ()
|
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
body ...)
|
|
|
|
|
(lambda args
|
2013-11-14 01:09:07 +01:00
|
|
|
|
;; Before Guile v2.0.9-39-gfe51c7b, the SIGALRM triggers EINTR
|
|
|
|
|
;; because of the bug at
|
2013-06-29 22:10:06 +02:00
|
|
|
|
;; <http://lists.gnu.org/archive/html/guile-devel/2013-06/msg00050.html>.
|
|
|
|
|
;; When that happens, try again. Note: SA_RESTART cannot be
|
|
|
|
|
;; used because of <http://bugs.gnu.org/14640>.
|
2013-06-18 00:11:40 +02:00
|
|
|
|
(if (= EINTR (system-error-errno args))
|
2013-06-29 22:10:06 +02:00
|
|
|
|
(begin
|
|
|
|
|
;; Wait a little to avoid bursts.
|
|
|
|
|
(usleep (random 3000000 %random-state))
|
|
|
|
|
(try))
|
2013-06-18 00:11:40 +02:00
|
|
|
|
(apply throw args))))))
|
|
|
|
|
(lambda result
|
|
|
|
|
(alarm 0)
|
|
|
|
|
(sigaction SIGALRM SIG_DFL)
|
|
|
|
|
(apply values result)))))
|
|
|
|
|
|
2016-03-14 17:09:46 +01:00
|
|
|
|
(define* (fetch uri #:key (buffered? #t) (timeout? #t))
|
2013-04-12 17:30:27 +02:00
|
|
|
|
"Return a binary input port to URI and the number of bytes it's expected to
|
2016-03-14 17:09:46 +01:00
|
|
|
|
provide."
|
2013-04-02 10:44:20 +02:00
|
|
|
|
(case (uri-scheme uri)
|
|
|
|
|
((file)
|
2013-08-22 17:14:20 +02:00
|
|
|
|
(let ((port (open-file (uri-path uri)
|
|
|
|
|
(if buffered? "rb" "r0b"))))
|
2013-04-12 17:30:27 +02:00
|
|
|
|
(values port (stat:size (stat port)))))
|
2016-03-10 11:53:03 +01:00
|
|
|
|
((http https)
|
2014-03-01 15:38:11 +01:00
|
|
|
|
(guard (c ((http-get-error? c)
|
2016-03-14 17:09:46 +01:00
|
|
|
|
(leave (_ "download from '~a' failed: ~a, ~s~%")
|
|
|
|
|
(uri->string (http-get-error-uri c))
|
|
|
|
|
(http-get-error-code c)
|
|
|
|
|
(http-get-error-reason c))))
|
2014-03-01 15:38:11 +01:00
|
|
|
|
;; Test this with:
|
|
|
|
|
;; sudo tc qdisc add dev eth0 root netem delay 1500ms
|
|
|
|
|
;; and then cancel with:
|
|
|
|
|
;; sudo tc qdisc del dev eth0 root
|
|
|
|
|
(let ((port #f))
|
2015-05-07 21:51:30 +02:00
|
|
|
|
(with-timeout (if timeout?
|
2014-03-01 15:38:11 +01:00
|
|
|
|
%fetch-timeout
|
|
|
|
|
0)
|
|
|
|
|
(begin
|
2014-11-27 21:20:11 +01:00
|
|
|
|
(warning (_ "while fetching ~a: server is somewhat slow~%")
|
2014-03-01 15:38:11 +01:00
|
|
|
|
(uri->string uri))
|
|
|
|
|
(warning (_ "try `--no-substitutes' if the problem persists~%"))
|
|
|
|
|
|
|
|
|
|
;; Before Guile v2.0.9-39-gfe51c7b, EINTR was reported to the user,
|
|
|
|
|
;; and thus PORT had to be closed and re-opened. This is not the
|
|
|
|
|
;; case afterward.
|
|
|
|
|
(unless (or (guile-version>? "2.0.9")
|
|
|
|
|
(version>? (version) "2.0.9.39"))
|
|
|
|
|
(when port
|
2016-03-17 21:57:15 +01:00
|
|
|
|
(close-connection port))))
|
2014-03-01 15:38:11 +01:00
|
|
|
|
(begin
|
|
|
|
|
(when (or (not port) (port-closed? port))
|
2016-03-10 11:53:03 +01:00
|
|
|
|
(set! port (open-connection-for-uri uri))
|
|
|
|
|
(unless (or buffered? (not (file-port? port)))
|
2015-05-06 10:31:11 +02:00
|
|
|
|
(setvbuf port _IONBF)))
|
2016-03-09 18:34:04 +01:00
|
|
|
|
(http-fetch uri #:text? #f #:port port))))))
|
|
|
|
|
(else
|
|
|
|
|
(leave (_ "unsupported substitute URI scheme: ~a~%")
|
|
|
|
|
(uri->string uri)))))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2015-07-13 11:38:31 +02:00
|
|
|
|
(define-record-type <cache-info>
|
|
|
|
|
(%make-cache-info url store-directory wants-mass-query?)
|
|
|
|
|
cache-info?
|
|
|
|
|
(url cache-info-url)
|
|
|
|
|
(store-directory cache-info-store-directory)
|
|
|
|
|
(wants-mass-query? cache-info-wants-mass-query?))
|
|
|
|
|
|
|
|
|
|
(define (download-cache-info url)
|
2016-03-14 22:44:59 +01:00
|
|
|
|
"Download the information for the cache at URL. On success, return a
|
|
|
|
|
<cache-info> object and a port on which to send further HTTP requests. On
|
|
|
|
|
failure, return #f and #f."
|
|
|
|
|
(define uri
|
|
|
|
|
(string->uri (string-append url "/nix-cache-info")))
|
|
|
|
|
|
|
|
|
|
(define (read-cache-info port)
|
|
|
|
|
(alist->record (fields->alist port)
|
|
|
|
|
(cut %make-cache-info url <...>)
|
|
|
|
|
'("StoreDir" "WantMassQuery")))
|
|
|
|
|
|
|
|
|
|
(catch #t
|
|
|
|
|
(lambda ()
|
|
|
|
|
(case (uri-scheme uri)
|
|
|
|
|
((file)
|
|
|
|
|
(values (call-with-input-file (uri-path uri)
|
|
|
|
|
read-cache-info)
|
|
|
|
|
#f))
|
|
|
|
|
((http https)
|
|
|
|
|
(let ((port (open-connection-for-uri uri
|
|
|
|
|
#:timeout %fetch-timeout)))
|
|
|
|
|
(guard (c ((http-get-error? c)
|
|
|
|
|
(warning (_ "while fetching '~a': ~a (~s)~%")
|
|
|
|
|
(uri->string (http-get-error-uri c))
|
|
|
|
|
(http-get-error-code c)
|
|
|
|
|
(http-get-error-reason c))
|
2016-03-17 21:57:15 +01:00
|
|
|
|
(close-connection port)
|
2016-03-14 22:44:59 +01:00
|
|
|
|
(warning (_ "ignoring substitute server at '~s'~%") url)
|
|
|
|
|
(values #f #f)))
|
|
|
|
|
(values (read-cache-info (http-fetch uri
|
|
|
|
|
#:port port
|
|
|
|
|
#:keep-alive? #t))
|
|
|
|
|
port))))))
|
|
|
|
|
(lambda (key . args)
|
|
|
|
|
(case key
|
|
|
|
|
((getaddrinfo-error system-error)
|
|
|
|
|
;; Silently ignore the error: probably due to lack of network access.
|
|
|
|
|
(values #f #f))
|
|
|
|
|
(else
|
|
|
|
|
(apply throw key args))))))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2015-07-13 11:38:31 +02:00
|
|
|
|
|
2013-04-02 10:44:20 +02:00
|
|
|
|
(define-record-type <narinfo>
|
2014-03-26 23:31:31 +01:00
|
|
|
|
(%make-narinfo path uri uri-base compression file-hash file-size nar-hash nar-size
|
2014-03-29 00:06:41 +01:00
|
|
|
|
references deriver system signature contents)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
narinfo?
|
|
|
|
|
(path narinfo-path)
|
2013-04-12 17:30:27 +02:00
|
|
|
|
(uri narinfo-uri)
|
2014-03-26 23:31:31 +01:00
|
|
|
|
(uri-base narinfo-uri-base) ; URI of the cache it originates from
|
2013-04-02 10:44:20 +02:00
|
|
|
|
(compression narinfo-compression)
|
|
|
|
|
(file-hash narinfo-file-hash)
|
|
|
|
|
(file-size narinfo-file-size)
|
|
|
|
|
(nar-hash narinfo-hash)
|
|
|
|
|
(nar-size narinfo-size)
|
|
|
|
|
(references narinfo-references)
|
|
|
|
|
(deriver narinfo-deriver)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
(system narinfo-system)
|
|
|
|
|
(signature narinfo-signature) ; canonical sexp
|
|
|
|
|
;; The original contents of a narinfo file. This field is needed because we
|
|
|
|
|
;; want to preserve the exact textual representation for verification purposes.
|
|
|
|
|
;; See <https://lists.gnu.org/archive/html/guix-devel/2014-02/msg00340.html>
|
|
|
|
|
;; for more information.
|
|
|
|
|
(contents narinfo-contents))
|
|
|
|
|
|
2015-10-19 23:12:34 +02:00
|
|
|
|
(define (narinfo-hash->sha256 hash)
|
|
|
|
|
"If the string HASH denotes a sha256 hash, return it as a bytevector.
|
|
|
|
|
Otherwise return #f."
|
|
|
|
|
(and (string-prefix? "sha256:" hash)
|
|
|
|
|
(nix-base32-string->bytevector (string-drop hash 7))))
|
|
|
|
|
|
2014-03-29 00:06:41 +01:00
|
|
|
|
(define (narinfo-signature->canonical-sexp str)
|
|
|
|
|
"Return the value of a narinfo's 'Signature' field as a canonical sexp."
|
|
|
|
|
(match (string-split str #\;)
|
|
|
|
|
((version _ sig)
|
|
|
|
|
(let ((maybe-number (string->number version)))
|
|
|
|
|
(cond ((not (number? maybe-number))
|
2015-01-09 01:10:31 +01:00
|
|
|
|
(leave (_ "signature version must be a number: ~s~%")
|
2014-03-29 00:06:41 +01:00
|
|
|
|
version))
|
|
|
|
|
;; Currently, there are no other versions.
|
|
|
|
|
((not (= 1 maybe-number))
|
|
|
|
|
(leave (_ "unsupported signature version: ~a~%")
|
|
|
|
|
maybe-number))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(else
|
|
|
|
|
(let ((signature (utf8->string (base64-decode sig))))
|
|
|
|
|
(catch 'gcry-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(string->canonical-sexp signature))
|
2014-04-22 11:41:52 +02:00
|
|
|
|
(lambda (key proc err)
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(leave (_ "signature is not a valid \
|
|
|
|
|
s-expression: ~s~%")
|
|
|
|
|
signature))))))))
|
2014-03-29 00:06:41 +01:00
|
|
|
|
(x
|
|
|
|
|
(leave (_ "invalid format of the signature field: ~a~%") x))))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2014-03-29 00:06:41 +01:00
|
|
|
|
(define (narinfo-maker str cache-url)
|
|
|
|
|
"Return a narinfo constructor for narinfos originating from CACHE-URL. STR
|
|
|
|
|
must contain the original contents of a narinfo file."
|
2013-04-12 17:30:27 +02:00
|
|
|
|
(lambda (path url compression file-hash file-size nar-hash nar-size
|
2014-03-29 00:06:41 +01:00
|
|
|
|
references deriver system signature)
|
2013-04-12 17:30:27 +02:00
|
|
|
|
"Return a new <narinfo> object."
|
|
|
|
|
(%make-narinfo path
|
|
|
|
|
;; Handle the case where URL is a relative URL.
|
|
|
|
|
(or (string->uri url)
|
|
|
|
|
(string->uri (string-append cache-url "/" url)))
|
2014-03-26 23:31:31 +01:00
|
|
|
|
cache-url
|
2013-04-12 17:30:27 +02:00
|
|
|
|
|
|
|
|
|
compression file-hash
|
|
|
|
|
(and=> file-size string->number)
|
|
|
|
|
nar-hash
|
|
|
|
|
(and=> nar-size string->number)
|
|
|
|
|
(string-tokenize references)
|
|
|
|
|
(match deriver
|
|
|
|
|
((or #f "") #f)
|
|
|
|
|
(_ deriver))
|
2014-03-29 00:06:41 +01:00
|
|
|
|
system
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(false-if-exception
|
|
|
|
|
(and=> signature narinfo-signature->canonical-sexp))
|
2014-03-29 00:06:41 +01:00
|
|
|
|
str)))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(define* (assert-valid-signature narinfo signature hash
|
2014-03-29 00:06:41 +01:00
|
|
|
|
#:optional (acl (current-acl)))
|
2014-03-31 23:47:02 +02:00
|
|
|
|
"Bail out if SIGNATURE, a canonical sexp representing the signature of
|
|
|
|
|
NARINFO, doesn't match HASH, a bytevector containing the hash of NARINFO."
|
|
|
|
|
(let ((uri (uri->string (narinfo-uri narinfo))))
|
|
|
|
|
(signature-case (signature hash acl)
|
|
|
|
|
(valid-signature #t)
|
|
|
|
|
(invalid-signature
|
|
|
|
|
(leave (_ "invalid signature for '~a'~%") uri))
|
|
|
|
|
(hash-mismatch
|
|
|
|
|
(leave (_ "hash mismatch for '~a'~%") uri))
|
|
|
|
|
(unauthorized-key
|
|
|
|
|
(leave (_ "'~a' is signed with an unauthorized key~%") uri))
|
|
|
|
|
(corrupt-signature
|
|
|
|
|
(leave (_ "signature on '~a' is corrupt~%") uri)))))
|
2014-03-29 00:06:41 +01:00
|
|
|
|
|
2015-01-05 22:31:34 +01:00
|
|
|
|
(define* (read-narinfo port #:optional url
|
|
|
|
|
#:key size)
|
2014-03-29 00:06:41 +01:00
|
|
|
|
"Read a narinfo from PORT. If URL is true, it must be a string used to
|
2015-01-05 22:31:34 +01:00
|
|
|
|
build full URIs from relative URIs found while reading PORT. When SIZE is
|
|
|
|
|
true, read at most SIZE bytes from PORT; otherwise, read as much as possible.
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
|
|
|
|
|
No authentication and authorization checks are performed here!"
|
2015-01-05 22:31:34 +01:00
|
|
|
|
(let ((str (utf8->string (if size
|
|
|
|
|
(get-bytevector-n port size)
|
|
|
|
|
(get-bytevector-all port)))))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(alist->record (call-with-input-string str fields->alist)
|
|
|
|
|
(narinfo-maker str url)
|
|
|
|
|
'("StorePath" "URL" "Compression"
|
|
|
|
|
"FileHash" "FileSize" "NarHash" "NarSize"
|
|
|
|
|
"References" "Deriver" "System"
|
|
|
|
|
"Signature"))))
|
|
|
|
|
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(define (narinfo-sha256 narinfo)
|
|
|
|
|
"Return the sha256 hash of NARINFO as a bytevector, or #f if NARINFO lacks a
|
|
|
|
|
'Signature' field."
|
|
|
|
|
(let ((contents (narinfo-contents narinfo)))
|
2015-01-09 01:10:31 +01:00
|
|
|
|
(match (string-contains contents "Signature:")
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(#f #f)
|
2015-01-09 01:10:31 +01:00
|
|
|
|
(index
|
|
|
|
|
(let ((above-signature (string-take contents index)))
|
|
|
|
|
(sha256 (string->utf8 above-signature)))))))
|
2014-03-31 23:47:02 +02:00
|
|
|
|
|
2014-03-31 21:58:21 +02:00
|
|
|
|
(define* (assert-valid-narinfo narinfo
|
|
|
|
|
#:optional (acl (current-acl))
|
|
|
|
|
#:key (verbose? #t))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
"Raise an exception if NARINFO lacks a signature, has an invalid signature,
|
|
|
|
|
or is signed by an unauthorized key."
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(let ((hash (narinfo-sha256 narinfo)))
|
|
|
|
|
(if (not hash)
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(if %allow-unauthenticated-substitutes?
|
|
|
|
|
narinfo
|
2014-06-17 00:30:16 +02:00
|
|
|
|
(leave (_ "substitute at '~a' lacks a signature~%")
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(uri->string (narinfo-uri narinfo))))
|
|
|
|
|
(let ((signature (narinfo-signature narinfo)))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(unless %allow-unauthenticated-substitutes?
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(assert-valid-signature narinfo signature hash acl)
|
2014-03-31 21:58:21 +02:00
|
|
|
|
(when verbose?
|
2015-09-15 07:31:11 +02:00
|
|
|
|
;; Visually separate substitutions with a newline.
|
2014-03-31 21:58:21 +02:00
|
|
|
|
(format (current-error-port)
|
2015-09-15 07:31:11 +02:00
|
|
|
|
"~%Found valid signature for ~a~%From ~a~%"
|
2014-03-31 21:58:21 +02:00
|
|
|
|
(narinfo-path narinfo)
|
|
|
|
|
(uri->string (narinfo-uri narinfo)))))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
narinfo))))
|
|
|
|
|
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(define* (valid-narinfo? narinfo #:optional (acl (current-acl)))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
"Return #t if NARINFO's signature is not valid."
|
2014-03-31 23:47:02 +02:00
|
|
|
|
(or %allow-unauthenticated-substitutes?
|
|
|
|
|
(let ((hash (narinfo-sha256 narinfo))
|
|
|
|
|
(signature (narinfo-signature narinfo)))
|
|
|
|
|
(and hash signature
|
|
|
|
|
(signature-case (signature hash acl)
|
|
|
|
|
(valid-signature #t)
|
|
|
|
|
(else #f))))))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
|
|
|
|
|
(define (write-narinfo narinfo port)
|
|
|
|
|
"Write NARINFO to PORT."
|
2014-03-29 00:06:41 +01:00
|
|
|
|
(put-bytevector port (string->utf8 (narinfo-contents narinfo))))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
|
|
|
|
|
(define (narinfo->string narinfo)
|
|
|
|
|
"Return the external representation of NARINFO."
|
|
|
|
|
(call-with-output-string (cut write-narinfo narinfo <>)))
|
|
|
|
|
|
2014-03-26 23:31:31 +01:00
|
|
|
|
(define (string->narinfo str cache-uri)
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
"Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
|
|
|
|
|
the cache STR originates form."
|
2014-03-26 23:31:31 +01:00
|
|
|
|
(call-with-input-string str (cut read-narinfo <> cache-uri)))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(define (obsolete? date now ttl)
|
|
|
|
|
"Return #t if DATE is obsolete compared to NOW + TTL seconds."
|
|
|
|
|
(time>? (subtract-duration now (make-time time-duration 0 ttl))
|
|
|
|
|
(make-time time-monotonic 0 date)))
|
|
|
|
|
|
2013-11-08 22:47:02 +01:00
|
|
|
|
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(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."
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(string-append %narinfo-cache-directory "/"
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(bytevector->base32-string (sha256 (string->utf8 cache-url)))
|
|
|
|
|
"/" (store-path-hash-part path)))
|
|
|
|
|
|
|
|
|
|
(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."
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(define now
|
|
|
|
|
(current-time time-monotonic))
|
|
|
|
|
|
|
|
|
|
(define cache-file
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(narinfo-cache-file cache-url path))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
|
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call-with-input-file cache-file
|
|
|
|
|
(lambda (p)
|
|
|
|
|
(match (read p)
|
2016-03-16 14:51:37 +01:00
|
|
|
|
(('narinfo ('version 2)
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
('cache-uri cache-uri)
|
2016-03-16 14:51:37 +01:00
|
|
|
|
('date date) ('ttl _) ('value #f))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
;; A cached negative lookup.
|
|
|
|
|
(if (obsolete? date now %narinfo-negative-ttl)
|
|
|
|
|
(values #f #f)
|
|
|
|
|
(values #t #f)))
|
2016-03-16 14:51:37 +01:00
|
|
|
|
(('narinfo ('version 2)
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
('cache-uri cache-uri)
|
2016-03-16 14:51:37 +01:00
|
|
|
|
('date date) ('ttl ttl) ('value value))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
;; A cached positive lookup
|
2016-03-16 14:51:37 +01:00
|
|
|
|
(if (obsolete? date now ttl)
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(values #f #f)
|
|
|
|
|
(values #t (string->narinfo value cache-uri))))
|
|
|
|
|
(('narinfo ('version v) _ ...)
|
|
|
|
|
(values #f #f))))))
|
|
|
|
|
(lambda _
|
|
|
|
|
(values #f #f))))
|
|
|
|
|
|
2016-03-16 15:31:18 +01:00
|
|
|
|
(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."
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(define now
|
|
|
|
|
(current-time time-monotonic))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(define (cache-entry cache-uri narinfo)
|
2016-03-16 14:51:37 +01:00
|
|
|
|
`(narinfo (version 2)
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(cache-uri ,cache-uri)
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(date ,(time-second now))
|
2016-03-16 15:31:18 +01:00
|
|
|
|
(ttl ,(or ttl
|
|
|
|
|
(if narinfo %narinfo-ttl %narinfo-negative-ttl)))
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(value ,(and=> narinfo narinfo->string))))
|
|
|
|
|
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(let ((file (narinfo-cache-file cache-url path)))
|
2015-10-19 23:12:34 +02:00
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(mkdir-p (dirname file))
|
|
|
|
|
(with-atomic-file-output file
|
|
|
|
|
(lambda (out)
|
|
|
|
|
(write (cache-entry cache-url narinfo) out))))
|
|
|
|
|
(lambda args
|
|
|
|
|
;; We may not have write access to the local cache when called from an
|
|
|
|
|
;; unprivileged process such as 'guix challenge'.
|
|
|
|
|
(unless (= EACCES (system-error-errno args))
|
|
|
|
|
(apply throw args)))))
|
2015-07-13 15:52:29 +02:00
|
|
|
|
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
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")))
|
|
|
|
|
(build-request (string->uri url) #:method 'GET)))
|
|
|
|
|
|
2016-03-14 22:44:59 +01:00
|
|
|
|
(define* (http-multiple-get base-uri proc seed requests
|
|
|
|
|
#:key port)
|
2016-03-10 11:53:03 +01:00
|
|
|
|
"Send all of REQUESTS to the server at BASE-URI. Call PROC for each
|
2015-10-28 11:45:27 +01:00
|
|
|
|
response, passing it the request object, the response, a port from which to
|
|
|
|
|
read the response body, and the previous result, starting with SEED, à la
|
2016-03-14 22:44:59 +01:00
|
|
|
|
'fold'. Return the final result. When PORT is specified, use it as the
|
|
|
|
|
initial connection on which HTTP requests are sent."
|
|
|
|
|
(let connect ((port port)
|
|
|
|
|
(requests requests)
|
2015-10-28 11:45:27 +01:00
|
|
|
|
(result seed))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
;; (format (current-error-port) "connecting (~a requests left)..."
|
|
|
|
|
;; (length requests))
|
2016-03-14 22:44:59 +01:00
|
|
|
|
(let ((p (or port (open-connection-for-uri base-uri))))
|
2016-03-10 11:53:03 +01:00
|
|
|
|
;; For HTTPS, P is not a file port and does not support 'setvbuf'.
|
|
|
|
|
(when (file-port? p)
|
|
|
|
|
(setvbuf p _IOFBF (expt 2 16)))
|
|
|
|
|
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
;; Send all of REQUESTS in a row.
|
2016-03-10 13:53:23 +01:00
|
|
|
|
;; XXX: Do our own caching to work around inefficiencies when
|
|
|
|
|
;; communicating over TLS: <http://bugs.gnu.org/22966>.
|
|
|
|
|
(let-values (((buffer get) (open-bytevector-output-port)))
|
|
|
|
|
;; On Guile > 2.0.9, inherit the HTTP proxying property from P.
|
|
|
|
|
(when (module-variable (resolve-interface '(web http))
|
|
|
|
|
'http-proxy-port?)
|
|
|
|
|
(set-http-proxy-port?! buffer (http-proxy-port? p)))
|
|
|
|
|
|
|
|
|
|
(for-each (cut write-request <> buffer) requests)
|
|
|
|
|
(put-bytevector p (get))
|
|
|
|
|
(force-output p))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
|
|
|
|
|
;; Now start processing responses.
|
|
|
|
|
(let loop ((requests requests)
|
|
|
|
|
(result result))
|
|
|
|
|
(match requests
|
|
|
|
|
(()
|
|
|
|
|
(reverse result))
|
|
|
|
|
((head tail ...)
|
2015-07-07 00:52:16 +02:00
|
|
|
|
(let* ((resp (read-response p))
|
|
|
|
|
(body (response-body-port resp))
|
2015-10-28 11:45:27 +01:00
|
|
|
|
(result (proc head resp body result)))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
;; The server can choose to stop responding at any time, in which
|
|
|
|
|
;; case we have to try again. Check whether that is the case.
|
2015-07-07 00:52:16 +02:00
|
|
|
|
;; Note that even upon "Connection: close", we can read from BODY.
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(match (assq 'connection (response-headers resp))
|
|
|
|
|
(('connection 'close)
|
2016-03-17 21:57:15 +01:00
|
|
|
|
(close-connection p)
|
2016-03-14 22:44:59 +01:00
|
|
|
|
(connect #f tail result)) ;try again
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(_
|
2015-07-07 00:52:16 +02:00
|
|
|
|
(loop tail result)))))))))) ;keep going
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
|
|
|
|
|
(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)
|
|
|
|
|
"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)))))
|
|
|
|
|
|
2015-07-13 11:38:31 +02:00
|
|
|
|
(define (fetch-narinfos url paths)
|
|
|
|
|
"Retrieve all the narinfos for PATHS from the cache at URL and return them."
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(define update-progress!
|
|
|
|
|
(let ((done 0))
|
|
|
|
|
(lambda ()
|
|
|
|
|
(display #\cr (current-error-port))
|
|
|
|
|
(force-output (current-error-port))
|
|
|
|
|
(format (current-error-port)
|
|
|
|
|
(_ "updating list of substitutes from '~a'... ~5,1f%")
|
|
|
|
|
url (* 100. (/ done (length paths))))
|
|
|
|
|
(set! done (+ 1 done)))))
|
|
|
|
|
|
2015-10-28 11:45:27 +01:00
|
|
|
|
(define (handle-narinfo-response request response port result)
|
2016-03-17 21:49:05 +01:00
|
|
|
|
(let* ((code (response-code response))
|
|
|
|
|
(len (response-content-length response))
|
2016-03-16 15:31:18 +01:00
|
|
|
|
(cache (response-cache-control response))
|
|
|
|
|
(ttl (and cache (assoc-ref cache 'max-age))))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
;; Make sure to read no more than LEN bytes since subsequent bytes may
|
|
|
|
|
;; belong to the next response.
|
2016-03-17 21:49:05 +01:00
|
|
|
|
(if (= code 200) ; hit
|
|
|
|
|
(let ((narinfo (read-narinfo port url #:size len)))
|
|
|
|
|
(cache-narinfo! url (narinfo-path narinfo) narinfo ttl)
|
|
|
|
|
(update-progress!)
|
|
|
|
|
(cons narinfo result))
|
|
|
|
|
(let* ((path (uri-path (request-uri request)))
|
|
|
|
|
(hash-part (string-drop-right path 8))) ; drop ".narinfo"
|
|
|
|
|
(if len
|
|
|
|
|
(get-bytevector-n port len)
|
|
|
|
|
(read-to-eof port))
|
|
|
|
|
(cache-narinfo! url
|
|
|
|
|
(find (cut string-contains <> hash-part) paths)
|
|
|
|
|
#f
|
|
|
|
|
(if (= 404 code)
|
|
|
|
|
ttl
|
|
|
|
|
%narinfo-transient-error-ttl))
|
|
|
|
|
(update-progress!)
|
|
|
|
|
result))))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
|
2016-03-14 22:44:59 +01:00
|
|
|
|
(define (do-fetch uri port)
|
2015-11-28 00:02:23 +01:00
|
|
|
|
(case (and=> uri uri-scheme)
|
2016-03-10 11:53:03 +01:00
|
|
|
|
((http https)
|
2015-11-28 00:02:23 +01:00
|
|
|
|
(let ((requests (map (cut narinfo-request url <>) paths)))
|
|
|
|
|
(update-progress!)
|
2016-03-10 11:53:03 +01:00
|
|
|
|
(let ((result (http-multiple-get uri
|
2015-11-28 00:02:23 +01:00
|
|
|
|
handle-narinfo-response '()
|
2016-03-14 22:44:59 +01:00
|
|
|
|
requests
|
|
|
|
|
#:port port)))
|
2016-03-17 21:57:15 +01:00
|
|
|
|
(close-connection port)
|
2015-11-28 00:02:23 +01:00
|
|
|
|
(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 (_ "~s: unsupported server URI scheme~%")
|
|
|
|
|
(if uri (uri-scheme uri) url)))))
|
|
|
|
|
|
2016-03-14 22:44:59 +01:00
|
|
|
|
(let-values (((cache-info port)
|
|
|
|
|
(download-cache-info url)))
|
|
|
|
|
(and cache-info
|
|
|
|
|
(if (string=? (cache-info-store-directory cache-info)
|
|
|
|
|
(%store-prefix))
|
|
|
|
|
(do-fetch (string->uri url) port) ;reuse PORT
|
|
|
|
|
(begin
|
|
|
|
|
(warning (_ "'~a' uses different store '~a'; ignoring it~%")
|
|
|
|
|
url (cache-info-store-directory cache-info))
|
2016-03-17 21:57:15 +01:00
|
|
|
|
(close-connection port)
|
2016-03-14 22:44:59 +01:00
|
|
|
|
#f)))))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
|
|
|
|
|
(define (lookup-narinfos cache paths)
|
|
|
|
|
"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)
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(cached-narinfo cache path)))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(if valid?
|
2015-10-28 11:48:27 +01:00
|
|
|
|
(if value
|
|
|
|
|
(values (cons value cached) missing)
|
|
|
|
|
(values cached missing))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
(values cached (cons path missing)))))
|
|
|
|
|
'()
|
|
|
|
|
'()
|
|
|
|
|
paths)))
|
|
|
|
|
(if (null? missing)
|
|
|
|
|
cached
|
2015-07-13 11:38:31 +02:00
|
|
|
|
(let ((missing (fetch-narinfos cache missing)))
|
|
|
|
|
(append cached (or missing '()))))))
|
substitute-binary: Pipeline HTTP requests instead of using threads.
* guix/scripts/substitute-binary.scm (fetch-narinfo, %lookup-threads,
n-par-map*): Remove.
(narinfo-cache-file, cached-narinfo, cache-narinfo!, narinfo-request,
http-multiple-get, read-to-eof, fetch-narinfos, lookup-narinfos,
narinfo-from-file): New procedures.
(lookup-narinfo): Rewrite in terms of 'lookup-narinfos'.
(guix-substitute-binary): Use 'lookup-narinfos' instead of
'lookup-narinfo'.
2015-03-23 22:25:04 +01:00
|
|
|
|
|
2015-10-28 10:11:43 +01:00
|
|
|
|
(define (lookup-narinfos/diverse caches paths)
|
|
|
|
|
"Look up narinfos for PATHS on all of CACHES, a list of URLS, in that order.
|
|
|
|
|
That is, when a cache lacks a narinfo, look it up in the next cache, and so
|
|
|
|
|
on. Return a list of narinfos for PATHS or a subset thereof."
|
|
|
|
|
(let loop ((caches caches)
|
|
|
|
|
(paths paths)
|
|
|
|
|
(result '()))
|
|
|
|
|
(match paths
|
|
|
|
|
(() ;we're done
|
|
|
|
|
result)
|
|
|
|
|
(_
|
|
|
|
|
(match caches
|
|
|
|
|
((cache rest ...)
|
|
|
|
|
(let* ((narinfos (lookup-narinfos cache paths))
|
|
|
|
|
(hits (map narinfo-path narinfos))
|
|
|
|
|
(missing (lset-difference string=? paths hits))) ;XXX: perf
|
|
|
|
|
(loop rest missing (append narinfos result))))
|
|
|
|
|
(() ;that's it
|
|
|
|
|
result))))))
|
|
|
|
|
|
|
|
|
|
(define (lookup-narinfo caches path)
|
|
|
|
|
"Return the narinfo for PATH in CACHES, or #f when no substitute for PATH
|
|
|
|
|
was found."
|
|
|
|
|
(match (lookup-narinfos/diverse caches (list path))
|
|
|
|
|
((answer) answer)
|
|
|
|
|
(_ #f)))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(define (remove-expired-cached-narinfos directory)
|
|
|
|
|
"Remove expired narinfo entries from DIRECTORY. The sole purpose of this
|
2013-04-20 15:12:24 +02:00
|
|
|
|
function is to make sure `%narinfo-cache-directory' doesn't grow
|
|
|
|
|
indefinitely."
|
|
|
|
|
(define now
|
|
|
|
|
(current-time time-monotonic))
|
|
|
|
|
|
|
|
|
|
(define (expired? file)
|
|
|
|
|
(catch 'system-error
|
|
|
|
|
(lambda ()
|
|
|
|
|
(call-with-input-file file
|
|
|
|
|
(lambda (port)
|
|
|
|
|
(match (read port)
|
2016-03-16 14:51:37 +01:00
|
|
|
|
(('narinfo ('version 2) ('cache-uri _)
|
|
|
|
|
('date date) ('ttl _) ('value #f))
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(obsolete? date now %narinfo-negative-ttl))
|
2016-03-16 14:51:37 +01:00
|
|
|
|
(('narinfo ('version 2) ('cache-uri _)
|
|
|
|
|
('date date) ('ttl ttl) ('value _))
|
|
|
|
|
(obsolete? date now ttl))
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(_ #t)))))
|
|
|
|
|
(lambda args
|
|
|
|
|
;; FILE may have been deleted.
|
|
|
|
|
#t)))
|
|
|
|
|
|
|
|
|
|
(for-each (lambda (file)
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(let ((file (string-append directory "/" file)))
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(when (expired? file)
|
|
|
|
|
;; Wrap in `false-if-exception' because FILE might have been
|
|
|
|
|
;; deleted in the meantime (TOCTTOU).
|
|
|
|
|
(false-if-exception (delete-file file)))))
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(scandir directory
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(lambda (file)
|
|
|
|
|
(= (string-length file) 32)))))
|
|
|
|
|
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(define (narinfo-cache-directories)
|
|
|
|
|
"Return the list of narinfo cache directories (one per cache URL.)"
|
|
|
|
|
(map (cut string-append %narinfo-cache-directory "/" <>)
|
|
|
|
|
(scandir %narinfo-cache-directory
|
|
|
|
|
(lambda (item)
|
|
|
|
|
(and (not (member item '("." "..")))
|
|
|
|
|
(file-is-directory?
|
|
|
|
|
(string-append %narinfo-cache-directory
|
|
|
|
|
"/" item)))))))
|
|
|
|
|
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(define (maybe-remove-expired-cached-narinfo)
|
|
|
|
|
"Remove expired narinfo entries from the cache if deemed necessary."
|
|
|
|
|
(define now
|
|
|
|
|
(current-time time-monotonic))
|
|
|
|
|
|
|
|
|
|
(define expiry-file
|
|
|
|
|
(string-append %narinfo-cache-directory "/last-expiry-cleanup"))
|
|
|
|
|
|
|
|
|
|
(define last-expiry-date
|
|
|
|
|
(or (false-if-exception
|
|
|
|
|
(call-with-input-file expiry-file read))
|
|
|
|
|
0))
|
|
|
|
|
|
2015-07-13 15:52:29 +02:00
|
|
|
|
(when (obsolete? last-expiry-date now
|
|
|
|
|
%narinfo-expired-cache-entry-removal-delay)
|
|
|
|
|
(for-each remove-expired-cached-narinfos
|
|
|
|
|
(narinfo-cache-directories))
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(call-with-output-file expiry-file
|
|
|
|
|
(cute write (time-second now) <>))))
|
|
|
|
|
|
2013-06-20 23:41:11 +02:00
|
|
|
|
(define (progress-report-port report-progress port)
|
|
|
|
|
"Return a port that calls REPORT-PROGRESS every time something is read from
|
|
|
|
|
PORT. REPORT-PROGRESS is a two-argument procedure such as that returned by
|
|
|
|
|
`progress-proc'."
|
|
|
|
|
(define total 0)
|
|
|
|
|
(define (read! bv start count)
|
|
|
|
|
(let ((n (match (get-bytevector-n! port bv start count)
|
|
|
|
|
((? eof-object?) 0)
|
|
|
|
|
(x x))))
|
|
|
|
|
(set! total (+ total n))
|
|
|
|
|
(report-progress total (const n))
|
|
|
|
|
;; XXX: We're not in control, so we always return anyway.
|
|
|
|
|
n))
|
|
|
|
|
|
2015-05-07 21:51:30 +02:00
|
|
|
|
(make-custom-binary-input-port "progress-port-proc"
|
|
|
|
|
read! #f #f
|
2016-03-17 21:57:15 +01:00
|
|
|
|
(cut close-connection port)))
|
2013-06-20 23:41:11 +02:00
|
|
|
|
|
2013-05-29 23:21:54 +02:00
|
|
|
|
(define-syntax with-networking
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
"Catch DNS lookup errors and gracefully exit."
|
|
|
|
|
;; Note: no attempt is made to catch other networking errors, because DNS
|
|
|
|
|
;; lookup errors are typically the first one, and because other errors are
|
|
|
|
|
;; a subset of `system-error', which is harder to filter.
|
|
|
|
|
((_ exp ...)
|
|
|
|
|
(catch 'getaddrinfo-error
|
|
|
|
|
(lambda () exp ...)
|
|
|
|
|
(lambda (key error)
|
|
|
|
|
(leave (_ "host name lookup error: ~a~%")
|
|
|
|
|
(gai-strerror error)))))))
|
|
|
|
|
|
2013-09-13 23:42:36 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Help.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (show-help)
|
2015-03-25 10:34:27 +01:00
|
|
|
|
(display (_ "Usage: guix substitute [OPTION]...
|
2013-09-13 23:42:36 +02:00
|
|
|
|
Internal tool to substitute a pre-built binary to a local build.\n"))
|
|
|
|
|
(display (_ "
|
|
|
|
|
--query report on the availability of substitutes for the
|
|
|
|
|
store file names passed on the standard input"))
|
|
|
|
|
(display (_ "
|
|
|
|
|
--substitute STORE-FILE DESTINATION
|
|
|
|
|
download STORE-FILE and store it as a Nar in file
|
|
|
|
|
DESTINATION"))
|
|
|
|
|
(newline)
|
|
|
|
|
(display (_ "
|
|
|
|
|
-h, --help display this help and exit"))
|
|
|
|
|
(display (_ "
|
|
|
|
|
-V, --version display version information and exit"))
|
|
|
|
|
(newline)
|
|
|
|
|
(show-bug-report-information))
|
|
|
|
|
|
|
|
|
|
|
2015-07-13 17:51:02 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Daemon/substituter protocol.
|
|
|
|
|
;;;
|
|
|
|
|
|
|
|
|
|
(define (display-narinfo-data narinfo)
|
2015-09-03 23:37:33 +02:00
|
|
|
|
"Write to the current output port the contents of NARINFO in the format
|
2015-07-13 17:51:02 +02:00
|
|
|
|
expected by the daemon."
|
|
|
|
|
(format #t "~a\n~a\n~a\n"
|
|
|
|
|
(narinfo-path narinfo)
|
|
|
|
|
(or (and=> (narinfo-deriver narinfo)
|
|
|
|
|
(cute string-append (%store-prefix) "/" <>))
|
|
|
|
|
"")
|
|
|
|
|
(length (narinfo-references narinfo)))
|
|
|
|
|
(for-each (cute format #t "~a/~a~%" (%store-prefix) <>)
|
|
|
|
|
(narinfo-references narinfo))
|
|
|
|
|
(format #t "~a\n~a\n"
|
|
|
|
|
(or (narinfo-file-size narinfo) 0)
|
|
|
|
|
(or (narinfo-size narinfo) 0)))
|
|
|
|
|
|
|
|
|
|
(define* (process-query command
|
2015-10-28 10:11:43 +01:00
|
|
|
|
#:key cache-urls acl)
|
2015-07-13 17:51:02 +02:00
|
|
|
|
"Reply to COMMAND, a query as written by the daemon to this process's
|
|
|
|
|
standard input. Use ACL as the access-control list against which to check
|
|
|
|
|
authorized substitutes."
|
|
|
|
|
(define (valid? obj)
|
2015-10-28 10:11:43 +01:00
|
|
|
|
(valid-narinfo? obj acl))
|
2015-07-13 17:51:02 +02:00
|
|
|
|
|
|
|
|
|
(match (string-tokenize command)
|
|
|
|
|
(("have" paths ..1)
|
2015-10-28 10:11:43 +01:00
|
|
|
|
;; Return the subset of PATHS available in CACHE-URLS.
|
|
|
|
|
(let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(for-each (lambda (narinfo)
|
|
|
|
|
(format #t "~a~%" (narinfo-path narinfo)))
|
|
|
|
|
(filter valid? substitutable))
|
|
|
|
|
(newline)))
|
|
|
|
|
(("info" paths ..1)
|
2015-10-28 10:11:43 +01:00
|
|
|
|
;; Reply info about PATHS if it's in CACHE-URLS.
|
|
|
|
|
(let ((substitutable (lookup-narinfos/diverse cache-urls paths)))
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(for-each display-narinfo-data (filter valid? substitutable))
|
|
|
|
|
(newline)))
|
|
|
|
|
(wtf
|
|
|
|
|
(error "unknown `--query' command" wtf))))
|
|
|
|
|
|
|
|
|
|
(define* (process-substitution store-item destination
|
2015-10-28 10:11:43 +01:00
|
|
|
|
#:key cache-urls acl)
|
|
|
|
|
"Substitute STORE-ITEM (a store file name) from CACHE-URLS, and write it to
|
2015-07-13 17:51:02 +02:00
|
|
|
|
DESTINATION as a nar file. Verify the substitute against ACL."
|
2015-10-28 10:11:43 +01:00
|
|
|
|
(let* ((narinfo (lookup-narinfo cache-urls store-item))
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(uri (narinfo-uri narinfo)))
|
|
|
|
|
;; Make sure it is signed and everything.
|
|
|
|
|
(assert-valid-narinfo narinfo acl)
|
|
|
|
|
|
|
|
|
|
;; Tell the daemon what the expected hash of the Nar itself is.
|
|
|
|
|
(format #t "~a~%" (narinfo-hash narinfo))
|
|
|
|
|
|
2015-09-15 07:31:11 +02:00
|
|
|
|
(format (current-error-port) "Downloading ~a~:[~*~; (~a installed)~]...~%"
|
|
|
|
|
(store-path-abbreviation store-item)
|
2015-07-13 17:51:02 +02:00
|
|
|
|
;; Use the Nar size as an estimate of the installed size.
|
|
|
|
|
(narinfo-size narinfo)
|
|
|
|
|
(and=> (narinfo-size narinfo)
|
2015-09-15 07:31:11 +02:00
|
|
|
|
(cute byte-count->string <>)))
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(let*-values (((raw download-size)
|
|
|
|
|
;; Note that Hydra currently generates Nars on the fly
|
|
|
|
|
;; and doesn't specify a Content-Length, so
|
|
|
|
|
;; DOWNLOAD-SIZE is #f in practice.
|
|
|
|
|
(fetch uri #:buffered? #f #:timeout? #f))
|
|
|
|
|
((progress)
|
|
|
|
|
(let* ((comp (narinfo-compression narinfo))
|
|
|
|
|
(dl-size (or download-size
|
|
|
|
|
(and (equal? comp "none")
|
|
|
|
|
(narinfo-size narinfo))))
|
|
|
|
|
(progress (progress-proc (uri-abbreviation uri)
|
|
|
|
|
dl-size
|
2015-09-15 07:31:11 +02:00
|
|
|
|
(current-error-port)
|
|
|
|
|
#:abbreviation
|
|
|
|
|
store-path-abbreviation)))
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(progress-report-port progress raw)))
|
|
|
|
|
((input pids)
|
|
|
|
|
(decompressed-port (and=> (narinfo-compression narinfo)
|
|
|
|
|
string->symbol)
|
|
|
|
|
progress)))
|
|
|
|
|
;; Unpack the Nar at INPUT into DESTINATION.
|
|
|
|
|
(restore-file input destination)
|
|
|
|
|
|
|
|
|
|
;; Skip a line after what 'progress-proc' printed.
|
|
|
|
|
(newline (current-error-port))
|
|
|
|
|
|
|
|
|
|
(every (compose zero? cdr waitpid) pids))))
|
|
|
|
|
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
|
|
|
|
;;;
|
|
|
|
|
;;; Entry point.
|
|
|
|
|
;;;
|
|
|
|
|
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(define (check-acl-initialized)
|
|
|
|
|
"Warn if the ACL is uninitialized."
|
|
|
|
|
(define (singleton? acl)
|
|
|
|
|
;; True if ACL contains just the user's public key.
|
|
|
|
|
(and (file-exists? %public-key-file)
|
|
|
|
|
(let ((key (call-with-input-file %public-key-file
|
|
|
|
|
(compose string->canonical-sexp
|
|
|
|
|
get-string-all))))
|
2014-06-19 23:35:21 +02:00
|
|
|
|
(match acl
|
|
|
|
|
((thing)
|
|
|
|
|
(equal? (canonical-sexp->string thing)
|
|
|
|
|
(canonical-sexp->string key)))
|
|
|
|
|
(_
|
|
|
|
|
#f)))))
|
|
|
|
|
|
|
|
|
|
(let ((acl (acl->public-keys (current-acl))))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(when (or (null? acl) (singleton? acl))
|
|
|
|
|
(warning (_ "ACL for archive imports seems to be uninitialized, \
|
|
|
|
|
substitutes may be unavailable\n")))))
|
|
|
|
|
|
2014-10-09 13:25:41 +02:00
|
|
|
|
(define (daemon-options)
|
|
|
|
|
"Return a list of name/value pairs denoting build daemon options."
|
|
|
|
|
(define %not-newline
|
|
|
|
|
(char-set-complement (char-set #\newline)))
|
|
|
|
|
|
|
|
|
|
(match (getenv "_NIX_OPTIONS")
|
|
|
|
|
(#f ;should not happen when called by the daemon
|
|
|
|
|
'())
|
|
|
|
|
(newline-separated
|
|
|
|
|
;; Here we get something of the form "OPTION1=VALUE1\nOPTION2=VALUE2\n".
|
|
|
|
|
(filter-map (lambda (option=value)
|
|
|
|
|
(match (string-index option=value #\=)
|
|
|
|
|
(#f ;invalid option setting
|
|
|
|
|
#f)
|
|
|
|
|
(equal-sign
|
|
|
|
|
(cons (string-take option=value equal-sign)
|
|
|
|
|
(string-drop option=value (+ 1 equal-sign))))))
|
|
|
|
|
(string-tokenize newline-separated %not-newline)))))
|
|
|
|
|
|
|
|
|
|
(define (find-daemon-option option)
|
|
|
|
|
"Return the value of build daemon option OPTION, or #f if it could not be
|
|
|
|
|
found."
|
|
|
|
|
(assoc-ref (daemon-options) option))
|
|
|
|
|
|
2015-10-28 10:11:43 +01:00
|
|
|
|
(define %cache-urls
|
2016-03-16 18:13:02 +01:00
|
|
|
|
(match (and=> (or (find-daemon-option "untrusted-substitute-urls") ;client
|
|
|
|
|
(find-daemon-option "substitute-urls")) ;admin
|
2014-10-09 13:38:16 +02:00
|
|
|
|
string-tokenize)
|
2015-10-28 10:11:43 +01:00
|
|
|
|
((urls ...)
|
|
|
|
|
urls)
|
2014-10-09 13:38:16 +02:00
|
|
|
|
(#f
|
|
|
|
|
;; This can only happen when this script is not invoked by the
|
|
|
|
|
;; daemon.
|
2015-10-28 10:11:43 +01:00
|
|
|
|
'("http://hydra.gnu.org"))))
|
2014-10-09 13:25:41 +02:00
|
|
|
|
|
2015-03-25 10:34:27 +01:00
|
|
|
|
(define (guix-substitute . args)
|
2013-04-02 10:44:20 +02:00
|
|
|
|
"Implement the build daemon's substituter protocol."
|
2013-04-15 23:42:27 +02:00
|
|
|
|
(mkdir-p %narinfo-cache-directory)
|
2013-04-20 15:12:24 +02:00
|
|
|
|
(maybe-remove-expired-cached-narinfo)
|
2014-06-19 23:35:21 +02:00
|
|
|
|
(check-acl-initialized)
|
2014-01-18 16:48:29 +01:00
|
|
|
|
|
|
|
|
|
;; Starting from commit 22144afa in Nix, we are allowed to bail out directly
|
|
|
|
|
;; when we know we cannot substitute, but we must emit a newline on stdout
|
|
|
|
|
;; when everything is alright.
|
2015-10-28 10:11:43 +01:00
|
|
|
|
(when (null? %cache-urls)
|
|
|
|
|
(exit 0))
|
2014-01-18 16:48:29 +01:00
|
|
|
|
|
|
|
|
|
;; Say hello (see above.)
|
|
|
|
|
(newline)
|
|
|
|
|
(force-output (current-output-port))
|
|
|
|
|
|
2013-05-29 23:21:54 +02:00
|
|
|
|
(with-networking
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(with-error-handling ; for signature errors
|
|
|
|
|
(match args
|
|
|
|
|
(("--query")
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(let ((acl (current-acl)))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(let loop ((command (read-line)))
|
|
|
|
|
(or (eof-object? command)
|
|
|
|
|
(begin
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(process-query command
|
2015-10-28 10:11:43 +01:00
|
|
|
|
#:cache-urls %cache-urls
|
2015-07-13 17:51:02 +02:00
|
|
|
|
#:acl acl)
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(loop (read-line)))))))
|
|
|
|
|
(("--substitute" store-path destination)
|
|
|
|
|
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
|
2015-07-13 17:51:02 +02:00
|
|
|
|
(process-substitution store-path destination
|
2015-10-28 10:11:43 +01:00
|
|
|
|
#:cache-urls %cache-urls
|
2015-07-13 17:51:02 +02:00
|
|
|
|
#:acl (current-acl)))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(("--version")
|
2015-03-25 10:34:27 +01:00
|
|
|
|
(show-version-and-exit "guix substitute"))
|
substitute-binary: Defer narinfo authentication and authorization checks.
* guix/scripts/substitute-binary.scm (narinfo-signature->canonical-sexp):
Catch 'gcry-error' around 'string->canonical-sexp' call, and re-raise
as a SRFI-35 &message and &nar-signature-error.
(narinfo-maker): Handle when SIGNATURE is #f or an invalid canonical
sexp.
(&nar-signature-error, &nar-invalid-hash-error): New variables.
(assert-valid-signature): Use them. Expect 'signature' to be a
canonical sexp.
(read-narinfo): Remove authentication and authorization checks.
(%signature-line-rx): New variable.
(assert-valid-narinfo, valid-narinfo?): New procedures.
(guix-substitute-binary): Wrap body in 'with-error-handling'.
[valid?]: New procedure.
<--query>: Show only store items of narinfos that match
'valid-narinfo?'.
<--substitute>: Call 'assert-valid-narinfo'.
* tests/substitute-binary.scm (test-error*): Use 'test-equal'.
(%keypair): Remove.
(%public-key, %private-key): Load from signing-key.{pub,sec}.
(signature-body): Add #:public-key parameter.
(call-with-narinfo): New procedure.
(with-narinfo): New macro.
("corrupt signature data", "unauthorized public key", "invalid
signature"): Make the first argument to 'assert-valid-signature' a
canonical sexp.
("invalid hash", "valid read-narinfo", "valid write-narinfo"):
Remove.
("query narinfo with invalid hash", "query narinfo signed with
authorized key", "query narinfo signed with unauthorized key",
"substitute, invalid hash", "substitute, unauthorized key"): New
tests.
2014-03-30 22:29:35 +02:00
|
|
|
|
(("--help")
|
|
|
|
|
(show-help))
|
|
|
|
|
(opts
|
|
|
|
|
(leave (_ "~a: unrecognized options~%") opts))))))
|
2013-04-02 10:44:20 +02:00
|
|
|
|
|
2013-06-29 22:10:06 +02:00
|
|
|
|
;;; Local Variables:
|
2013-06-18 00:11:40 +02:00
|
|
|
|
;;; eval: (put 'with-timeout 'scheme-indent-function 1)
|
2013-06-04 09:43:38 +02:00
|
|
|
|
;;; End:
|
|
|
|
|
|
2015-03-25 10:34:27 +01:00
|
|
|
|
;;; substitute.scm ends here
|