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.
This commit is contained in:
Ludovic Courtès
parent
00230df107
commit
cdea30e061
|
|
@ -247,8 +247,19 @@ failure."
|
|||
((not (= 1 maybe-number))
|
||||
(leave (_ "unsupported signature version: ~a~%")
|
||||
maybe-number))
|
||||
(else (string->canonical-sexp
|
||||
(utf8->string (base64-decode sig)))))))
|
||||
(else
|
||||
(let ((signature (utf8->string (base64-decode sig))))
|
||||
(catch 'gcry-error
|
||||
(lambda ()
|
||||
(string->canonical-sexp signature))
|
||||
(lambda (err . _)
|
||||
(raise (condition
|
||||
(&message
|
||||
(message "signature is not a valid \
|
||||
s-expression"))
|
||||
(&nar-signature-error
|
||||
(file #f)
|
||||
(signature signature) (port #f)))))))))))
|
||||
(x
|
||||
(leave (_ "invalid format of the signature field: ~a~%") x))))
|
||||
|
||||
|
|
@ -273,33 +284,24 @@ must contain the original contents of a narinfo file."
|
|||
((or #f "") #f)
|
||||
(_ deriver))
|
||||
system
|
||||
(narinfo-signature->canonical-sexp signature)
|
||||
(false-if-exception
|
||||
(and=> signature narinfo-signature->canonical-sexp))
|
||||
str)))
|
||||
|
||||
(define &nar-signature-error (@@ (guix nar) &nar-signature-error))
|
||||
(define &nar-invalid-hash-error (@@ (guix nar) &nar-invalid-hash-error))
|
||||
|
||||
;;; XXX: The following function is nearly an exact copy of the one from
|
||||
;;; 'guix/nar.scm'. Factorize as soon as we know how to make the latter
|
||||
;;; public (see <https://lists.gnu.org/archive/html/guix-devel/2014-03/msg00097.html>).
|
||||
;;; Keep this one private to avoid confusion.
|
||||
(define* (assert-valid-signature signature hash port
|
||||
#:optional (acl (current-acl)))
|
||||
"Bail out if SIGNATURE, a string (as produced by 'canonical-sexp->string'),
|
||||
doesn't match HASH, a bytevector containing the expected hash for FILE."
|
||||
(let* ((&nar-signature-error (@@ (guix nar) &nar-signature-error))
|
||||
(&nar-invalid-hash-error (@@ (guix nar) &nar-invalid-hash-error))
|
||||
;; XXX: This is just to keep the errors happy; get a sensible
|
||||
;; filename.
|
||||
"Bail out if SIGNATURE, a canonical sexp, doesn't match HASH, a bytevector
|
||||
containing the expected hash for FILE."
|
||||
(let* (;; XXX: This is just to keep the errors happy; get a sensible
|
||||
;; file name.
|
||||
(file #f)
|
||||
(signature (catch 'gcry-error
|
||||
(lambda ()
|
||||
(string->canonical-sexp signature))
|
||||
(lambda (err . _)
|
||||
(raise (condition
|
||||
(&message
|
||||
(message "signature is not a valid \
|
||||
s-expression"))
|
||||
(&nar-signature-error
|
||||
(file file)
|
||||
(signature signature) (port port)))))))
|
||||
(subject (signature-subject signature))
|
||||
(data (signature-signed-data signature)))
|
||||
(if (and data subject)
|
||||
|
|
@ -324,25 +326,42 @@ s-expression"))
|
|||
(&nar-signature-error
|
||||
(signature signature) (file file) (port port)))))))
|
||||
|
||||
(define* (read-narinfo port #:optional url (acl (current-acl)))
|
||||
(define* (read-narinfo port #:optional url)
|
||||
"Read a narinfo from PORT. If URL is true, it must be a string used to
|
||||
build full URIs from relative URIs found while reading PORT."
|
||||
(let* ((str (utf8->string (get-bytevector-all port)))
|
||||
(rx (make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$"))
|
||||
(res (or (regexp-exec rx str)
|
||||
(leave (_ "cannot find the Signature line: ~a~%")
|
||||
str)))
|
||||
(hash (sha256 (string->utf8 (match:substring res 1))))
|
||||
(narinfo (alist->record (fields->alist (open-input-string str))
|
||||
(narinfo-maker str url)
|
||||
'("StorePath" "URL" "Compression"
|
||||
"FileHash" "FileSize" "NarHash" "NarSize"
|
||||
"References" "Deriver" "System"
|
||||
"Signature")))
|
||||
(signature (canonical-sexp->string (narinfo-signature narinfo))))
|
||||
(unless %allow-unauthenticated-substitutes?
|
||||
(assert-valid-signature signature hash port acl))
|
||||
narinfo))
|
||||
build full URIs from relative URIs found while reading PORT.
|
||||
|
||||
No authentication and authorization checks are performed here!"
|
||||
(let ((str (utf8->string (get-bytevector-all port))))
|
||||
(alist->record (call-with-input-string str fields->alist)
|
||||
(narinfo-maker str url)
|
||||
'("StorePath" "URL" "Compression"
|
||||
"FileHash" "FileSize" "NarHash" "NarSize"
|
||||
"References" "Deriver" "System"
|
||||
"Signature"))))
|
||||
|
||||
(define %signature-line-rx
|
||||
;; Regexp matching a signature line in a narinfo.
|
||||
(make-regexp "(.+)^[[:blank:]]*Signature:[[:blank:]].+$"))
|
||||
|
||||
(define* (assert-valid-narinfo narinfo #:optional (acl (current-acl)))
|
||||
"Raise an exception if NARINFO lacks a signature, has an invalid signature,
|
||||
or is signed by an unauthorized key."
|
||||
(let* ((contents (narinfo-contents narinfo))
|
||||
(res (regexp-exec %signature-line-rx contents)))
|
||||
(if (not res)
|
||||
(if %allow-unauthenticated-substitutes?
|
||||
narinfo
|
||||
(leave (_ "narinfo lacks a signature: ~s~%")
|
||||
contents))
|
||||
(let ((hash (sha256 (string->utf8 (match:substring res 1))))
|
||||
(signature (narinfo-signature narinfo)))
|
||||
(unless %allow-unauthenticated-substitutes?
|
||||
(assert-valid-signature signature hash #f acl))
|
||||
narinfo))))
|
||||
|
||||
(define (valid-narinfo? narinfo)
|
||||
"Return #t if NARINFO's signature is not valid."
|
||||
(false-if-exception (begin (assert-valid-narinfo narinfo) #t)))
|
||||
|
||||
(define (write-narinfo narinfo port)
|
||||
"Write NARINFO to PORT."
|
||||
|
|
@ -353,7 +372,8 @@ build full URIs from relative URIs found while reading PORT."
|
|||
(call-with-output-string (cut write-narinfo narinfo <>)))
|
||||
|
||||
(define (string->narinfo str cache-uri)
|
||||
"Return the narinfo represented by STR."
|
||||
"Return the narinfo represented by STR. Assume CACHE-URI as the base URI of
|
||||
the cache STR originates form."
|
||||
(call-with-input-string str (cut read-narinfo <> cache-uri)))
|
||||
|
||||
(define (fetch-narinfo cache path)
|
||||
|
|
@ -391,9 +411,9 @@ check what it has."
|
|||
(string-append %narinfo-cache-directory "/"
|
||||
(store-path-hash-part path)))
|
||||
|
||||
(define (cache-entry narinfo)
|
||||
(define (cache-entry cache-uri narinfo)
|
||||
`(narinfo (version 1)
|
||||
(cache-uri ,(narinfo-uri-base narinfo))
|
||||
(cache-uri ,cache-uri)
|
||||
(date ,(time-second now))
|
||||
(value ,(and=> narinfo narinfo->string))))
|
||||
|
||||
|
|
@ -432,7 +452,7 @@ check what it has."
|
|||
(when cache
|
||||
(with-atomic-file-output cache-file
|
||||
(lambda (out)
|
||||
(write (cache-entry narinfo) out))))
|
||||
(write (cache-entry (cache-url cache) narinfo) out))))
|
||||
narinfo))))
|
||||
|
||||
(define (remove-expired-cached-narinfos)
|
||||
|
|
@ -570,6 +590,21 @@ Internal tool to substitute a pre-built binary to a local build.\n"))
|
|||
(lambda (n proc lst)
|
||||
(par-map proc lst))))
|
||||
|
||||
(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))))
|
||||
(equal? (acl->public-keys acl) (list key)))))
|
||||
|
||||
(let ((acl (current-acl)))
|
||||
(when (or (null? acl) (singleton? acl))
|
||||
(warning (_ "ACL for archive imports seems to be uninitialized, \
|
||||
substitutes may be unavailable\n")))))
|
||||
|
||||
(define (guix-substitute-binary . args)
|
||||
"Implement the build daemon's substituter protocol."
|
||||
(mkdir-p %narinfo-cache-directory)
|
||||
|
|
@ -598,96 +633,102 @@ substituter disabled~%")
|
|||
(force-output (current-output-port))
|
||||
|
||||
(with-networking
|
||||
(match args
|
||||
(("--query")
|
||||
(let ((cache (delay (open-cache %cache-url))))
|
||||
(let loop ((command (read-line)))
|
||||
(or (eof-object? command)
|
||||
(begin
|
||||
(match (string-tokenize command)
|
||||
(("have" paths ..1)
|
||||
;; Return the subset of PATHS available in CACHE.
|
||||
(let ((substitutable
|
||||
(if cache
|
||||
(n-par-map* %lookup-threads
|
||||
(cut lookup-narinfo cache <>)
|
||||
paths)
|
||||
'())))
|
||||
(for-each (lambda (narinfo)
|
||||
(when narinfo
|
||||
(format #t "~a~%" (narinfo-path narinfo))))
|
||||
(filter narinfo? substitutable))
|
||||
(newline)))
|
||||
(("info" paths ..1)
|
||||
;; Reply info about PATHS if it's in CACHE.
|
||||
(let ((substitutable
|
||||
(if cache
|
||||
(n-par-map* %lookup-threads
|
||||
(cut lookup-narinfo cache <>)
|
||||
paths)
|
||||
'())))
|
||||
(for-each (lambda (narinfo)
|
||||
(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)))
|
||||
(filter narinfo? substitutable))
|
||||
(newline)))
|
||||
(wtf
|
||||
(error "unknown `--query' command" wtf)))
|
||||
(loop (read-line)))))))
|
||||
(("--substitute" store-path destination)
|
||||
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
|
||||
(let* ((cache (delay (open-cache %cache-url)))
|
||||
(narinfo (lookup-narinfo cache store-path))
|
||||
(uri (narinfo-uri narinfo)))
|
||||
;; Tell the daemon what the expected hash of the Nar itself is.
|
||||
(format #t "~a~%" (narinfo-hash narinfo))
|
||||
(with-error-handling ; for signature errors
|
||||
(match args
|
||||
(("--query")
|
||||
(let ((cache (delay (open-cache %cache-url))))
|
||||
(define (valid? obj)
|
||||
(and (narinfo? obj) (valid-narinfo? obj)))
|
||||
|
||||
(format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%"
|
||||
store-path (uri->string uri)
|
||||
(let loop ((command (read-line)))
|
||||
(or (eof-object? command)
|
||||
(begin
|
||||
(match (string-tokenize command)
|
||||
(("have" paths ..1)
|
||||
;; Return the subset of PATHS available in CACHE.
|
||||
(let ((substitutable
|
||||
(if cache
|
||||
(n-par-map* %lookup-threads
|
||||
(cut lookup-narinfo cache <>)
|
||||
paths)
|
||||
'())))
|
||||
(for-each (lambda (narinfo)
|
||||
(format #t "~a~%" (narinfo-path narinfo)))
|
||||
(filter valid? substitutable))
|
||||
(newline)))
|
||||
(("info" paths ..1)
|
||||
;; Reply info about PATHS if it's in CACHE.
|
||||
(let ((substitutable
|
||||
(if cache
|
||||
(n-par-map* %lookup-threads
|
||||
(cut lookup-narinfo cache <>)
|
||||
paths)
|
||||
'())))
|
||||
(for-each (lambda (narinfo)
|
||||
(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)))
|
||||
(filter valid? substitutable))
|
||||
(newline)))
|
||||
(wtf
|
||||
(error "unknown `--query' command" wtf)))
|
||||
(loop (read-line)))))))
|
||||
(("--substitute" store-path destination)
|
||||
;; Download STORE-PATH and add store it as a Nar in file DESTINATION.
|
||||
(let* ((cache (delay (open-cache %cache-url)))
|
||||
(narinfo (lookup-narinfo cache store-path))
|
||||
(uri (narinfo-uri narinfo)))
|
||||
;; Make sure it is signed and everything.
|
||||
(assert-valid-narinfo narinfo)
|
||||
|
||||
;; Use the Nar size as an estimate of the installed size.
|
||||
(narinfo-size narinfo)
|
||||
(and=> (narinfo-size narinfo)
|
||||
(cute / <> (expt 2. 20))))
|
||||
(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
|
||||
(current-error-port))))
|
||||
(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)
|
||||
(every (compose zero? cdr waitpid) pids))))
|
||||
(("--version")
|
||||
(show-version-and-exit "guix substitute-binary"))
|
||||
(("--help")
|
||||
(show-help))
|
||||
(opts
|
||||
(leave (_ "~a: unrecognized options~%") opts)))))
|
||||
;; Tell the daemon what the expected hash of the Nar itself is.
|
||||
(format #t "~a~%" (narinfo-hash narinfo))
|
||||
|
||||
(format (current-error-port) "downloading `~a' from `~a'~:[~*~; (~,1f MiB installed)~]...~%"
|
||||
store-path (uri->string uri)
|
||||
|
||||
;; Use the Nar size as an estimate of the installed size.
|
||||
(narinfo-size narinfo)
|
||||
(and=> (narinfo-size narinfo)
|
||||
(cute / <> (expt 2. 20))))
|
||||
(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
|
||||
(current-error-port))))
|
||||
(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)
|
||||
(every (compose zero? cdr waitpid) pids))))
|
||||
(("--version")
|
||||
(show-version-and-exit "guix substitute-binary"))
|
||||
(("--help")
|
||||
(show-help))
|
||||
(opts
|
||||
(leave (_ "~a: unrecognized options~%") opts))))))
|
||||
|
||||
|
||||
;;; Local Variables:
|
||||
|
|
|
|||
|
|
@ -24,7 +24,13 @@
|
|||
#:use-module (guix nar)
|
||||
#:use-module (guix pk-crypto)
|
||||
#:use-module (guix pki)
|
||||
#:use-module (guix config)
|
||||
#:use-module ((guix store) #:select (%store-prefix))
|
||||
#:use-module ((guix build utils) #:select (delete-file-recursively))
|
||||
#:use-module (rnrs bytevectors)
|
||||
#:use-module (rnrs io ports)
|
||||
#:use-module (web uri)
|
||||
#:use-module (srfi srfi-26)
|
||||
#:use-module (srfi srfi-34)
|
||||
#:use-module ((srfi srfi-64) #:hide (test-error)))
|
||||
|
||||
|
|
@ -36,52 +42,37 @@
|
|||
;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to
|
||||
;;; catch specific exceptions.
|
||||
(define-syntax-rule (test-error* name exp)
|
||||
(test-assert name
|
||||
(test-equal name
|
||||
1
|
||||
(catch 'quit
|
||||
(lambda ()
|
||||
exp
|
||||
#f)
|
||||
(const #t))))
|
||||
|
||||
(define %keypair
|
||||
;; (display (canonical-sexp->string
|
||||
;; (generate-key "(genkey (rsa (nbits 4:1024)))")))
|
||||
(string->canonical-sexp
|
||||
"(key-data
|
||||
(public-key
|
||||
(rsa
|
||||
(n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#)
|
||||
(e #010001#)
|
||||
)
|
||||
)
|
||||
(private-key
|
||||
(rsa
|
||||
(n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#)
|
||||
(e #010001#)
|
||||
(d #40E6D963EF143E9241BC10DE7A785C988C89EB1EC33253A5796AFB38FCC804D015500EC8CBCA0F5E318EE9D660DC19E7774E2E89BFD38379297EA87EFBDAC24BA32EE5339215382B2C89F5A817FD9131CA8E8A0A70D58E26E847AD0C447053671A6B2D7746087DE058A02B17701752B8A36EB414435921615AE7CAA8AC48E451#)
|
||||
(p #00EA88C0C19FE83C09285EF49FF88A1159357FD870031C20F15EF5103FBEB10925299BCA197F7143D6792A1BA7044EDA572EC94FA6B00889F9857216CF5B984403#)
|
||||
(q #00EAFE541EE9E0531255A85CADBEF64D5F679766D7209F521ADD131CF4B7DA9DF5414901342A146EE84FAA1E35EE0D0F6CE3F5F25989C0D1E9FA5B678D78C113C9#)
|
||||
(u #59C80FA2C48181F6855691C9D443619BA46C7648056E081697C370D8096E8EF165122D5E55F8FD6A2DCC404FA8BDCDC1FD20B4D76A433F25E8FD6901EC2DBDAD#)
|
||||
)
|
||||
)
|
||||
)"))
|
||||
(lambda (key value)
|
||||
value))))
|
||||
|
||||
(define %public-key
|
||||
(find-sexp-token %keypair 'public-key))
|
||||
;; This key is known to be in the ACL by default.
|
||||
(call-with-input-file (string-append %config-directory "/signing-key.pub")
|
||||
(compose string->canonical-sexp get-string-all)))
|
||||
|
||||
(define %private-key
|
||||
(find-sexp-token %keypair 'private-key))
|
||||
(call-with-input-file (string-append %config-directory "/signing-key.sec")
|
||||
(compose string->canonical-sexp get-string-all)))
|
||||
|
||||
(define (signature-body str)
|
||||
(define* (signature-body str #:key (public-key %public-key))
|
||||
"Return the signature of STR as the base64-encoded body of a narinfo's
|
||||
'Signature' field."
|
||||
(base64-encode
|
||||
(string->utf8
|
||||
(canonical-sexp->string
|
||||
(signature-sexp (bytevector->hash-data (sha256 (string->utf8 str))
|
||||
#:key-type 'rsa)
|
||||
%private-key
|
||||
%public-key)))))
|
||||
public-key)))))
|
||||
|
||||
(define %signature-body
|
||||
;; Body of the signature of the word "secret".
|
||||
(signature-body "secret"))
|
||||
|
||||
(define %wrong-public-key
|
||||
|
|
@ -93,9 +84,11 @@
|
|||
)"))
|
||||
|
||||
(define %wrong-signature
|
||||
(let* ((body (string->canonical-sexp
|
||||
(utf8->string
|
||||
(base64-decode %signature-body))))
|
||||
;; 'Signature' field where the public key doesn't match the private key used
|
||||
;; to make the signature.
|
||||
(let* ((body (string->canonical-sexp
|
||||
(utf8->string
|
||||
(base64-decode %signature-body))))
|
||||
(data (canonical-sexp->string (find-sexp-token body 'data)))
|
||||
(sig-val (canonical-sexp->string (find-sexp-token body 'sig-val)))
|
||||
(public-key (canonical-sexp->string %wrong-public-key))
|
||||
|
|
@ -106,14 +99,18 @@
|
|||
(string-append "1;irrelevant;" body*)))
|
||||
|
||||
(define* (signature str #:optional (body %signature-body))
|
||||
"Return the 'Signature' field value with STR as the version part and BODY as
|
||||
the actual base64-encoded signature part."
|
||||
(string-append str ";irrelevant;" body))
|
||||
|
||||
(define %signature
|
||||
;; Signature computed over the word "secret".
|
||||
(signature "1" %signature-body))
|
||||
|
||||
(define %acl
|
||||
(public-keys->acl (list %public-key)))
|
||||
|
||||
|
||||
(test-begin "substitute-binary")
|
||||
|
||||
(test-error* "not a number"
|
||||
|
|
@ -127,7 +124,7 @@
|
|||
|
||||
(define-syntax-rule (test-error-condition name pred exp)
|
||||
(test-assert name
|
||||
(guard (condition ((pred condition) (pk 'true condition #t))
|
||||
(guard (condition ((pred condition) #t)
|
||||
(else #f))
|
||||
exp
|
||||
#f)))
|
||||
|
|
@ -135,63 +132,142 @@
|
|||
;;; XXX: Do we need a better predicate hierarchy for these tests?
|
||||
(test-error-condition "corrupt signature data"
|
||||
nar-signature-error?
|
||||
(assert-valid-signature "invalid sexp" "irrelevant"
|
||||
(assert-valid-signature (string->canonical-sexp "(foo bar baz)") "irrelevant"
|
||||
(open-input-string "irrelevant")
|
||||
%acl))
|
||||
|
||||
(test-error-condition "unauthorized public key"
|
||||
nar-signature-error?
|
||||
(assert-valid-signature (canonical-sexp->string
|
||||
(narinfo-signature->canonical-sexp %signature))
|
||||
(assert-valid-signature (narinfo-signature->canonical-sexp %signature)
|
||||
"irrelevant"
|
||||
(open-input-string "irrelevant")
|
||||
(public-keys->acl '())))
|
||||
|
||||
(test-error-condition "invalid signature"
|
||||
nar-signature-error?
|
||||
(assert-valid-signature (canonical-sexp->string
|
||||
(narinfo-signature->canonical-sexp
|
||||
%wrong-signature))
|
||||
(assert-valid-signature (narinfo-signature->canonical-sexp
|
||||
%wrong-signature)
|
||||
(sha256 (string->utf8 "secret"))
|
||||
(open-input-string "irrelevant")
|
||||
(public-keys->acl (list %wrong-public-key))))
|
||||
|
||||
|
||||
(define %narinfo
|
||||
"StorePath: /nix/store/foo
|
||||
(string-append "StorePath: " (%store-prefix)
|
||||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo
|
||||
URL: nar/foo
|
||||
Compression: bzip2
|
||||
NarHash: sha256:7
|
||||
NarSize: 42
|
||||
References: bar baz
|
||||
Deriver: foo.drv
|
||||
System: mips64el-linux\n")
|
||||
Deriver: " (%store-prefix) "/foo.drv
|
||||
System: mips64el-linux\n"))
|
||||
|
||||
(define (narinfo sig)
|
||||
"Return a narinfo with SIG as its 'Signature' field."
|
||||
(format #f "~aSignature: ~a~%" %narinfo sig))
|
||||
|
||||
(define %signed-narinfo
|
||||
;; Narinfo with a valid signature.
|
||||
(narinfo (signature "1" (signature-body %narinfo))))
|
||||
|
||||
(test-error-condition "invalid hash"
|
||||
(define (call-with-narinfo narinfo thunk)
|
||||
"Call THUNK in a context where $GUIX_BINARY_SUBSTITUTE_URL is populated with
|
||||
a file for NARINFO."
|
||||
(let ((narinfo-directory (and=> (string->uri (getenv
|
||||
"GUIX_BINARY_SUBSTITUTE_URL"))
|
||||
uri-path))
|
||||
(cache-directory (string-append (getenv "XDG_CACHE_HOME")
|
||||
"/guix/substitute-binary/")))
|
||||
(dynamic-wind
|
||||
(lambda ()
|
||||
(when (file-exists? cache-directory)
|
||||
(delete-file-recursively cache-directory))
|
||||
(call-with-output-file (string-append narinfo-directory
|
||||
"/nix-cache-info")
|
||||
(lambda (port)
|
||||
(format port "StoreDir: ~a\nWantMassQuery: 0\n"
|
||||
(%store-prefix))))
|
||||
(call-with-output-file (string-append narinfo-directory "/"
|
||||
"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
|
||||
".narinfo")
|
||||
(cut display narinfo <>))
|
||||
|
||||
(set! (@@ (guix scripts substitute-binary)
|
||||
%allow-unauthenticated-substitutes?)
|
||||
#f))
|
||||
thunk
|
||||
(lambda ()
|
||||
(delete-file-recursively cache-directory)))))
|
||||
|
||||
(define-syntax-rule (with-narinfo narinfo body ...)
|
||||
(call-with-narinfo narinfo (lambda () body ...)))
|
||||
|
||||
|
||||
(test-equal "query narinfo with invalid hash"
|
||||
;; The hash of '%signature' is computed over the word "secret", not
|
||||
;; '%narinfo'.
|
||||
nar-invalid-hash-error?
|
||||
(read-narinfo (open-input-string (narinfo %signature))
|
||||
"https://example.com" %acl))
|
||||
""
|
||||
|
||||
(test-assert "valid read-narinfo"
|
||||
(read-narinfo (open-input-string %signed-narinfo)
|
||||
"https://example.com" %acl))
|
||||
(with-narinfo (narinfo %signature)
|
||||
(string-trim-both
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(with-input-from-string (string-append "have " (%store-prefix)
|
||||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||||
(lambda ()
|
||||
(guix-substitute-binary "--query"))))))))
|
||||
|
||||
(test-equal "valid write-narinfo"
|
||||
%signed-narinfo
|
||||
(call-with-output-string
|
||||
(lambda (port)
|
||||
(write-narinfo (read-narinfo (open-input-string %signed-narinfo)
|
||||
"https://example.com" %acl)
|
||||
port))))
|
||||
(test-equal "query narinfo signed with authorized key"
|
||||
(string-append (%store-prefix) "/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||||
|
||||
(with-narinfo %signed-narinfo
|
||||
(string-trim-both
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(with-input-from-string (string-append "have " (%store-prefix)
|
||||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||||
(lambda ()
|
||||
(guix-substitute-binary "--query"))))))))
|
||||
|
||||
(test-equal "query narinfo signed with unauthorized key"
|
||||
"" ; not substitutable
|
||||
|
||||
(with-narinfo (narinfo (signature "1"
|
||||
(signature-body %narinfo
|
||||
#:public-key %wrong-public-key)))
|
||||
(string-trim-both
|
||||
(with-output-to-string
|
||||
(lambda ()
|
||||
(with-input-from-string (string-append "have " (%store-prefix)
|
||||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||||
(lambda ()
|
||||
(guix-substitute-binary "--query"))))))))
|
||||
|
||||
(test-error* "substitute, invalid hash"
|
||||
;; The hash of '%signature' is computed over the word "secret", not
|
||||
;; '%narinfo'.
|
||||
(with-narinfo (narinfo %signature)
|
||||
(guix-substitute-binary "--substitute"
|
||||
(string-append (%store-prefix)
|
||||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||||
"foo")))
|
||||
|
||||
(test-error* "substitute, unauthorized key"
|
||||
(with-narinfo (narinfo (signature "1"
|
||||
(signature-body %narinfo
|
||||
#:public-key %wrong-public-key)))
|
||||
(guix-substitute-binary "--substitute"
|
||||
(string-append (%store-prefix)
|
||||
"/aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa-foo")
|
||||
"foo")))
|
||||
|
||||
(test-end "substitute-binary")
|
||||
|
||||
|
||||
(exit (= (test-runner-fail-count (test-runner-current)) 0))
|
||||
|
||||
;;; Local Variables:
|
||||
;;; eval: (put 'with-narinfo 'scheme-indent-function 1)
|
||||
;;; eval: (put 'test-error* 'scheme-indent-function 1)
|
||||
;;; End:
|
||||
|
|
|
|||
Loading…
Reference in New Issue