tests/gpgscm: Add a TinySCHEME-based test driver.
[gnupg.git] / tests / gpgscm / tests.scm
1 ;; Common definitions for writing tests.
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 ;; Trace displays and returns the given value.  A debugging aid.
21 (define (trace x)
22   (display x)
23   (newline)
24   x)
25
26 ;; Stringification.
27 (define (stringify expression)
28   (let ((p (open-output-string)))
29     (write expression p)
30     (get-output-string p)))
31
32 ;; Reporting.
33 (define (info msg)
34   (display msg)
35   (newline)
36   (flush-stdio))
37
38 (define (error msg)
39   (info msg)
40   (exit 1))
41
42 (define (skip msg)
43   (info msg)
44   (exit 77))
45
46 (define (make-counter)
47   (let ((c 0))
48     (lambda ()
49       (let ((r c))
50         (set! c (+ 1 c))
51         r))))
52
53 (define *progress-nesting* 0)
54
55 (define (call-with-progress msg what)
56   (set! *progress-nesting* (+ 1 *progress-nesting*))
57   (if (= 1 *progress-nesting*)
58       (begin
59         (info msg)
60         (display "    > ")
61         (flush-stdio)
62         (what (lambda (item)
63               (display item)
64               (display " ")
65               (flush-stdio)))
66         (info "< "))
67       (begin
68         (what (lambda (item) (display ".") (flush-stdio)))
69         (display " ")
70         (flush-stdio)))
71   (set! *progress-nesting* (- *progress-nesting* 1)))
72
73 (define (for-each-p msg proc lst)
74   (for-each-p' msg proc (lambda (x) x) lst))
75
76 (define (for-each-p' msg proc fmt lst)
77   (call-with-progress
78    msg
79    (lambda (progress)
80      (for-each (lambda (a)
81                  (progress (fmt a))
82                  (proc a))
83                lst))))
84
85 ;; Process management.
86 (define CLOSED_FD -1)
87 (define (call-with-fds what infd outfd errfd)
88   (wait-process (stringify what) (spawn-process-fd what infd outfd errfd) #t))
89 (define (call what)
90   (call-with-fds what
91                  CLOSED_FD
92                  (if (< *verbose* 0) STDOUT_FILENO CLOSED_FD)
93                  (if (< *verbose* 0) STDERR_FILENO CLOSED_FD)))
94 (define (call-check what)
95   (if (not (= 0 (call what)))
96       (throw (list what "failed"))))
97
98 ;; Accessor functions for the results of 'spawn-process'.
99 (define :stdin car)
100 (define :stdout cadr)
101 (define :stderr caddr)
102 (define :pid cadddr)
103
104 (define (call-with-io what in)
105   (let ((h (spawn-process what 0)))
106     (es-write (:stdin h) in)
107     (es-fclose (:stdin h))
108     (let* ((out (es-read-all (:stdout h)))
109            (err (es-read-all (:stderr h)))
110            (result (wait-process (car what) (:pid h) #t)))
111       (es-fclose (:stdout h))
112       (es-fclose (:stderr h))
113       (list result out err))))
114
115 ;; Accessor function for the results of 'call-with-io'.  ':stdout' and
116 ;; ':stderr' can also be used.
117 (define :retcode car)
118
119 (define (call-popen command input-string)
120   (let ((result (call-with-io command input-string)))
121     (if (= 0 (:retcode result))
122         (:stdout result)
123         (throw (:stderr result)))))
124
125 ;;
126 ;; estream helpers.
127 ;;
128
129 (define (es-read-all stream)
130   (let loop
131       ((acc ""))
132     (if (es-feof stream)
133         acc
134         (loop (string-append acc (es-read stream 4096))))))
135
136 ;;
137 ;; File management.
138 ;;
139 (define (file=? a b)
140   (file-equal a b #t))
141
142 (define (text-file=? a b)
143   (file-equal a b #f))
144
145 (define (file-copy from to)
146   (catch '() (unlink to))
147   (letfd ((source (open from (logior O_RDONLY O_BINARY)))
148           (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
149     (splice source sink)))
150
151 (define (text-file-copy from to)
152   (catch '() (unlink to))
153   (letfd ((source (open from O_RDONLY))
154           (sink (open to (logior O_WRONLY O_CREAT) #o600)))
155     (splice source sink)))
156
157 (define (canonical-path path)
158   (if (char=? #\/ (string-ref path 0))
159       path
160       (string-append (getcwd) "/" path)))
161
162 (define (in-srcdir what)
163   (canonical-path (string-append (getenv "srcdir") "/" what)))
164
165 (define (with-path name)
166   (let loop ((path (string-split (getenv "GPGSCM_PATH") #\:)))
167     (if (null? path)
168         name
169         (let* ((qualified-name (string-append (car path) "/" name))
170                (file-exists (call-with-input-file qualified-name
171                               (lambda (x) #t))))
172           (if file-exists
173               qualified-name
174               (loop (cdr path)))))))
175
176 (define (basename path)
177   (let ((i (string-index path #\/)))
178     (if (equal? i #f)
179         path
180         (basename (substring path (+ 1 i) (string-length path))))))
181
182 ;; Helper for (pipe).
183 (define :read-end car)
184 (define :write-end cadr)
185
186 ;; let-like macro that manages file descriptors.
187 ;;
188 ;; (letfd <bindings> <body>)
189 ;;
190 ;; Bind all variables given in <bindings> and initialize each of them
191 ;; to the given initial value, and close them after evaluting <body>.
192 (macro (letfd form)
193   (let ((result-sym (gensym)))
194     `((lambda (,(caaadr form))
195         (let ((,result-sym
196                ,(if (= 1 (length (cadr form)))
197                     `(begin ,@(cddr form))
198                     `(letfd ,(cdadr form) ,@(cddr form)))))
199           (close ,(caaadr form))
200           ,result-sym)) ,@(cdaadr form))))
201
202 (macro (with-working-directory form)
203   (let ((result-sym (gensym)) (cwd-sym (gensym)))
204     `(let* ((,cwd-sym (getcwd))
205             (_ (if ,(cadr form) (chdir ,(cadr form))))
206             (,result-sym (begin ,@(cddr form))))
207        (chdir ,cwd-sym)
208        ,result-sym)))
209
210 (macro (with-temporary-working-directory form)
211   (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
212     `(let* ((,cwd-sym (getcwd))
213             (,tmp-sym (mkdtemp "gpgscm-XXXXXX"))
214             (_ (chdir ,tmp-sym))
215             (,result-sym (begin ,@(cdr form))))
216        (chdir ,cwd-sym)
217        (unlink-recursively ,tmp-sym)
218        ,result-sym)))
219
220 (define (make-temporary-file . args)
221   (canonical-path (string-append (mkdtemp "gpgscm-XXXXXX")
222                                  "/"
223                                  (if (null? args) "a" (car args)))))
224
225 (define (remove-temporary-file filename)
226   (catch '()
227     (unlink filename))
228   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
229     (catch (echo "removing temporary directory" dirname "failed")
230       (rmdir dirname))))
231
232 ;; let-like macro that manages temporary files.
233 ;;
234 ;; (lettmp <bindings> <body>)
235 ;;
236 ;; Bind all variables given in <bindings>, initialize each of them to
237 ;; a string representing an unique path in the filesystem, and delete
238 ;; them after evaluting <body>.
239 (macro (lettmp form)
240   (let ((result-sym (gensym)))
241     `((lambda (,(caadr form))
242         (let ((,result-sym
243                ,(if (= 1 (length (cadr form)))
244                     `(begin ,@(cddr form))
245                     `(lettmp ,(cdadr form) ,@(cddr form)))))
246           (remove-temporary-file ,(caadr form))
247           ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
248
249 (define (check-execution source transformer)
250   (lettmp (sink)
251           (transformer source sink)))
252
253 (define (check-identity source transformer)
254   (lettmp (sink)
255           (transformer source sink)
256           (if (not (file=? source sink))
257               (error "mismatch"))))
258
259 ;;
260 ;; Monadic pipe support.
261 ;;
262
263 (define pipeM
264   (package
265    (define (new procs source sink producer)
266      (package
267       (define (dump)
268         (write (list procs source sink producer))
269         (newline))
270       (define (add-proc command pid)
271         (new (cons (list command pid) procs) source sink producer))
272       (define (commands)
273         (map car procs))
274       (define (pids)
275         (map cadr procs))
276       (define (set-source source')
277         (new procs source' sink producer))
278       (define (set-sink sink')
279         (new procs source sink' producer))
280       (define (set-producer producer')
281         (if producer
282             (throw "producer already set"))
283         (new procs source sink producer'))))))
284
285
286 (define (pipe:do . commands)
287   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
288     (if (null? cmds)
289         (begin
290           (if M::producer (M::producer))
291           (if (not (null? M::procs))
292               (let* ((retcodes (wait-processes (map stringify (M::commands))
293                                                (M::pids) #t))
294                      (results (map (lambda (p r) (append p (list r)))
295                                    M::procs retcodes))
296                      (failed (filter (lambda (x) (not (= 0 (caddr x))))
297                                      results)))
298                 (if (not (null? failed))
299                     (throw failed))))) ; xxx nicer reporting
300         (if (and (= 2 (length cmds)) (number? (cadr cmds)))
301             ;; hack: if it's an fd, use it as sink
302             (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
303               (if (> M::source 2) (close M::source))
304               (if (> (cadr cmds) 2) (close (cadr cmds)))
305               (loop M' '()))
306             (let ((M' ((car cmds) M)))
307               (if (> M::source 2) (close M::source))
308               (loop M' (cdr cmds)))))))
309
310 (define (pipe:open pathname flags)
311   (lambda (M)
312     (M::set-source (open pathname flags))))
313
314 (define (pipe:defer producer)
315   (lambda (M)
316     (let* ((p (outbound-pipe))
317            (M' (M::set-source (:read-end p))))
318       (M'::set-producer (lambda ()
319                           (producer (:write-end p))
320                           (close (:write-end p)))))))
321 (define (pipe:echo data)
322  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
323
324 (define (pipe:spawn command)
325   (lambda (M)
326     (define (do-spawn M new-source)
327       (let ((pid (spawn-process-fd command M::source M::sink
328                                    (if (> *verbose* 0)
329                                        STDERR_FILENO CLOSED_FD)))
330             (M' (M::set-source new-source)))
331         (M'::add-proc command pid)))
332     (if (= CLOSED_FD M::sink)
333         (let* ((p (pipe))
334                (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
335           (close (:write-end p))
336           (M'::set-sink CLOSED_FD))
337         (do-spawn M CLOSED_FD))))
338
339 (define (pipe:splice sink)
340   (lambda (M)
341     (splice M::source sink)
342     (M::set-source CLOSED_FD)))
343
344 (define (pipe:write-to pathname flags mode)
345   (open pathname flags mode))
346
347 ;;
348 ;; Monadic transformer support.
349 ;;
350
351 (define (tr:do . commands)
352   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
353     (if (null? cmds)
354         (for-each remove-temporary-file tmpfiles)
355         (let ((v ((car cmds) tmpfiles source)))
356           (loop (car v) (cadr v) (cdr cmds))))))
357
358 (define (tr:open pathname)
359   (lambda (tmpfiles source)
360     (list tmpfiles pathname)))
361
362 (define (tr:spawn input command)
363   (lambda (tmpfiles source)
364     (let* ((t (make-temporary-file))
365            (cmd (map (lambda (x)
366                        (cond
367                         ((equal? '**in** x) source)
368                         ((equal? '**out** x) t)
369                         (else x))) command)))
370       (call-popen cmd input)
371       (list (cons t tmpfiles) t))))
372
373 (define (tr:write-to pathname)
374   (lambda (tmpfiles source)
375     (rename source pathname)
376     (list tmpfiles pathname)))
377
378 (define (tr:pipe-do . commands)
379   (lambda (tmpfiles source)
380     (let ((t (make-temporary-file)))
381       (apply pipe:do
382         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
383           ,@commands
384           ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
385       (list (cons t tmpfiles) t))))
386
387 (define (tr:assert-identity reference)
388   (lambda (tmpfiles source)
389     (if (not (file=? source reference))
390         (error "mismatch"))
391     (list tmpfiles source)))
392
393 (define (tr:assert-weak-identity reference)
394   (lambda (tmpfiles source)
395     (if (not (text-file=? source reference))
396         (error "mismatch"))
397     (list tmpfiles source)))
398
399 (define (tr:call-with-content function)
400   (lambda (tmpfiles source)
401     (function (call-with-input-file source read-all))
402     (list tmpfiles source)))