tests: Fix macro.
[gnupg.git] / tests / openpgp / defs.scm
1 ;; Common definitions for the OpenPGP test scripts.
2 ;;
3 ;; Copyright (C) 2016 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 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 tools
100   '((gpgv "GPGV" "g10/gpgv")
101     (gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent")
102     (gpgconf "GPGCONF" "tools/gpgconf")
103     (gpg-preset-passphrase "GPG_PRESET_PASSPHRASE"
104                            "agent/gpg-preset-passphrase")
105     (gpgtar "GPGTAR" "tools/gpgtar")
106     (gpg-zip "GPGZIP" "tools/gpg-zip")
107     (pinentry "PINENTRY" "tests/openpgp/fake-pinentry")))
108
109 (define bin-prefix (getenv "BIN_PREFIX"))
110 (define installed? (not (string=? "" bin-prefix)))
111
112 (define (tool-hardcoded which)
113   (let ((t (assoc which tools)))
114     (getenv' (cadr t)
115              (qualify (if installed?
116                           (string-append bin-prefix "/" (basename (caddr t)))
117                           (string-append (getenv "objdir") "/" (caddr t)))))))
118
119 (define (gpg-conf . args)
120   (let ((s (call-popen `(,(tool-hardcoded 'gpgconf) ,@args) "")))
121     (map (lambda (line) (map percent-decode (string-split line #\:)))
122          (string-split-newlines s))))
123 (define :gc:c:name car)
124 (define :gc:c:description cadr)
125 (define :gc:c:pgmname caddr)
126
127 (unless installed?
128         (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t))
129 (define gpg-components (apply gpg-conf
130                         `(,@(if installed? '()
131                                 (list '--build-prefix (getenv "objdir")))
132                           --list-components)))
133
134 (define (tool which)
135   (case which
136     ((gpg gpg-agent scdaemon gpgsm dirmngr)
137      (:gc:c:pgmname (assoc (symbol->string which) gpg-components)))
138     (else
139      (tool-hardcoded which))))
140
141 (define (gpg-has-option? option)
142   (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "")
143                     option))
144
145 (define have-opt-always-trust
146   (catch #f
147          (call-check `(,(tool 'gpg) --gpgconf-test --always-trust))
148          #t))
149
150 (define GPG `(,(tool 'gpg) --no-permission-warning
151               ,@(if have-opt-always-trust '(--always-trust) '())))
152 (define GPGV `(,(tool 'gpgv)))
153 (define PINENTRY (tool 'pinentry))
154
155 (define (tr:gpg input args)
156   (tr:spawn input `(,@GPG --output **out** ,@args **in**)))
157
158 (define (pipe:gpg args)
159   (pipe:spawn `(,@GPG --output - ,@args -)))
160
161 (define (gpg-with-colons args)
162   (let ((s (call-popen `(,@GPG --with-colons ,@args) "")))
163     (map (lambda (line) (string-split line #\:))
164          (string-split-newlines s))))
165
166 ;; Convenient accessors for the colon output.
167 (define (:type x)   (string->symbol (list-ref x 0)))
168 (define (:length x) (string->number (list-ref x 2)))
169 (define (:alg x) (string->number (list-ref x 3)))
170 (define (:expire x) (list-ref x 6))
171 (define (:fpr x) (list-ref x 9))
172 (define (:cap x) (list-ref x 11))
173
174 (define (have-public-key? key)
175   (catch #f
176          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
177                                          (equal? key::fpr (:fpr l))))
178                         (gpg-with-colons `(--list-keys ,key::fpr))))))
179
180 (define (have-secret-key? key)
181   (catch #f
182          (pair? (filter (lambda (l) (and (equal? 'fpr (:type l))
183                                          (equal? key::fpr (:fpr l))))
184                         (gpg-with-colons `(--list-secret-keys ,key::fpr))))))
185
186 (define (have-secret-key-file? key)
187   (file-exists? (path-join (getenv "GNUPGHOME") "private-keys-v1.d"
188                            (string-append key::grip ".key"))))
189
190 (define (get-config what)
191   (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
192
193 (define all-pubkey-algos (delay (get-config "pubkeyname")))
194 (define all-hash-algos (delay (get-config "digestname")))
195 (define all-cipher-algos (delay (get-config "ciphername")))
196 (define all-compression-algos (delay (get-config "compressname")))
197
198 (define (have-pubkey-algo? x)
199   (not (not (member x (force all-pubkey-algos)))))
200 (define (have-hash-algo? x)
201   (not (not (member x (force all-hash-algos)))))
202 (define (have-cipher-algo? x)
203   (not (not (member x (force all-cipher-algos)))))
204
205 (define (gpg-pipe args0 args1 errfd)
206   (lambda (source sink)
207     (let* ((p (pipe))
208            (task0 (spawn-process-fd `(,@GPG ,@args0)
209                    source (:write-end p) errfd))
210            (_ (close (:write-end p)))
211            (task1 (spawn-process-fd `(,@GPG ,@args1)
212                    (:read-end p) sink errfd)))
213       (close (:read-end p))
214       (wait-processes (list GPG GPG) (list task0 task1) #t))))
215
216 (setenv "GPG_AGENT_INFO" "" #t)
217 (setenv "GNUPGHOME" (getcwd) #t)
218
219 ;;
220 ;; GnuPG helper.
221 ;;
222
223 ;; Evaluate a sequence of expressions with an ephemeral home
224 ;; directory.
225 (define-macro (with-ephemeral-home-directory . expressions)
226   (let ((original-home-directory (gensym))
227         (ephemeral-home-directory (gensym)))
228     `(let ((,original-home-directory (getenv "GNUPGHOME"))
229            (,ephemeral-home-directory (mkdtemp)))
230        (finally (unlink-recursively ,ephemeral-home-directory)
231          (dynamic-wind
232              (lambda () (setenv "GNUPGHOME" ,ephemeral-home-directory #t))
233              (lambda () ,@expressions)
234              (lambda () (setenv "GNUPGHOME" ,original-home-directory #t)))))))
235
236 ;; Call GPG to obtain the hash sums.  Either specify an input file in
237 ;; ARGS, or an string in INPUT.  Returns a list of (<algo>
238 ;; "<hashsum>") lists.
239 (define (gpg-hash-string args input)
240   (map
241    (lambda (line)
242      (let ((p (string-split line #\:)))
243        (list (string->number (cadr p)) (caddr p))))
244    (string-split-newlines
245     (call-popen `(,@GPG --with-colons ,@args) input))))
246
247 ;; Dearmor a file.
248 (define (dearmor source-name sink-name)
249   (pipe:do
250    (pipe:open source-name (logior O_RDONLY O_BINARY))
251    (pipe:spawn `(,@GPG --dearmor))
252    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
253
254 ;;
255 ;; Support for test environment creation and teardown.
256 ;;
257
258 (define (make-test-data filename size)
259   (call-with-binary-output-file
260    filename
261    (lambda (port)
262      (display (make-random-string size) port))))
263
264 (define (create-gpghome)
265   (log "Creating test environment...")
266
267   (srandom (getpid))
268   (make-test-data "random_seed" 600)
269
270   (log "Creating configuration files")
271   (for-each
272    (lambda (name)
273      (file-copy (in-srcdir (string-append name ".tmpl")) name)
274      (let ((p (open-input-output-file name)))
275        (cond
276         ((string=? "gpg.conf" name)
277          (if have-opt-always-trust
278              (display "no-auto-check-trustdb\n" p))
279          (display (string-append "agent-program "
280                                  (tool 'gpg-agent)
281                                  "|--debug-quick-random\n") p)
282          (display "allow-weak-digest-algos\n" p))
283         ((string=? "gpg-agent.conf" name)
284          (display (string-append "pinentry-program " PINENTRY "\n") p)))))
285    '("gpg.conf" "gpg-agent.conf")))
286
287 ;; Initialize the test environment, install appropriate configuration
288 ;; and start the agent, without any keys.
289 (define (setup-environment)
290   (create-gpghome)
291   (start-agent))
292
293 (define (create-sample-files)
294   (log "Creating sample data files")
295   (for-each
296    (lambda (size)
297      (make-test-data (string-append "data-" (number->string size))
298                      size))
299    '(500 9000 32000 80000))
300
301   (log "Unpacking samples")
302   (for-each
303    (lambda (name)
304      (dearmor (in-srcdir ".." "openpgp" (string-append name "o.asc")) name))
305    plain-files))
306
307 (define (create-legacy-gpghome)
308   (create-sample-files)
309   (mkdir "private-keys-v1.d" "-rwx")
310
311   (log "Storing private keys")
312   (for-each
313    (lambda (name)
314      (dearmor (in-srcdir (string-append "/privkeys/" name ".asc"))
315               (string-append "private-keys-v1.d/" name ".key")))
316    '("50B2D4FA4122C212611048BC5FC31BD44393626E"
317      "7E201E28B6FEB2927B321F443205F4724EBE637E"
318      "13FDB8809B17C5547779F9D205C45F47CE0217CE"
319      "343D8AF79796EE107D645A2787A9D9252F924E6F"
320      "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
321      "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
322      "FD692BD59D6640A84C8422573D469F84F3B98E53"
323      "76F7E2B35832976B50A27A282D9B87E44577EB66"
324      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
325      "00FE67F28A52A8AA08FFAED20AF832DA916D1985"
326      "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
327      "A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
328      "ADE710D74409777B7729A7653373D820F67892E0"
329      "CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
330      "1E28F20E41B54C2D1234D896096495FF57E08D18"
331      "EB33B687EB8581AB64D04852A54453E85F3DF62D"
332      "C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
333      "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
334
335   (log "Importing public demo and test keys")
336   (for-each
337    (lambda (file)
338      (call-check `(,@GPG --yes --import ,(in-srcdir file))))
339    (list "pubdemo.asc" "pubring.asc" key-file1))
340
341   (pipe:do
342    (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
343    (pipe:spawn `(,@GPG --dearmor))
344    (pipe:spawn `(,@GPG --yes --import))))
345
346 (define (preset-passphrases)
347   (log "Presetting passphrases")
348   ;; one@example.com
349   (call-check `(,(tool 'gpg-preset-passphrase)
350                 --preset --passphrase def
351                 "50B2D4FA4122C212611048BC5FC31BD44393626E"))
352   (call-check `(,(tool 'gpg-preset-passphrase)
353                 --preset --passphrase def
354                 "7E201E28B6FEB2927B321F443205F4724EBE637E"))
355   ;; alpha@example.net
356   (call-check `(,(tool 'gpg-preset-passphrase)
357                 --preset --passphrase abc
358                 "76F7E2B35832976B50A27A282D9B87E44577EB66"))
359   (call-check `(,(tool 'gpg-preset-passphrase)
360                 --preset --passphrase abc
361                 "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
362
363 ;; Initialize the test environment, install appropriate configuration
364 ;; and start the agent, with the keys from the legacy test suite.
365 (define (setup-legacy-environment)
366   (create-gpghome)
367   (if (member "--unpack-tarball" *args*)
368       (begin
369         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
370         (start-agent))
371       (begin
372         (start-agent)
373         (create-legacy-gpghome)))
374   (preset-passphrases))
375
376 ;; Create the socket dir and start the agent.
377 (define (start-agent)
378   (log "Starting gpg-agent...")
379   (atexit stop-agent)
380   (catch (log "Warning: Creating socket directory failed:" (car *error*))
381          (call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
382   (call-check `(,(tool 'gpg-connect-agent) --verbose
383                 ,(string-append "--agent-program=" (tool 'gpg-agent)
384                                 "|--debug-quick-random")
385                 /bye)))
386
387 ;; Stop the agent and remove the socket dir.
388 (define (stop-agent)
389   (log "Stopping gpg-agent...")
390   (catch (log "Warning: Removing socket directory failed.")
391          (call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
392   (call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
393                 killagent /bye)))