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