Browse Source
* guix/scripts/substitute-binary.scm (<narinfo>): Add the 'signature' and 'contents' fields. (narinfo-signature->canonical-sexp): New function. (narinfo-maker): Add the 'signature' argument and use it. (assert-valid-signature): New function. (read-narinfo): Support the Signature field. (write-narinfo): Use 'narinfo-contents'. (%allow-unauthenticated-substitutes?): New variable. * guix/base64.scm, tests/base64.scm, tests/substitute-binary.scm: New files. * Makefile.am (SCM_TESTS): Add tests/base64.scm and tests/substitute-binary.scm. (MODULES): Add guix/base64.scm. * test-env.in: Set 'GUIX_ALLOW_UNAUTHENTICATED_SUBSTITUTES'.version-0.8.3
Nikita Karetnikov
8 years ago
committed by
Ludovic Courtès
Ludovic Courtès
6 changed files with 600 additions and 44 deletions
@ -0,0 +1,212 @@ |
|||
;; -*- mode: scheme; coding: utf-8 -*- |
|||
;; |
|||
;; This module was renamed from (weinholt text base64 (1 0 20100612)) to |
|||
;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on |
|||
;; February 12, 2014. |
|||
;; |
|||
;; Copyright © 2009, 2010 Göran Weinholt <goran@weinholt.se> |
|||
;; |
|||
;; This program 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. |
|||
;; |
|||
;; This program 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 this program. If not, see <http://www.gnu.org/licenses/>. |
|||
#!r6rs |
|||
|
|||
;; RFC 4648 Base-N Encodings |
|||
|
|||
(library (guix base64) |
|||
(export base64-encode |
|||
base64-decode |
|||
base64-alphabet |
|||
base64url-alphabet |
|||
get-delimited-base64 |
|||
put-delimited-base64) |
|||
(import (rnrs) |
|||
(only (srfi :13 strings) |
|||
string-index |
|||
string-prefix? string-suffix? |
|||
string-concatenate string-trim-both)) |
|||
|
|||
(define base64-alphabet |
|||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") |
|||
|
|||
(define base64url-alphabet |
|||
"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") |
|||
|
|||
(define base64-encode |
|||
(case-lambda |
|||
;; Simple interface. Returns a string containing the canonical |
|||
;; base64 representation of the given bytevector. |
|||
((bv) |
|||
(base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f)) |
|||
((bv start) |
|||
(base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f)) |
|||
((bv start end) |
|||
(base64-encode bv start end #f #f base64-alphabet #f)) |
|||
((bv start end line-length) |
|||
(base64-encode bv start end line-length #f base64-alphabet #f)) |
|||
((bv start end line-length no-padding) |
|||
(base64-encode bv start end line-length no-padding base64-alphabet #f)) |
|||
((bv start end line-length no-padding alphabet) |
|||
(base64-encode bv start end line-length no-padding alphabet #f)) |
|||
;; Base64 encodes the bytes [start,end[ in the given bytevector. |
|||
;; Lines are limited to line-length characters (unless #f), |
|||
;; which must be a multiple of four. To omit the padding |
|||
;; characters (#\=) set no-padding to a true value. If port is |
|||
;; #f, returns a string. |
|||
((bv start end line-length no-padding alphabet port) |
|||
(assert (or (not line-length) (zero? (mod line-length 4)))) |
|||
(let-values (((p extract) (if port |
|||
(values port (lambda () (values))) |
|||
(open-string-output-port)))) |
|||
(letrec ((put (if line-length |
|||
(let ((chars 0)) |
|||
(lambda (p c) |
|||
(when (fx=? chars line-length) |
|||
(set! chars 0) |
|||
(put-char p #\linefeed)) |
|||
(set! chars (fx+ chars 1)) |
|||
(put-char p c))) |
|||
put-char))) |
|||
(let lp ((i start)) |
|||
(cond ((= i end)) |
|||
((<= (+ i 3) end) |
|||
(let ((x (bytevector-uint-ref bv i (endianness big) 3))) |
|||
(put p (string-ref alphabet (fxbit-field x 18 24))) |
|||
(put p (string-ref alphabet (fxbit-field x 12 18))) |
|||
(put p (string-ref alphabet (fxbit-field x 6 12))) |
|||
(put p (string-ref alphabet (fxbit-field x 0 6))) |
|||
(lp (+ i 3)))) |
|||
((<= (+ i 2) end) |
|||
(let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8))) |
|||
(put p (string-ref alphabet (fxbit-field x 18 24))) |
|||
(put p (string-ref alphabet (fxbit-field x 12 18))) |
|||
(put p (string-ref alphabet (fxbit-field x 6 12))) |
|||
(unless no-padding |
|||
(put p #\=)))) |
|||
(else |
|||
(let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16))) |
|||
(put p (string-ref alphabet (fxbit-field x 18 24))) |
|||
(put p (string-ref alphabet (fxbit-field x 12 18))) |
|||
(unless no-padding |
|||
(put p #\=) |
|||
(put p #\=))))))) |
|||
(extract))))) |
|||
|
|||
;; Decodes a base64 string. The string must contain only pure |
|||
;; unpadded base64 data. |
|||
(define base64-decode |
|||
(case-lambda |
|||
((str) |
|||
(base64-decode str base64-alphabet #f)) |
|||
((str alphabet) |
|||
(base64-decode str alphabet #f)) |
|||
((str alphabet port) |
|||
(unless (zero? (mod (string-length str) 4)) |
|||
(error 'base64-decode |
|||
"input string must be a multiple of four characters")) |
|||
(let-values (((p extract) (if port |
|||
(values port (lambda () (values))) |
|||
(open-bytevector-output-port)))) |
|||
(do ((i 0 (+ i 4))) |
|||
((= i (string-length str)) |
|||
(extract)) |
|||
(let ((c1 (string-ref str i)) |
|||
(c2 (string-ref str (+ i 1))) |
|||
(c3 (string-ref str (+ i 2))) |
|||
(c4 (string-ref str (+ i 3)))) |
|||
;; TODO: be more clever than string-index |
|||
(let ((i1 (string-index alphabet c1)) |
|||
(i2 (string-index alphabet c2)) |
|||
(i3 (string-index alphabet c3)) |
|||
(i4 (string-index alphabet c4))) |
|||
(cond ((and i1 i2 i3 i4) |
|||
(let ((x (fxior (fxarithmetic-shift-left i1 18) |
|||
(fxarithmetic-shift-left i2 12) |
|||
(fxarithmetic-shift-left i3 6) |
|||
i4))) |
|||
(put-u8 p (fxbit-field x 16 24)) |
|||
(put-u8 p (fxbit-field x 8 16)) |
|||
(put-u8 p (fxbit-field x 0 8)))) |
|||
((and i1 i2 i3 (char=? c4 #\=) |
|||
(= i (- (string-length str) 4))) |
|||
(let ((x (fxior (fxarithmetic-shift-left i1 18) |
|||
(fxarithmetic-shift-left i2 12) |
|||
(fxarithmetic-shift-left i3 6)))) |
|||
(put-u8 p (fxbit-field x 16 24)) |
|||
(put-u8 p (fxbit-field x 8 16)))) |
|||
((and i1 i2 (char=? c3 #\=) (char=? c4 #\=) |
|||
(= i (- (string-length str) 4))) |
|||
(let ((x (fxior (fxarithmetic-shift-left i1 18) |
|||
(fxarithmetic-shift-left i2 12)))) |
|||
(put-u8 p (fxbit-field x 16 24)))) |
|||
(else |
|||
(error 'base64-decode "invalid input" |
|||
(list c1 c2 c3 c4))))))))))) |
|||
|
|||
(define (get-line-comp f port) |
|||
(if (port-eof? port) |
|||
(eof-object) |
|||
(f (get-line port)))) |
|||
|
|||
;; Reads the common -----BEGIN/END type----- delimited format from |
|||
;; the given port. Returns two values: a string with the type and a |
|||
;; bytevector containing the base64 decoded data. The second value |
|||
;; is the eof object if there is an eof before the BEGIN delimiter. |
|||
(define (get-delimited-base64 port) |
|||
(define (get-first-data-line port) |
|||
;; Some MIME data has header fields in the same format as mail |
|||
;; or http. These are ignored. |
|||
(let ((line (get-line-comp string-trim-both port))) |
|||
(cond ((eof-object? line) line) |
|||
((string-index line #\:) |
|||
(let lp () ;read until empty line |
|||
(let ((line (get-line-comp string-trim-both port))) |
|||
(if (string=? line "") |
|||
(get-line-comp string-trim-both port) |
|||
(lp))))) |
|||
(else line)))) |
|||
(let ((line (get-line-comp string-trim-both port))) |
|||
(cond ((eof-object? line) |
|||
(values "" (eof-object))) |
|||
((string=? line "") |
|||
(get-delimited-base64 port)) |
|||
((and (string-prefix? "-----BEGIN " line) |
|||
(string-suffix? "-----" line)) |
|||
(let* ((type (substring line 11 (- (string-length line) 5))) |
|||
(endline (string-append "-----END " type "-----"))) |
|||
(let-values (((outp extract) (open-bytevector-output-port))) |
|||
(let lp ((line (get-first-data-line port))) |
|||
(cond ((eof-object? line) |
|||
(error 'get-delimited-base64 |
|||
"unexpected end of file")) |
|||
((string-prefix? "-" line) |
|||
(unless (string=? line endline) |
|||
(error 'get-delimited-base64 |
|||
"bad end delimiter" type line)) |
|||
(values type (extract))) |
|||
(else |
|||
(unless (and (= (string-length line) 5) |
|||
(string-prefix? "=" line)) ;Skip Radix-64 checksum |
|||
(base64-decode line base64-alphabet outp)) |
|||
(lp (get-line-comp string-trim-both port)))))))) |
|||
(else ;skip garbage (like in openssl x509 -in foo -text output). |
|||
(get-delimited-base64 port))))) |
|||
|
|||
(define put-delimited-base64 |
|||
(case-lambda |
|||
((port type bv line-length) |
|||
(display (string-append "-----BEGIN " type "-----\n") port) |
|||
(base64-encode bv 0 (bytevector-length bv) |
|||
line-length #f base64-alphabet port) |
|||
(display (string-append "\n-----END " type "-----\n") port)) |
|||
((port type bv) |
|||
(put-delimited-base64 port type bv 76))))) |
|||
@ -0,0 +1,59 @@ |
|||
;;; GNU Guix --- Functional package management for GNU |
|||
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> |
|||
;;; |
|||
;;; This file is part of GNU Guix. |
|||
;;; |
|||
;;; GNU Guix is free software; you can redistribute it and/or modify it |
|||
;;; under the terms of the GNU General Public License as published by |
|||
;;; the Free Software Foundation; either version 3 of the License, or (at |
|||
;;; your option) any later version. |
|||
;;; |
|||
;;; GNU Guix is distributed in the hope that it will be useful, but |
|||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
;;; GNU General Public License for more details. |
|||
;;; |
|||
;;; You should have received a copy of the GNU General Public License |
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
|||
|
|||
(define-module (test-base64) |
|||
#:use-module (guix base64) |
|||
#:use-module (rnrs bytevectors) |
|||
#:use-module (srfi srfi-64)) |
|||
|
|||
(define (string->base64 str) |
|||
(base64-encode (string->utf8 str))) |
|||
|
|||
;;; Test vectors from <https://tools.ietf.org/rfc/rfc4648.txt>. |
|||
|
|||
(test-begin "base64") |
|||
|
|||
(test-equal "empty string" |
|||
(string->base64 "") |
|||
"") |
|||
|
|||
(test-equal "f" |
|||
(string->base64 "f") |
|||
"Zg==") |
|||
|
|||
(test-equal "fo" |
|||
(string->base64 "fo") |
|||
"Zm8=") |
|||
|
|||
(test-equal "foo" |
|||
(string->base64 "foo") |
|||
"Zm9v") |
|||
|
|||
(test-equal "foob" |
|||
(string->base64 "foob") |
|||
"Zm9vYg==") |
|||
|
|||
(test-equal "fooba" |
|||
(string->base64 "fooba") |
|||
"Zm9vYmE=") |
|||
|
|||
(test-equal "foobar" |
|||
(string->base64 "foobar") |
|||
"Zm9vYmFy") |
|||
|
|||
(test-end "base64") |
|||
@ -0,0 +1,197 @@ |
|||
;;; GNU Guix --- Functional package management for GNU |
|||
;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> |
|||
;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> |
|||
;;; |
|||
;;; This file is part of GNU Guix. |
|||
;;; |
|||
;;; GNU Guix is free software; you can redistribute it and/or modify it |
|||
;;; under the terms of the GNU General Public License as published by |
|||
;;; the Free Software Foundation; either version 3 of the License, or (at |
|||
;;; your option) any later version. |
|||
;;; |
|||
;;; GNU Guix is distributed in the hope that it will be useful, but |
|||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of |
|||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|||
;;; GNU General Public License for more details. |
|||
;;; |
|||
;;; You should have received a copy of the GNU General Public License |
|||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. |
|||
|
|||
(define-module (test-substitute-binary) |
|||
#:use-module (guix scripts substitute-binary) |
|||
#:use-module (guix base64) |
|||
#:use-module (guix hash) |
|||
#:use-module (guix nar) |
|||
#:use-module (guix pk-crypto) |
|||
#:use-module (guix pki) |
|||
#:use-module (rnrs bytevectors) |
|||
#:use-module (srfi srfi-34) |
|||
#:use-module ((srfi srfi-64) #:hide (test-error))) |
|||
|
|||
(define assert-valid-signature |
|||
;; (guix scripts substitute-binary) does not export this function in order to |
|||
;; avoid misuse. |
|||
(@@ (guix scripts substitute-binary) assert-valid-signature)) |
|||
|
|||
;;; 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 |
|||
(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#) |
|||
) |
|||
) |
|||
)")) |
|||
|
|||
(define %public-key |
|||
(find-sexp-token %keypair 'public-key)) |
|||
|
|||
(define %private-key |
|||
(find-sexp-token %keypair 'private-key)) |
|||
|
|||
(define (signature-body str) |
|||
(base64-encode |
|||
(string->utf8 |
|||
(canonical-sexp->string |
|||
(signature-sexp (bytevector->hash-data (sha256 (string->utf8 str)) |
|||
#:key-type 'rsa) |
|||
%private-key |
|||
%public-key))))) |
|||
|
|||
(define %signature-body |
|||
(signature-body "secret")) |
|||
|
|||
(define %wrong-public-key |
|||
(string->canonical-sexp "(public-key |
|||
(rsa |
|||
(n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#) |
|||
(e #010001#) |
|||
) |
|||
)")) |
|||
|
|||
(define %wrong-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)) |
|||
(body* (base64-encode |
|||
(string->utf8 |
|||
(string-append "(signature \n" data sig-val |
|||
public-key " )\n"))))) |
|||
(string-append "1;irrelevant;" body*))) |
|||
|
|||
(define* (signature str #:optional (body %signature-body)) |
|||
(string-append str ";irrelevant;" body)) |
|||
|
|||
(define %signature |
|||
(signature "1" %signature-body)) |
|||
|
|||
(define %acl |
|||
(public-keys->acl (list %public-key))) |
|||
|
|||
(test-begin "substitute-binary") |
|||
|
|||
(test-error* "not a number" |
|||
(narinfo-signature->canonical-sexp (signature "not a number"))) |
|||
|
|||
(test-error* "wrong version number" |
|||
(narinfo-signature->canonical-sexp (signature "2"))) |
|||
|
|||
(test-assert "valid narinfo-signature->canonical-sexp" |
|||
(canonical-sexp? (narinfo-signature->canonical-sexp %signature))) |
|||
|
|||
(define-syntax-rule (test-error-condition name pred exp) |
|||
(test-assert name |
|||
(guard (condition ((pred condition) (pk 'true condition #t)) |
|||
(else #f)) |
|||
exp |
|||
#f))) |
|||
|
|||
;;; 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" |
|||
(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)) |
|||
"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)) |
|||
(sha256 (string->utf8 "secret")) |
|||
(open-input-string "irrelevant") |
|||
(public-keys->acl (list %wrong-public-key)))) |
|||
|
|||
(define %narinfo |
|||
"StorePath: /nix/store/foo |
|||
URL: nar/foo |
|||
Compression: bzip2 |
|||
NarHash: sha256:7 |
|||
NarSize: 42 |
|||
References: bar baz |
|||
Deriver: foo.drv |
|||
System: mips64el-linux\n") |
|||
|
|||
(define (narinfo sig) |
|||
(format #f "~aSignature: ~a~%" %narinfo sig)) |
|||
|
|||
(define %signed-narinfo |
|||
(narinfo (signature "1" (signature-body %narinfo)))) |
|||
|
|||
(test-error-condition "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)) |
|||
|
|||
(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-end "substitute-binary") |
|||
|
|||
|
|||
(exit (= (test-runner-fail-count (test-runner-current)) 0)) |
|||
Loading…
Reference in new issue