Commit | Line | Data |
---|---|---|
e9c6c584 NK |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org> | |
3 | ;;; Copyright © 2014 Ludovic Courtès <ludo@gnu.org> | |
4 | ;;; | |
5 | ;;; This file is part of GNU Guix. | |
6 | ;;; | |
7 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
8 | ;;; under the terms of the GNU General Public License as published by | |
9 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
10 | ;;; your option) any later version. | |
11 | ;;; | |
12 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
13 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
14 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
15 | ;;; GNU General Public License for more details. | |
16 | ;;; | |
17 | ;;; You should have received a copy of the GNU General Public License | |
18 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
19 | ||
20 | (define-module (test-substitute-binary) | |
21 | #:use-module (guix scripts substitute-binary) | |
22 | #:use-module (guix base64) | |
23 | #:use-module (guix hash) | |
24 | #:use-module (guix nar) | |
25 | #:use-module (guix pk-crypto) | |
26 | #:use-module (guix pki) | |
27 | #:use-module (rnrs bytevectors) | |
28 | #:use-module (srfi srfi-34) | |
29 | #:use-module ((srfi srfi-64) #:hide (test-error))) | |
30 | ||
31 | (define assert-valid-signature | |
32 | ;; (guix scripts substitute-binary) does not export this function in order to | |
33 | ;; avoid misuse. | |
34 | (@@ (guix scripts substitute-binary) assert-valid-signature)) | |
35 | ||
36 | ;;; XXX: Replace with 'test-error' from SRFI-64 as soon as it allow us to | |
37 | ;;; catch specific exceptions. | |
38 | (define-syntax-rule (test-error* name exp) | |
39 | (test-assert name | |
40 | (catch 'quit | |
41 | (lambda () | |
42 | exp | |
43 | #f) | |
44 | (const #t)))) | |
45 | ||
46 | (define %keypair | |
47 | ;; (display (canonical-sexp->string | |
48 | ;; (generate-key "(genkey (rsa (nbits 4:1024)))"))) | |
49 | (string->canonical-sexp | |
50 | "(key-data | |
51 | (public-key | |
52 | (rsa | |
53 | (n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#) | |
54 | (e #010001#) | |
55 | ) | |
56 | ) | |
57 | (private-key | |
58 | (rsa | |
59 | (n #00D74A00F16DD109A8E773291856A4EF9EE2C2D975E0BC207EA24245C9CFE39E32D8BA5442A2720A57E3A9D9E55E596A8B19CB2EF844E5E859362593914BD626433C887FB798AE87E1DA95D372DFC81E220B8802B04CEC818D9B6B4E2108817755AEBAC23D2FD2B0AB82A52FD785194F3C2D7B9327212588DB74D464EEE5DC9F5B#) | |
60 | (e #010001#) | |
61 | (d #40E6D963EF143E9241BC10DE7A785C988C89EB1EC33253A5796AFB38FCC804D015500EC8CBCA0F5E318EE9D660DC19E7774E2E89BFD38379297EA87EFBDAC24BA32EE5339215382B2C89F5A817FD9131CA8E8A0A70D58E26E847AD0C447053671A6B2D7746087DE058A02B17701752B8A36EB414435921615AE7CAA8AC48E451#) | |
62 | (p #00EA88C0C19FE83C09285EF49FF88A1159357FD870031C20F15EF5103FBEB10925299BCA197F7143D6792A1BA7044EDA572EC94FA6B00889F9857216CF5B984403#) | |
63 | (q #00EAFE541EE9E0531255A85CADBEF64D5F679766D7209F521ADD131CF4B7DA9DF5414901342A146EE84FAA1E35EE0D0F6CE3F5F25989C0D1E9FA5B678D78C113C9#) | |
64 | (u #59C80FA2C48181F6855691C9D443619BA46C7648056E081697C370D8096E8EF165122D5E55F8FD6A2DCC404FA8BDCDC1FD20B4D76A433F25E8FD6901EC2DBDAD#) | |
65 | ) | |
66 | ) | |
67 | )")) | |
68 | ||
69 | (define %public-key | |
70 | (find-sexp-token %keypair 'public-key)) | |
71 | ||
72 | (define %private-key | |
73 | (find-sexp-token %keypair 'private-key)) | |
74 | ||
75 | (define (signature-body str) | |
76 | (base64-encode | |
77 | (string->utf8 | |
78 | (canonical-sexp->string | |
79 | (signature-sexp (bytevector->hash-data (sha256 (string->utf8 str)) | |
80 | #:key-type 'rsa) | |
81 | %private-key | |
82 | %public-key))))) | |
83 | ||
84 | (define %signature-body | |
85 | (signature-body "secret")) | |
86 | ||
87 | (define %wrong-public-key | |
88 | (string->canonical-sexp "(public-key | |
89 | (rsa | |
90 | (n #00E05873AC2B168760343145918E954EE9AB73C026355693B192E01EE835261AA689E9EF46642E895BCD65C648524059FC450E4BA77A68F4C52D0E39EF0CC9359709AB6AAB153B63782201871325B0FDA19CB401CD99FD0C31A91CA9000AA90A77E82B89E036FB63BC1D3961207469B3B12468977148D376F8012BB12A4B11A8F1#) | |
91 | (e #010001#) | |
92 | ) | |
93 | )")) | |
94 | ||
95 | (define %wrong-signature | |
96 | (let* ((body (string->canonical-sexp | |
97 | (utf8->string | |
98 | (base64-decode %signature-body)))) | |
99 | (data (canonical-sexp->string (find-sexp-token body 'data))) | |
100 | (sig-val (canonical-sexp->string (find-sexp-token body 'sig-val))) | |
101 | (public-key (canonical-sexp->string %wrong-public-key)) | |
102 | (body* (base64-encode | |
103 | (string->utf8 | |
104 | (string-append "(signature \n" data sig-val | |
105 | public-key " )\n"))))) | |
106 | (string-append "1;irrelevant;" body*))) | |
107 | ||
108 | (define* (signature str #:optional (body %signature-body)) | |
109 | (string-append str ";irrelevant;" body)) | |
110 | ||
111 | (define %signature | |
112 | (signature "1" %signature-body)) | |
113 | ||
114 | (define %acl | |
115 | (public-keys->acl (list %public-key))) | |
116 | ||
117 | (test-begin "substitute-binary") | |
118 | ||
119 | (test-error* "not a number" | |
120 | (narinfo-signature->canonical-sexp (signature "not a number"))) | |
121 | ||
122 | (test-error* "wrong version number" | |
123 | (narinfo-signature->canonical-sexp (signature "2"))) | |
124 | ||
125 | (test-assert "valid narinfo-signature->canonical-sexp" | |
126 | (canonical-sexp? (narinfo-signature->canonical-sexp %signature))) | |
127 | ||
128 | (define-syntax-rule (test-error-condition name pred exp) | |
129 | (test-assert name | |
130 | (guard (condition ((pred condition) (pk 'true condition #t)) | |
131 | (else #f)) | |
132 | exp | |
133 | #f))) | |
134 | ||
135 | ;;; XXX: Do we need a better predicate hierarchy for these tests? | |
136 | (test-error-condition "corrupt signature data" | |
137 | nar-signature-error? | |
138 | (assert-valid-signature "invalid sexp" "irrelevant" | |
139 | (open-input-string "irrelevant") | |
140 | %acl)) | |
141 | ||
142 | (test-error-condition "unauthorized public key" | |
143 | nar-signature-error? | |
144 | (assert-valid-signature (canonical-sexp->string | |
145 | (narinfo-signature->canonical-sexp %signature)) | |
146 | "irrelevant" | |
147 | (open-input-string "irrelevant") | |
148 | (public-keys->acl '()))) | |
149 | ||
150 | (test-error-condition "invalid signature" | |
151 | nar-signature-error? | |
152 | (assert-valid-signature (canonical-sexp->string | |
153 | (narinfo-signature->canonical-sexp | |
154 | %wrong-signature)) | |
155 | (sha256 (string->utf8 "secret")) | |
156 | (open-input-string "irrelevant") | |
157 | (public-keys->acl (list %wrong-public-key)))) | |
158 | ||
159 | (define %narinfo | |
160 | "StorePath: /nix/store/foo | |
161 | URL: nar/foo | |
162 | Compression: bzip2 | |
163 | NarHash: sha256:7 | |
164 | NarSize: 42 | |
165 | References: bar baz | |
166 | Deriver: foo.drv | |
167 | System: mips64el-linux\n") | |
168 | ||
169 | (define (narinfo sig) | |
170 | (format #f "~aSignature: ~a~%" %narinfo sig)) | |
171 | ||
172 | (define %signed-narinfo | |
173 | (narinfo (signature "1" (signature-body %narinfo)))) | |
174 | ||
175 | (test-error-condition "invalid hash" | |
176 | ;; The hash of '%signature' is computed over the word "secret", not | |
177 | ;; '%narinfo'. | |
178 | nar-invalid-hash-error? | |
179 | (read-narinfo (open-input-string (narinfo %signature)) | |
180 | "https://example.com" %acl)) | |
181 | ||
182 | (test-assert "valid read-narinfo" | |
183 | (read-narinfo (open-input-string %signed-narinfo) | |
184 | "https://example.com" %acl)) | |
185 | ||
186 | (test-equal "valid write-narinfo" | |
187 | %signed-narinfo | |
188 | (call-with-output-string | |
189 | (lambda (port) | |
190 | (write-narinfo (read-narinfo (open-input-string %signed-narinfo) | |
191 | "https://example.com" %acl) | |
192 | port)))) | |
193 | ||
194 | (test-end "substitute-binary") | |
195 | ||
196 | \f | |
197 | (exit (= (test-runner-fail-count (test-runner-current)) 0)) |