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