186efe0ca31bc33d9b9ca37fa88f12d51e8d6839
[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 (unless installed?
144         (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t))
145
146 (define (gpg-conf . args)
147   (gpg-conf' "" args))
148 (define (gpg-conf' input args)
149   (let ((s (call-popen `(,(tool-hardcoded 'gpgconf)
150                          ,@(if installed? '()
151                                (list '--build-prefix (getenv "objdir")))
152                          ,@args) input)))
153     (map (lambda (line) (map percent-decode (string-split line #\:)))
154          (string-split-newlines s))))
155 (define :gc:c:name car)
156 (define :gc:c:description cadr)
157 (define :gc:c:pgmname caddr)
158 (define (:gc:o:name x)             (list-ref x 0))
159 (define (:gc:o:flags x)            (string->number (list-ref x 1)))
160 (define (:gc:o:level x)            (string->number (list-ref x 2)))
161 (define (:gc:o:description x)      (list-ref x 3))
162 (define (:gc:o:type x)             (string->number (list-ref x 4)))
163 (define (:gc:o:alternate-type x)   (string->number (list-ref x 5)))
164 (define (:gc:o:argument-name x)    (list-ref x 6))
165 (define (:gc:o:default-value x)    (list-ref x 7))
166 (define (:gc:o:default-argument x) (list-ref x 8))
167 (define (:gc:o:value x)            (if (< (length x) 10) "" (list-ref x 9)))
168
169 (define (gpg-config component key)
170   (package
171    (define (value)
172      (let* ((conf (assoc key (gpg-conf '--list-options component)))
173             (type (:gc:o:type conf))
174             (value (:gc:o:value conf)))
175        (case type
176          ((0 2 3) (string->number value))
177          ((1 32) (substring value 1 (string-length value))))))
178    (define (update value)
179      (let ((value' (cond
180                     ((string? value) (string-append "\"" value))
181                     ((number? value) (number->string value))
182                     (else (throw "Unsupported value" value)))))
183        (gpg-conf' (string-append key ":0:" (percent-encode value'))
184                   `(--change-options ,component))))
185    (define (clear)
186      (gpg-conf' (string-append key ":16:")
187                 `(--change-options ,component)))))
188
189 (define gpg-components (apply gpg-conf '(--list-components)))
190
191 (define (tool which)
192   (case which
193     ((gpg gpg-agent scdaemon gpgsm dirmngr)
194      (:gc:c:pgmname (assoc (symbol->string which) gpg-components)))
195     (else
196      (tool-hardcoded which))))
197
198 (define (gpg-has-option? option)
199   (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "")
200                     option))
201
202 (define have-opt-always-trust
203   (catch #f
204          (with-ephemeral-home-directory (lambda ()) (lambda ())
205            (call-check `(,(tool 'gpg) --gpgconf-test --always-trust)))
206          #t))
207
208 (define GPG `(,(tool 'gpg) --no-permission-warning
209               ,@(if have-opt-always-trust '(--always-trust) '())))
210 (define GPGV `(,(tool 'gpgv)))
211 (define PINENTRY (tool 'pinentry))
212
213 (define (tr:gpg input args)
214   (tr:spawn input `(,@GPG --output **out** ,@args **in**)))
215
216 (define (pipe:gpg args)
217   (pipe:spawn `(,@GPG --output - ,@args -)))
218
219 (define (gpg-with-colons args)
220   (let ((s (call-popen `(,@GPG --with-colons ,@args) "")))
221     (map (lambda (line) (string-split line #\:))
222          (string-split-newlines s))))
223
224 ;; Convenient accessors for the colon output.
225 (define (:type x)   (string->symbol (list-ref x 0)))
226 (define (:length x) (string->number (list-ref x 2)))
227 (define (:alg x) (string->number (list-ref x 3)))
228 (define (:expire x) (list-ref x 6))
229 (define (:fpr x) (list-ref x 9))
230 (define (:cap x) (list-ref x 11))
231
232 (define (have-public-key? key)
233   (catch #f
234          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
235                                          (equal? key::fpr (:fpr l))))
236                         (gpg-with-colons `(--list-keys ,key::fpr))))))
237
238 (define (have-secret-key? key)
239   (catch #f
240          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
241                                          (equal? key::fpr (:fpr l))))
242                         (gpg-with-colons `(--list-secret-keys ,key::fpr))))))
243
244 (define (have-secret-key-file? key)
245   (file-exists? (path-join (getenv "GNUPGHOME") "private-keys-v1.d"
246                            (string-append key::grip ".key"))))
247
248 (define (get-config what)
249   (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
250
251 (define all-pubkey-algos (delay (get-config "pubkeyname")))
252 (define all-hash-algos (delay (get-config "digestname")))
253 (define all-cipher-algos (delay (get-config "ciphername")))
254 (define all-compression-algos (delay (get-config "compressname")))
255
256 (define (have-pubkey-algo? x)
257   (not (not (member x (force all-pubkey-algos)))))
258 (define (have-hash-algo? x)
259   (not (not (member x (force all-hash-algos)))))
260 (define (have-cipher-algo? x)
261   (not (not (member x (force all-cipher-algos)))))
262 (define (have-compression-algo? x)
263   (not (not (member x (force all-compression-algos)))))
264
265 (define (gpg-pipe args0 args1 errfd)
266   (lambda (source sink)
267     (let* ((p (pipe))
268            (task0 (spawn-process-fd `(,@GPG ,@args0)
269                    source (:write-end p) errfd))
270            (_ (close (:write-end p)))
271            (task1 (spawn-process-fd `(,@GPG ,@args1)
272                    (:read-end p) sink errfd)))
273       (close (:read-end p))
274       (wait-processes (list GPG GPG) (list task0 task1) #t))))
275
276 (setenv "GPG_AGENT_INFO" "" #t)
277 (setenv "GNUPGHOME" (getcwd) #t)
278 (define GNUPGHOME (getcwd))
279
280 ;;
281 ;; GnuPG helper.
282 ;;
283
284 ;; Call GPG to obtain the hash sums.  Either specify an input file in
285 ;; ARGS, or an string in INPUT.  Returns a list of (<algo>
286 ;; "<hashsum>") lists.
287 (define (gpg-hash-string args input)
288   (map
289    (lambda (line)
290      (let ((p (string-split line #\:)))
291        (list (string->number (cadr p)) (caddr p))))
292    (string-split-newlines
293     (call-popen `(,@GPG --with-colons ,@args) input))))
294
295 ;; Dearmor a file.
296 (define (dearmor source-name sink-name)
297   (pipe:do
298    (pipe:open source-name (logior O_RDONLY O_BINARY))
299    (pipe:spawn `(,@GPG --dearmor))
300    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
301
302 (define (gpg-dump-packets source-name sink-name)
303   (pipe:do
304    (pipe:open source-name (logior O_RDONLY O_BINARY))
305    (pipe:spawn `(,@GPG --list-packets))
306    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
307
308 ;;
309 ;; Support for test environment creation and teardown.
310 ;;
311
312 (define (make-test-data filename size)
313   (call-with-binary-output-file
314    filename
315    (lambda (port)
316      (display (make-random-string size) port))))
317
318 (define (create-file name . lines)
319   (catch #f (unlink name))
320   (letfd ((fd (open name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
321     (let ((port (fdopen fd "wb")))
322       (for-each (lambda (line) (display line port) (newline port))
323                 lines))))
324
325 (define (create-gpghome)
326   (log "Creating test environment...")
327
328   (srandom (getpid))
329   (make-test-data "random_seed" 600)
330
331   (log "Creating configuration files")
332
333   (if (flag "--use-keyring" *args*)
334       (create-file "pubring.gpg"))
335
336   (create-file "gpg.conf"
337                "no-greeting"
338                "no-secmem-warning"
339                "no-permission-warning"
340                "batch"
341                "no-auto-key-retrieve"
342                "no-auto-key-locate"
343                "allow-weak-digest-algos"
344                "ignore-mdc-error"
345                (if have-opt-always-trust
346                    "no-auto-check-trustdb" "#no-auto-check-trustdb")
347                (string-append "agent-program "
348                               (tool 'gpg-agent)
349                               "|--debug-quick-random\n")
350                )
351   (create-file "gpg-agent.conf"
352                "allow-preset-passphrase"
353                "no-grab"
354                "enable-ssh-support"
355                "s2k-count 65536"
356                (if (flag "--extended-key-format" *args*)
357                    "enable-extended-key-format" "#enable-extended-key-format")
358                (string-append "pinentry-program " (tool 'pinentry))
359                (if (assoc "scdaemon" gpg-components)
360                    (string-append "scdaemon-program " (tool 'scdaemon))
361                    "# No scdaemon available")
362                ))
363
364 ;; Initialize the test environment, install appropriate configuration
365 ;; and start the agent, without any keys.
366 (define (setup-environment)
367   (create-gpghome)
368   (start-agent))
369
370 (define (setup-environment-no-atexit)
371   (create-gpghome)
372   (start-agent #t))
373
374 (define (create-sample-files)
375   (log "Creating sample data files")
376   (for-each
377    (lambda (size)
378      (make-test-data (string-append "data-" (number->string size))
379                      size))
380    '(500 9000 32000 80000))
381
382   (log "Unpacking samples")
383   (for-each
384    (lambda (name)
385      (dearmor (in-srcdir "tests" "openpgp" (string-append name "o.asc")) name))
386    plain-files))
387
388 (define (create-legacy-gpghome)
389   (create-sample-files)
390
391   (log "Storing private keys")
392   (for-each
393    (lambda (name)
394      (dearmor (in-srcdir "tests" "openpgp" "privkeys" (string-append name ".asc"))
395               (string-append "private-keys-v1.d/" name ".key")))
396    '("50B2D4FA4122C212611048BC5FC31BD44393626E"
397      "7E201E28B6FEB2927B321F443205F4724EBE637E"
398      "13FDB8809B17C5547779F9D205C45F47CE0217CE"
399      "343D8AF79796EE107D645A2787A9D9252F924E6F"
400      "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
401      "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
402      "FD692BD59D6640A84C8422573D469F84F3B98E53"
403      "76F7E2B35832976B50A27A282D9B87E44577EB66"
404      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
405      "00FE67F28A52A8AA08FFAED20AF832DA916D1985"
406      "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
407      "A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
408      "ADE710D74409777B7729A7653373D820F67892E0"
409      "CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
410      "1E28F20E41B54C2D1234D896096495FF57E08D18"
411      "EB33B687EB8581AB64D04852A54453E85F3DF62D"
412      "C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
413      "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
414
415   (log "Importing public demo and test keys")
416   (for-each
417    (lambda (file)
418      (call-check `(,@GPG --yes --import ,(in-srcdir "tests" "openpgp" file))))
419    (list "pubdemo.asc" "pubring.asc" key-file1))
420
421   (pipe:do
422    (pipe:open (in-srcdir "tests" "openpgp" "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
423    (pipe:spawn `(,@GPG --dearmor))
424    (pipe:spawn `(,@GPG --yes --import))))
425
426 (define (preset-passphrases)
427   (log "Presetting passphrases")
428   ;; one@example.com
429   (call-check `(,(tool 'gpg-preset-passphrase)
430                 --preset --passphrase def
431                 "50B2D4FA4122C212611048BC5FC31BD44393626E"))
432   (call-check `(,(tool 'gpg-preset-passphrase)
433                 --preset --passphrase def
434                 "7E201E28B6FEB2927B321F443205F4724EBE637E"))
435   ;; alpha@example.net
436   (call-check `(,(tool 'gpg-preset-passphrase)
437                 --preset --passphrase abc
438                 "76F7E2B35832976B50A27A282D9B87E44577EB66"))
439   (call-check `(,(tool 'gpg-preset-passphrase)
440                 --preset --passphrase abc
441                 "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
442
443 ;; Initialize the test environment, install appropriate configuration
444 ;; and start the agent, with the keys from the legacy test suite.
445 (define (setup-legacy-environment)
446   (create-gpghome)
447   (if (member "--unpack-tarball" *args*)
448       (begin
449         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
450         (start-agent))
451       (begin
452         (start-agent)
453         (create-legacy-gpghome)))
454   (preset-passphrases))
455
456 ;; Create the socket dir and start the agent.
457 (define (start-agent . args)
458   (log "Starting gpg-agent...")
459   (let ((gnupghome (getenv "GNUPGHOME")))
460     (if (null? args)
461         (atexit (lambda ()
462                   (with-home-directory gnupghome (stop-agent))))))
463   (catch (log "Warning: Creating socket directory failed:" (car *error*))
464          (gpg-conf '--create-socketdir))
465   (call-check `(,(tool 'gpg-connect-agent) --verbose
466                 ,(string-append "--agent-program=" (tool 'gpg-agent)
467                                 "|--debug-quick-random")
468                 /bye)))
469
470 ;; Stop the agent and other daemons and remove the socket dir.
471 (define (stop-agent)
472   (log "Stopping gpg-agent...")
473   (gpg-conf '--kill 'all)
474   (catch (log "Warning: Removing socket directory failed.")
475          (gpg-conf '--remove-socketdir)))
476
477 ;; Get the trust level for KEYID.  Any remaining arguments are simply
478 ;; passed to GPG.
479 ;;
480 ;; This function only supports keys with a single user id.
481 (define (gettrust keyid . args)
482   (let ((trust
483           (list-ref (assoc "pub" (gpg-with-colons
484                                    `(,@args
485                                       --list-keys ,keyid))) 1)))
486     (unless (and (= 1 (string-length trust))
487                  (member (string-ref trust 0) (string->list "oidreqnmfuws-")))
488             (fail "Bad trust value:" trust))
489     trust))
490
491 ;; Check that KEYID's trust level matches EXPECTED-TRUST.  Any
492 ;; remaining arguments are simply passed to GPG.
493 ;;
494 ;; This function only supports keys with a single user id.
495 (define (checktrust keyid expected-trust . args)
496   (let ((trust (apply gettrust `(,keyid ,@args))))
497     (unless (string=? trust expected-trust)
498             (fail keyid ": Expected trust to be" expected-trust
499                    "but got" trust))))
500
501
502 ;; end