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