Clean up word replication.
[gnupg.git] / tests / openpgp / defs.scm
1 ;; Common definitions for the OpenPGP test scripts.
2 ;;
3 ;; Copyright (C) 2016, 2017 g10 Code GmbH
4 ;;
5 ;; This file is part of GnuPG.
6 ;;
7 ;; GnuPG is free software; you can redistribute it and/or modify
8 ;; it under the terms of the GNU General Public License as published by
9 ;; the Free Software Foundation; either version 3 of the License, or
10 ;; (at your option) any later version.
11 ;;
12 ;; GnuPG is distributed in the hope that it will be useful,
13 ;; but 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 this program; if not, see <http://www.gnu.org/licenses/>.
19
20 ;;
21 ;; Constants.
22 ;;
23
24 (define usrname1 "one@example.com")
25 (define usrpass1 "def")
26 (define usrname2 "two@example.com")
27 (define usrpass2 "")
28 (define usrname3 "three@example.com")
29 (define usrpass3 "")
30
31 (define dsa-usrname1 "pgp5")
32 ;; we use the sub key because we do not yet have the logic to derive
33 ;; the first encryption key from a keyblock (I guess) (Well of course
34 ;; we have this by now and the notation below will lookup the primary
35 ;; first and then search for the encryption subkey.)
36 (define dsa-usrname2 "0xCB879DE9")
37
38 (define keys
39   (package
40    (define (new fpr grip uids subkeys)
41      (package))
42    (define (subkey fpr grip)
43      (package))
44    (define alfa (new "A0FF4590BB6122EDEF6E3C542D727CC768697734"
45                      "76F7E2B35832976B50A27A282D9B87E44577EB66"
46                      '("alfa@example.net" "alpha@example.net")
47                      (list
48                       (subkey "3B3FBC948FE59301ED629EFB6AE6D7EE46A871F8"
49                               "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"))))
50    (define one (new "289B0EF1D105E124B6F626020EF77096D74C5F22"
51                     "50B2D4FA4122C212611048BC5FC31BD44393626E"
52                     '("one@example.com")
53                     (list
54                      (subkey "EB467DCA4AD7676A6A62B2ABABAB28A247BE2775"
55                              "7E201E28B6FEB2927B321F443205F4724EBE637E"))))
56    (define two (new "C1DEBB34EA8B71009EAFA474973D50E1C40FDECF"
57                     "343D8AF79796EE107D645A2787A9D9252F924E6F"
58                     '("two@example.com")
59                     (list
60                      (subkey "CD3D0F5701CBFCACB2A4907305A37887B27907AA"
61                              "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"))))))
62
63 (define key-file1 "samplekeys/rsa-rsa-sample-1.asc")
64 (define key-file2 "samplekeys/ed25519-cv25519-sample-1.asc")
65
66 (define plain-files '("plain-1" "plain-2" "plain-3" "plain-large"))
67 (define data-files '("data-500" "data-9000" "data-32000" "data-80000"))
68 (define exp-files '())
69 (define all-files (append plain-files data-files))
70
71 (let ((verbose (string->number (getenv "verbose"))))
72   (if (number? verbose)
73       (*set-verbose!* verbose)))
74
75 (define (qualify executable)
76   (string-append executable (getenv "EXEEXT")))
77
78 (define (getenv' key default)
79   (let ((value (getenv key)))
80     (if (string=? "" value)
81         default
82         value)))
83
84 (define (percent-decode s)
85   (define (decode c)
86     (if (and (> (length c) 2) (char=? #\% (car c)))
87         (integer->char (string->number (string #\# #\x (cadr c) (caddr c))))
88         #f))
89   (let loop ((i 0) (c (string->list s)) (r (make-string (string-length s))))
90     (if (null? c)
91         (substring r 0 i)
92         (let ((decoded (decode c)))
93           (string-set! r i (if decoded decoded (car c)))
94           (loop (+ 1 i) (if decoded (cdddr c) (cdr c)) r)))))
95 (assert (equal? (percent-decode "") ""))
96 (assert (equal? (percent-decode "%61") "a"))
97 (assert (equal? (percent-decode "foob%61r") "foobar"))
98
99 (define (percent-encode s)
100   (define (encode c)
101     `(#\% ,@(string->list (number->string (char->integer c) 16))))
102   (let loop ((acc '()) (cs (reverse (string->list s))))
103     (if (null? cs)
104         (list->string acc)
105         (case (car cs)
106           ((#\: #\%)
107            (loop (append (encode (car cs)) acc) (cdr cs)))
108           (else
109            (loop (cons (car cs) acc) (cdr cs)))))))
110 (assert (equal? (percent-encode "") ""))
111 (assert (equal? (percent-encode "%61") "%2561"))
112 (assert (equal? (percent-encode "foob%61r") "foob%2561r"))
113
114 (define tools
115   '((gpgv "GPGV" "g10/gpgv")
116     (gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent")
117     (gpgconf "GPGCONF" "tools/gpgconf")
118     (gpg-preset-passphrase "GPG_PRESET_PASSPHRASE"
119                            "agent/gpg-preset-passphrase")
120     (gpgtar "GPGTAR" "tools/gpgtar")
121     (gpg-zip "GPGZIP" "tools/gpg-zip")
122     (pinentry "PINENTRY" "tests/openpgp/fake-pinentry")))
123
124 (define bin-prefix (getenv "BIN_PREFIX"))
125 (define installed? (not (string=? "" bin-prefix)))
126
127 (define (tool-hardcoded which)
128   (let ((t (assoc which tools)))
129     (getenv' (cadr t)
130              (qualify (if installed?
131                           (string-append bin-prefix "/" (basename (caddr t)))
132                           (string-append (getenv "objdir") "/" (caddr t)))))))
133
134 ;; You can splice VALGRIND into your argument vector to run programs
135 ;; under valgrind.  For example, to run valgrind on gpg, you may want
136 ;; to redefine gpg:
137 ;;
138 ;; (set! gpg `(,@valgrind ,@gpg))
139 ;;
140 (define valgrind
141   '("/usr/bin/valgrind" --leak-check=full --error-exitcode=154))
142
143 (define (gpg-conf . args)
144   (gpg-conf' "" args))
145 (define (gpg-conf' input args)
146   (let ((s (call-popen `(,(tool-hardcoded 'gpgconf) ,@args) input)))
147     (map (lambda (line) (map percent-decode (string-split line #\:)))
148          (string-split-newlines s))))
149 (define :gc:c:name car)
150 (define :gc:c:description cadr)
151 (define :gc:c:pgmname caddr)
152
153 (define (gpg-config component key)
154   (package
155    (define (value)
156      (assoc key (gpg-conf '--list-options component)))
157    (define (update value)
158      (gpg-conf' (string-append key ":0:" (percent-encode value))
159                 `(--change-options ,component)))
160    (define (clear)
161      (gpg-conf' (string-append key ":16:")
162                 `(--change-options ,component)))))
163
164
165 (unless installed?
166         (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t))
167 (define gpg-components (apply gpg-conf
168                         `(,@(if installed? '()
169                                 (list '--build-prefix (getenv "objdir")))
170                           --list-components)))
171
172 (define (tool which)
173   (case which
174     ((gpg gpg-agent scdaemon gpgsm dirmngr)
175      (:gc:c:pgmname (assoc (symbol->string which) gpg-components)))
176     (else
177      (tool-hardcoded which))))
178
179 (define (gpg-has-option? option)
180   (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "")
181                     option))
182
183 (define have-opt-always-trust
184   (catch #f
185          (call-check `(,(tool 'gpg) --gpgconf-test --always-trust))
186          #t))
187
188 (define GPG `(,(tool 'gpg) --no-permission-warning
189               ,@(if have-opt-always-trust '(--always-trust) '())))
190 (define GPGV `(,(tool 'gpgv)))
191 (define PINENTRY (tool 'pinentry))
192
193 (define (tr:gpg input args)
194   (tr:spawn input `(,@GPG --output **out** ,@args **in**)))
195
196 (define (pipe:gpg args)
197   (pipe:spawn `(,@GPG --output - ,@args -)))
198
199 (define (gpg-with-colons args)
200   (let ((s (call-popen `(,@GPG --with-colons ,@args) "")))
201     (map (lambda (line) (string-split line #\:))
202          (string-split-newlines s))))
203
204 ;; Convenient accessors for the colon output.
205 (define (:type x)   (string->symbol (list-ref x 0)))
206 (define (:length x) (string->number (list-ref x 2)))
207 (define (:alg x) (string->number (list-ref x 3)))
208 (define (:expire x) (list-ref x 6))
209 (define (:fpr x) (list-ref x 9))
210 (define (:cap x) (list-ref x 11))
211
212 (define (have-public-key? key)
213   (catch #f
214          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
215                                          (equal? key::fpr (:fpr l))))
216                         (gpg-with-colons `(--list-keys ,key::fpr))))))
217
218 (define (have-secret-key? key)
219   (catch #f
220          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
221                                          (equal? key::fpr (:fpr l))))
222                         (gpg-with-colons `(--list-secret-keys ,key::fpr))))))
223
224 (define (have-secret-key-file? key)
225   (file-exists? (path-join (getenv "GNUPGHOME") "private-keys-v1.d"
226                            (string-append key::grip ".key"))))
227
228 (define (get-config what)
229   (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
230
231 (define all-pubkey-algos (delay (get-config "pubkeyname")))
232 (define all-hash-algos (delay (get-config "digestname")))
233 (define all-cipher-algos (delay (get-config "ciphername")))
234 (define all-compression-algos (delay (get-config "compressname")))
235
236 (define (have-pubkey-algo? x)
237   (not (not (member x (force all-pubkey-algos)))))
238 (define (have-hash-algo? x)
239   (not (not (member x (force all-hash-algos)))))
240 (define (have-cipher-algo? x)
241   (not (not (member x (force all-cipher-algos)))))
242
243 (define (gpg-pipe args0 args1 errfd)
244   (lambda (source sink)
245     (let* ((p (pipe))
246            (task0 (spawn-process-fd `(,@GPG ,@args0)
247                    source (:write-end p) errfd))
248            (_ (close (:write-end p)))
249            (task1 (spawn-process-fd `(,@GPG ,@args1)
250                    (:read-end p) sink errfd)))
251       (close (:read-end p))
252       (wait-processes (list GPG GPG) (list task0 task1) #t))))
253
254 (setenv "GPG_AGENT_INFO" "" #t)
255 (setenv "GNUPGHOME" (getcwd) #t)
256 (define GNUPGHOME (getcwd))
257
258 ;;
259 ;; GnuPG helper.
260 ;;
261
262 ;; Evaluate a sequence of expressions with an ephemeral home
263 ;; directory.
264 (define-macro (with-ephemeral-home-directory . expressions)
265   (let ((original-home-directory (gensym))
266         (ephemeral-home-directory (gensym)))
267     `(let ((,original-home-directory (getenv "GNUPGHOME"))
268            (,ephemeral-home-directory (mkdtemp)))
269        (finally (unlink-recursively ,ephemeral-home-directory)
270          (dynamic-wind
271              (lambda () (setenv "GNUPGHOME" ,ephemeral-home-directory #t))
272              (lambda () ,@expressions)
273              (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))))
274
275 ;; Call GPG to obtain the hash sums.  Either specify an input file in
276 ;; ARGS, or an string in INPUT.  Returns a list of (<algo>
277 ;; "<hashsum>") lists.
278 (define (gpg-hash-string args input)
279   (map
280    (lambda (line)
281      (let ((p (string-split line #\:)))
282        (list (string->number (cadr p)) (caddr p))))
283    (string-split-newlines
284     (call-popen `(,@GPG --with-colons ,@args) input))))
285
286 ;; Dearmor a file.
287 (define (dearmor source-name sink-name)
288   (pipe:do
289    (pipe:open source-name (logior O_RDONLY O_BINARY))
290    (pipe:spawn `(,@GPG --dearmor))
291    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
292
293 ;;
294 ;; Support for test environment creation and teardown.
295 ;;
296
297 (define (make-test-data filename size)
298   (call-with-binary-output-file
299    filename
300    (lambda (port)
301      (display (make-random-string size) port))))
302
303 (define (create-gpghome)
304   (log "Creating test environment...")
305
306   (srandom (getpid))
307   (make-test-data "random_seed" 600)
308
309   (log "Creating configuration files")
310   (for-each
311    (lambda (name)
312      (file-copy (in-srcdir (string-append name ".tmpl")) name)
313      (let ((p (open-input-output-file name)))
314        (cond
315         ((string=? "gpg.conf" name)
316          (if have-opt-always-trust
317              (display "no-auto-check-trustdb\n" p))
318          (display (string-append "agent-program "
319                                  (tool 'gpg-agent)
320                                  "|--debug-quick-random\n") p)
321          (display "allow-weak-digest-algos\n" p))
322         ((string=? "gpg-agent.conf" name)
323          (display (string-append "pinentry-program " PINENTRY "\n") p)))))
324    '("gpg.conf" "gpg-agent.conf")))
325
326 ;; Initialize the test environment, install appropriate configuration
327 ;; and start the agent, without any keys.
328 (define (setup-environment)
329   (create-gpghome)
330   (start-agent))
331
332 (define (create-sample-files)
333   (log "Creating sample data files")
334   (for-each
335    (lambda (size)
336      (make-test-data (string-append "data-" (number->string size))
337                      size))
338    '(500 9000 32000 80000))
339
340   (log "Unpacking samples")
341   (for-each
342    (lambda (name)
343      (dearmor (in-srcdir ".." "openpgp" (string-append name "o.asc")) name))
344    plain-files))
345
346 (define (create-legacy-gpghome)
347   (create-sample-files)
348   (mkdir "private-keys-v1.d" "-rwx")
349
350   (log "Storing private keys")
351   (for-each
352    (lambda (name)
353      (dearmor (in-srcdir (string-append "/privkeys/" name ".asc"))
354               (string-append "private-keys-v1.d/" name ".key")))
355    '("50B2D4FA4122C212611048BC5FC31BD44393626E"
356      "7E201E28B6FEB2927B321F443205F4724EBE637E"
357      "13FDB8809B17C5547779F9D205C45F47CE0217CE"
358      "343D8AF79796EE107D645A2787A9D9252F924E6F"
359      "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
360      "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
361      "FD692BD59D6640A84C8422573D469F84F3B98E53"
362      "76F7E2B35832976B50A27A282D9B87E44577EB66"
363      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
364      "00FE67F28A52A8AA08FFAED20AF832DA916D1985"
365      "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
366      "A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
367      "ADE710D74409777B7729A7653373D820F67892E0"
368      "CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
369      "1E28F20E41B54C2D1234D896096495FF57E08D18"
370      "EB33B687EB8581AB64D04852A54453E85F3DF62D"
371      "C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
372      "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
373
374   (log "Importing public demo and test keys")
375   (for-each
376    (lambda (file)
377      (call-check `(,@GPG --yes --import ,(in-srcdir file))))
378    (list "pubdemo.asc" "pubring.asc" key-file1))
379
380   (pipe:do
381    (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
382    (pipe:spawn `(,@GPG --dearmor))
383    (pipe:spawn `(,@GPG --yes --import))))
384
385 (define (preset-passphrases)
386   (log "Presetting passphrases")
387   ;; one@example.com
388   (call-check `(,(tool 'gpg-preset-passphrase)
389                 --preset --passphrase def
390                 "50B2D4FA4122C212611048BC5FC31BD44393626E"))
391   (call-check `(,(tool 'gpg-preset-passphrase)
392                 --preset --passphrase def
393                 "7E201E28B6FEB2927B321F443205F4724EBE637E"))
394   ;; alpha@example.net
395   (call-check `(,(tool 'gpg-preset-passphrase)
396                 --preset --passphrase abc
397                 "76F7E2B35832976B50A27A282D9B87E44577EB66"))
398   (call-check `(,(tool 'gpg-preset-passphrase)
399                 --preset --passphrase abc
400                 "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
401
402 ;; Initialize the test environment, install appropriate configuration
403 ;; and start the agent, with the keys from the legacy test suite.
404 (define (setup-legacy-environment)
405   (create-gpghome)
406   (if (member "--unpack-tarball" *args*)
407       (begin
408         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
409         (start-agent))
410       (begin
411         (start-agent)
412         (create-legacy-gpghome)))
413   (preset-passphrases))
414
415 ;; Create the socket dir and start the agent.
416 (define (start-agent)
417   (log "Starting gpg-agent...")
418   (atexit stop-agent)
419   (catch (log "Warning: Creating socket directory failed:" (car *error*))
420          (call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
421   (call-check `(,(tool 'gpg-connect-agent) --verbose
422                 ,(string-append "--agent-program=" (tool 'gpg-agent)
423                                 "|--debug-quick-random")
424                 /bye)))
425
426 ;; Stop the agent and remove the socket dir.
427 (define (stop-agent)
428   (log "Stopping gpg-agent...")
429   (catch (log "Warning: Removing socket directory failed.")
430          (call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
431   (call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
432                 killagent /bye)))