common: Support locating components in the build tree.
[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 key-file1 "samplekeys/rsa-rsa-sample-1.asc")
39 (define key-file2 "samplekeys/ed25519-cv25519-sample-1.asc")
40
41 (define plain-files '("plain-1" "plain-2" "plain-3"))
42 (define data-files '("data-500" "data-9000" "data-32000" "data-80000"))
43 (define exp-files '())
44
45 (let ((verbose (string->number (getenv "verbose"))))
46   (if (number? verbose)
47       (*set-verbose!* verbose)))
48
49 (define (qualify executable)
50   (string-append executable (getenv "EXEEXT")))
51
52 (define (getenv' key default)
53   (let ((value (getenv key)))
54     (if (string=? "" value)
55         default
56         value)))
57
58 (define tools
59   '((gpgv "GPGV" "g10/gpgv")
60     (gpg-connect-agent "GPG_CONNECT_AGENT" "tools/gpg-connect-agent")
61     (gpgconf "GPGCONF" "tools/gpgconf")
62     (gpg-preset-passphrase "GPG_PRESET_PASSPHRASE"
63                            "agent/gpg-preset-passphrase")
64     (gpgtar "GPGTAR" "tools/gpgtar")
65     (gpg-zip "GPGZIP" "tools/gpg-zip")
66     (pinentry "PINENTRY" "tests/openpgp/fake-pinentry")))
67
68 (define (tool-hardcoded which)
69   (let ((t (assoc which tools))
70         (prefix (getenv "BIN_PREFIX")))
71     (getenv' (cadr t)
72              (qualify (if (string=? prefix "")
73                           (string-append (getenv "objdir") "/" (caddr t))
74                           (string-append prefix "/" (basename (caddr t))))))))
75
76 (define (gpg-conf . args)
77   (let ((s (call-popen `(,(tool-hardcoded 'gpgconf) ,@args) "")))
78     (map (lambda (line) (string-split line #\:))
79          (string-split-newlines s))))
80 (define :gc:c:name car)
81 (define :gc:c:description cadr)
82 (define :gc:c:pgmname caddr)
83
84 (setenv "GNUPG_BUILDDIR" (getenv "objdir") #t)
85 (define gpg-components (gpg-conf '--build-prefix (getenv "objdir")
86                                  '--list-components))
87
88 (define (tool which)
89   (case which
90     ((gpg gpg-agent scdaemon gpgsm dirmngr)
91      (:gc:c:pgmname (assoc (symbol->string which) gpg-components)))
92     (else
93      (tool-hardcoded which))))
94
95 (define (gpg-has-option? option)
96   (string-contains? (call-popen `(,(tool 'gpg) --dump-options) "")
97                     option))
98
99 (define have-opt-always-trust
100   (catch #f
101          (call-check `(,(tool 'gpg) --gpgconf-test --always-trust))
102          #t))
103
104 (define GPG `(,(tool 'gpg) --no-permission-warning
105               ,@(if have-opt-always-trust '(--always-trust) '())))
106 (define GPGV `(,(tool 'gpgv)))
107 (define PINENTRY (tool 'pinentry))
108
109 (define (tr:gpg input args)
110   (tr:spawn input `(,@GPG --output **out** ,@args **in**)))
111
112 (define (pipe:gpg args)
113   (pipe:spawn `(,@GPG --output - ,@args -)))
114
115 (define (gpg-with-colons args)
116   (let ((s (call-popen `(,@GPG --with-colons ,@args) "")))
117     (map (lambda (line) (string-split line #\:))
118          (string-split-newlines s))))
119
120 (define (get-config what)
121   (string-split (caddar (gpg-with-colons `(--list-config ,what))) #\;))
122
123 (define all-pubkey-algos (delay (get-config "pubkeyname")))
124 (define all-hash-algos (delay (get-config "digestname")))
125 (define all-cipher-algos (delay (get-config "ciphername")))
126 (define all-compression-algos (delay (get-config "compressname")))
127
128 (define (have-pubkey-algo? x)
129   (not (not (member x (force all-pubkey-algos)))))
130 (define (have-hash-algo? x)
131   (not (not (member x (force all-hash-algos)))))
132 (define (have-cipher-algo? x)
133   (not (not (member x (force all-cipher-algos)))))
134
135 (define (gpg-pipe args0 args1 errfd)
136   (lambda (source sink)
137     (let* ((p (pipe))
138            (task0 (spawn-process-fd `(,@GPG ,@args0)
139                    source (:write-end p) errfd))
140            (_ (close (:write-end p)))
141            (task1 (spawn-process-fd `(,@GPG ,@args1)
142                    (:read-end p) sink errfd)))
143       (close (:read-end p))
144       (wait-processes (list GPG GPG) (list task0 task1) #t))))
145
146 (setenv "GPG_AGENT_INFO" "" #t)
147 (setenv "GNUPGHOME" (getcwd) #t)
148
149 ;;
150 ;; GnuPG helper.
151 ;;
152
153 ;; Call GPG to obtain the hash sums.  Either specify an input file in
154 ;; ARGS, or an string in INPUT.  Returns a list of (<algo>
155 ;; "<hashsum>") lists.
156 (define (gpg-hash-string args input)
157   (map
158    (lambda (line)
159      (let ((p (string-split line #\:)))
160        (list (string->number (cadr p)) (caddr p))))
161    (string-split-newlines
162     (call-popen `(,@GPG --with-colons ,@args) input))))
163
164 ;; Dearmor a file.
165 (define (dearmor source-name sink-name)
166   (pipe:do
167    (pipe:open source-name (logior O_RDONLY O_BINARY))
168    (pipe:spawn `(,@GPG --dearmor))
169    (pipe:write-to sink-name (logior O_WRONLY O_CREAT O_BINARY) #o600)))
170
171 ;;
172 ;; Support for test environment creation and teardown.
173 ;;
174
175 (define (make-test-data filename size)
176   (call-with-binary-output-file
177    filename
178    (lambda (port)
179      (display (make-random-string size) port))))
180
181 (define (create-gpghome)
182   (log "Creating test environment...")
183
184   (srandom (getpid))
185   (make-test-data "random_seed" 600)
186
187   (log "Creating configuration files")
188   (for-each
189    (lambda (name)
190      (file-copy (in-srcdir (string-append name ".tmpl")) name)
191      (let ((p (open-input-output-file name)))
192        (cond
193         ((string=? "gpg.conf" name)
194          (if have-opt-always-trust
195              (display "no-auto-check-trustdb\n" p))
196          (display (string-append "agent-program "
197                                  (tool 'gpg-agent)
198                                  "|--debug-quick-random\n") p)
199          (display "allow-weak-digest-algos\n" p))
200         ((string=? "gpg-agent.conf" name)
201          (display (string-append "pinentry-program " PINENTRY "\n") p)))))
202    '("gpg.conf" "gpg-agent.conf")))
203
204 ;; Initialize the test environment, install appropriate configuration
205 ;; and start the agent, without any keys.
206 (define (setup-environment)
207   (create-gpghome)
208   (start-agent))
209
210 (define (create-legacy-gpghome)
211   (log "Creating sample data files")
212   (for-each
213    (lambda (size)
214      (make-test-data (string-append "data-" (number->string size))
215                      size))
216    '(500 9000 32000 80000))
217
218   (log "Unpacking samples")
219   (for-each
220    (lambda (name)
221      (dearmor (in-srcdir (string-append name "o.asc")) name))
222    '("plain-1" "plain-2" "plain-3" "plain-large"))
223
224   (mkdir "private-keys-v1.d" "-rwx")
225
226   (log "Storing private keys")
227   (for-each
228    (lambda (name)
229      (dearmor (in-srcdir (string-append "/privkeys/" name ".asc"))
230               (string-append "private-keys-v1.d/" name ".key")))
231    '("50B2D4FA4122C212611048BC5FC31BD44393626E"
232      "7E201E28B6FEB2927B321F443205F4724EBE637E"
233      "13FDB8809B17C5547779F9D205C45F47CE0217CE"
234      "343D8AF79796EE107D645A2787A9D9252F924E6F"
235      "8B5ABF3EF9EB8D96B91A0B8C2C4401C91C834C34"
236      "0D6F6AD4C4C803B25470F9104E9F4E6A4CA64255"
237      "FD692BD59D6640A84C8422573D469F84F3B98E53"
238      "76F7E2B35832976B50A27A282D9B87E44577EB66"
239      "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD"
240      "00FE67F28A52A8AA08FFAED20AF832DA916D1985"
241      "1DF48228FEFF3EC2481B106E0ACA8C465C662CC5"
242      "A2832820DC9F40751BDCD375BB0945BA33EC6B4C"
243      "ADE710D74409777B7729A7653373D820F67892E0"
244      "CEFC51AF91F68A2904FBFF62C4F075A4785B803F"
245      "1E28F20E41B54C2D1234D896096495FF57E08D18"
246      "EB33B687EB8581AB64D04852A54453E85F3DF62D"
247      "C6A6390E9388CDBAD71EAEA698233FE5E04F001E"
248      "D69102E0F5AC6B6DB8E4D16DA8E18CF46D88CAE3"))
249
250   (log "Importing public demo and test keys")
251   (for-each
252    (lambda (file)
253      (call-check `(,@GPG --yes --import ,(in-srcdir file))))
254    (list "pubdemo.asc" "pubring.asc" key-file1))
255
256   (pipe:do
257    (pipe:open (in-srcdir "pubring.pkr.asc") (logior O_RDONLY O_BINARY))
258    (pipe:spawn `(,@GPG --dearmor))
259    (pipe:spawn `(,@GPG --yes --import))))
260
261 (define (preset-passphrases)
262   (log "Presetting passphrases")
263   ;; one@example.com
264   (call-check `(,(tool 'gpg-preset-passphrase)
265                 --preset --passphrase def
266                 "50B2D4FA4122C212611048BC5FC31BD44393626E"))
267   (call-check `(,(tool 'gpg-preset-passphrase)
268                 --preset --passphrase def
269                 "7E201E28B6FEB2927B321F443205F4724EBE637E"))
270   ;; alpha@example.net
271   (call-check `(,(tool 'gpg-preset-passphrase)
272                 --preset --passphrase abc
273                 "76F7E2B35832976B50A27A282D9B87E44577EB66"))
274   (call-check `(,(tool 'gpg-preset-passphrase)
275                 --preset --passphrase abc
276                 "A0747D5F9425E6664F4FFBEED20FBCA79FDED2BD")))
277
278 ;; Initialize the test environment, install appropriate configuration
279 ;; and start the agent, with the keys from the legacy test suite.
280 (define (setup-legacy-environment)
281   (create-gpghome)
282   (if (member "--unpack-tarball" *args*)
283       (begin
284         (call-check `(,(tool 'gpgtar) --extract --directory=. ,(cadr *args*)))
285         (start-agent))
286       (begin
287         (start-agent)
288         (create-legacy-gpghome)))
289   (preset-passphrases))
290
291 ;; Create the socket dir and start the agent.
292 (define (start-agent)
293   (log "Starting gpg-agent...")
294   (atexit stop-agent)
295   (catch (log "Warning: Creating socket directory failed:" (car *error*))
296          (call-popen `(,(tool 'gpgconf) --create-socketdir) ""))
297   (call-check `(,(tool 'gpg-connect-agent) --verbose
298                 ,(string-append "--agent-program=" (tool 'gpg-agent)
299                                 "|--debug-quick-random")
300                 /bye)))
301
302 ;; Stop the agent and remove the socket dir.
303 (define (stop-agent)
304   (log "Stopping gpg-agent...")
305   (catch (log "Warning: Removing socket directory failed.")
306          (call-popen `(,(tool 'gpgconf) --remove-socketdir) ""))
307   (call-check `(,(tool 'gpg-connect-agent) --verbose --no-autostart
308                 killagent /bye)))