tests,w32: Fix locating the components.
[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 (macro (with-ephemeral-home-directory form)
226   `(let ((original-home-directory (getenv "GNUPGHOME")))
227      (with-temporary-working-directory
228       (define ephemeral-home-directory (getcwd))
229       (dynamic-wind
230           (lambda () (setenv "GNUPGHOME" ephemeral-home-directory #t))
231           (lambda () ,@(cdr form))
232           (lambda () (setenv "GNUPGHOME" original-home-directory #t))))))
233
234 ;; Call GPG to obtain the hash sums.  Either specify an input file in
235 ;; ARGS, or an string in INPUT.  Returns a list of (<algo>
236 ;; "<hashsum>") lists.
237 (define (gpg-hash-string args input)
238   (map
239    (lambda (line)
240      (let ((p (string-split line #\:)))
241        (list (string->number (cadr p)) (caddr p))))
242    (string-split-newlines
243     (call-popen `(,@GPG --with-colons ,@args) input))))
244
245 ;; Dearmor a file.
246 (define (dearmor source-name sink-name)
247   (pipe:do
248    (pipe:open source-name (logior O_RDONLY O_BINARY))
249    (pipe:spawn `(,@GPG --dearmor))
250    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
251
252 ;;
253 ;; Support for test environment creation and teardown.
254 ;;
255
256 (define (make-test-data filename size)
257   (call-with-binary-output-file
258    filename
259    (lambda (port)
260      (display (make-random-string size) port))))
261
262 (define (create-gpghome)
263   (log "Creating test environment...")
264
265   (srandom (getpid))
266   (make-test-data "random_seed" 600)
267
268   (log "Creating configuration files")
269   (for-each
270    (lambda (name)
271      (file-copy (in-srcdir (string-append name ".tmpl")) name)
272      (let ((p (open-input-output-file name)))
273        (cond
274         ((string=? "gpg.conf" name)
275          (if have-opt-always-trust
276              (display "no-auto-check-trustdb\n" p))
277          (display (string-append "agent-program "
278                                  (tool 'gpg-agent)
279                                  "|--debug-quick-random\n") p)
280          (display "allow-weak-digest-algos\n" p))
281         ((string=? "gpg-agent.conf" name)
282          (display (string-append "pinentry-program " PINENTRY "\n") p)))))
283    '("gpg.conf" "gpg-agent.conf")))
284
285 ;; Initialize the test environment, install appropriate configuration
286 ;; and start the agent, without any keys.
287 (define (setup-environment)
288   (create-gpghome)
289   (start-agent))
290
291 (define (create-sample-files)
292   (log "Creating sample data files")
293   (for-each
294    (lambda (size)
295      (make-test-data (string-append "data-" (number->string size))
296                      size))
297    '(500 9000 32000 80000))
298
299   (log "Unpacking samples")
300   (for-each
301    (lambda (name)
302      (dearmor (in-srcdir ".." "openpgp" (string-append name "o.asc")) name))
303    plain-files))
304
305 (define (create-legacy-gpghome)
306   (create-sample-files)
307   (mkdir "private-keys-v1.d" "-rwx")
308
309   (log "Storing private keys")
310   (for-each
311    (lambda (name)
312      (dearmor (in-srcdir (string-append "/privkeys/" name ".asc"))
313               (string-append "private-keys-v1.d/" name ".key")))
314    '("50B2D4FA4122C212611048BC5FC31BD44393626E"
315      "7E201E28B6FEB2927B321F443205F4724EBE637E"
316      "13FDB8809B17C5547779F9D205C45F47CE0217CE"
317      "343D8AF79796EE107D645A2787A9D9252F924E6F"
318      "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
319      "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
320      "FD692BD59D6640A84C8422573D469F84F3B98E53"
321      "76F7E2B35832976B50A27A282D9B87E44577EB66"
322      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
323      "00FE67F28A52A8AA08FFAED20AF832DA916D1985"
324      "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
325      "A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
326      "ADE710D74409777B7729A7653373D820F67892E0"
327      "CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
328      "1E28F20E41B54C2D1234D896096495FF57E08D18"
329      "EB33B687EB8581AB64D04852A54453E85F3DF62D"
330      "C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
331      "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
332
333   (log "Importing public demo and test keys")
334   (for-each
335    (lambda (file)
336      (call-check `(,@GPG --yes --import ,(in-srcdir file))))
337    (list "pubdemo.asc" "pubring.asc" key-file1))
338
339   (pipe:do
340    (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
341    (pipe:spawn `(,@GPG --dearmor))
342    (pipe:spawn `(,@GPG --yes --import))))
343
344 (define (preset-passphrases)
345   (log "Presetting passphrases")
346   ;; one@example.com
347   (call-check `(,(tool 'gpg-preset-passphrase)
348                 --preset --passphrase def
349                 "50B2D4FA4122C212611048BC5FC31BD44393626E"))
350   (call-check `(,(tool 'gpg-preset-passphrase)
351                 --preset --passphrase def
352                 "7E201E28B6FEB2927B321F443205F4724EBE637E"))
353   ;; alpha@example.net
354   (call-check `(,(tool 'gpg-preset-passphrase)
355                 --preset --passphrase abc
356                 "76F7E2B35832976B50A27A282D9B87E44577EB66"))
357   (call-check `(,(tool 'gpg-preset-passphrase)
358                 --preset --passphrase abc
359                 "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
360
361 ;; Initialize the test environment, install appropriate configuration
362 ;; and start the agent, with the keys from the legacy test suite.
363 (define (setup-legacy-environment)
364   (create-gpghome)
365   (if (member "--unpack-tarball" *args*)
366       (begin
367         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
368         (start-agent))
369       (begin
370         (start-agent)
371         (create-legacy-gpghome)))
372   (preset-passphrases))
373
374 ;; Create the socket dir and start the agent.
375 (define (start-agent)
376   (log "Starting gpg-agent...")
377   (atexit stop-agent)
378   (catch (log "Warning: Creating socket directory failed:" (car *error*))
379          (call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
380   (call-check `(,(tool 'gpg-connect-agent) --verbose
381                 ,(string-append "--agent-program=" (tool 'gpg-agent)
382                                 "|--debug-quick-random")
383                 /bye)))
384
385 ;; Stop the agent and remove the socket dir.
386 (define (stop-agent)
387   (log "Stopping gpg-agent...")
388   (catch (log "Warning: Removing socket directory failed.")
389          (call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
390   (call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
391                 killagent /bye)))