gpgscm: Free file names.
[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 (define (call-check what)
98   (if (not (= 0 (call what)))
99       (throw (list what "failed"))))
100
101 ;; Accessor functions for the results of 'spawn-process'.
102 (define :stdin car)
103 (define :stdout cadr)
104 (define :stderr caddr)
105 (define :pid cadddr)
106
107 (define (call-with-io what in)
108   (let ((h (spawn-process what 0)))
109     (es-write (:stdin h) in)
110     (es-fclose (:stdin h))
111     (let* ((out (es-read-all (:stdout h)))
112            (err (es-read-all (:stderr h)))
113            (result (wait-process (car what) (:pid h) #t)))
114       (es-fclose (:stdout h))
115       (es-fclose (:stderr h))
116       (list result out err))))
117
118 ;; Accessor function for the results of 'call-with-io'.  ':stdout' and
119 ;; ':stderr' can also be used.
120 (define :retcode car)
121
122 (define (call-popen command input-string)
123   (let ((result (call-with-io command input-string)))
124     (if (= 0 (:retcode result))
125         (:stdout result)
126         (throw (:stderr result)))))
127
128 ;;
129 ;; estream helpers.
130 ;;
131
132 (define (es-read-all stream)
133   (let loop
134       ((acc ""))
135     (if (es-feof stream)
136         acc
137         (loop (string-append acc (es-read stream 4096))))))
138
139 ;;
140 ;; File management.
141 ;;
142 (define (file-exists? name)
143   (call-with-input-file name (lambda (port) #t)))
144
145 (define (file=? a b)
146   (file-equal a b #t))
147
148 (define (text-file=? a b)
149   (file-equal a b #f))
150
151 (define (file-copy from to)
152   (catch '() (unlink to))
153   (letfd ((source (open from (logior O_RDONLY O_BINARY)))
154           (sink (open to (logior O_WRONLY O_CREAT O_BINARY) #o600)))
155     (splice source sink)))
156
157 (define (text-file-copy from to)
158   (catch '() (unlink to))
159   (letfd ((source (open from O_RDONLY))
160           (sink (open to (logior O_WRONLY O_CREAT) #o600)))
161     (splice source sink)))
162
163 (define (canonical-path path)
164   (if (char=? #\/ (string-ref path 0))
165       path
166       (string-append (getcwd) "/" path)))
167
168 (define (in-srcdir what)
169   (canonical-path (string-append (getenv "srcdir") "/" what)))
170
171 (define (with-path name)
172   (let loop ((path (string-split (getenv "GPGSCM_PATH") #\:)))
173     (if (null? path)
174         name
175         (let* ((qualified-name (string-append (car path) "/" name))
176                (file-exists (call-with-input-file qualified-name
177                               (lambda (x) #t))))
178           (if file-exists
179               qualified-name
180               (loop (cdr path)))))))
181
182 (define (basename path)
183   (let ((i (string-index path #\/)))
184     (if (equal? i #f)
185         path
186         (basename (substring path (+ 1 i) (string-length path))))))
187
188 (define (basename-suffix path suffix)
189   (basename
190    (if (string-suffix? path suffix)
191        (substring path 0 (- (string-length path) (string-length suffix)))
192        path)))
193
194 ;; Helper for (pipe).
195 (define :read-end car)
196 (define :write-end cadr)
197
198 ;; let-like macro that manages file descriptors.
199 ;;
200 ;; (letfd <bindings> <body>)
201 ;;
202 ;; Bind all variables given in <bindings> and initialize each of them
203 ;; to the given initial value, and close them after evaluting <body>.
204 (macro (letfd form)
205   (let ((result-sym (gensym)))
206     `((lambda (,(caaadr form))
207         (let ((,result-sym
208                ,(if (= 1 (length (cadr form)))
209                     `(begin ,@(cddr form))
210                     `(letfd ,(cdadr form) ,@(cddr form)))))
211           (close ,(caaadr form))
212           ,result-sym)) ,@(cdaadr form))))
213
214 (macro (with-working-directory form)
215   (let ((result-sym (gensym)) (cwd-sym (gensym)))
216     `(let* ((,cwd-sym (getcwd))
217             (_ (if ,(cadr form) (chdir ,(cadr form))))
218             (,result-sym (begin ,@(cddr form))))
219        (chdir ,cwd-sym)
220        ,result-sym)))
221
222 (macro (with-temporary-working-directory form)
223   (let ((result-sym (gensym)) (cwd-sym (gensym)) (tmp-sym (gensym)))
224     `(let* ((,cwd-sym (getcwd))
225             (,tmp-sym (mkdtemp "gpgscm-XXXXXX"))
226             (_ (chdir ,tmp-sym))
227             (,result-sym (begin ,@(cdr form))))
228        (chdir ,cwd-sym)
229        (unlink-recursively ,tmp-sym)
230        ,result-sym)))
231
232 (define (make-temporary-file . args)
233   (canonical-path (string-append (mkdtemp "gpgscm-XXXXXX")
234                                  "/"
235                                  (if (null? args) "a" (car args)))))
236
237 (define (remove-temporary-file filename)
238   (catch '()
239     (unlink filename))
240   (let ((dirname (substring filename 0 (string-rindex filename #\/))))
241     (catch (echo "removing temporary directory" dirname "failed")
242       (rmdir dirname))))
243
244 ;; let-like macro that manages temporary files.
245 ;;
246 ;; (lettmp <bindings> <body>)
247 ;;
248 ;; Bind all variables given in <bindings>, initialize each of them to
249 ;; a string representing an unique path in the filesystem, and delete
250 ;; them after evaluting <body>.
251 (macro (lettmp form)
252   (let ((result-sym (gensym)))
253     `((lambda (,(caadr form))
254         (let ((,result-sym
255                ,(if (= 1 (length (cadr form)))
256                     `(begin ,@(cddr form))
257                     `(lettmp ,(cdadr form) ,@(cddr form)))))
258           (remove-temporary-file ,(caadr form))
259           ,result-sym)) (make-temporary-file ,(symbol->string (caadr form))))))
260
261 (define (check-execution source transformer)
262   (lettmp (sink)
263           (transformer source sink)))
264
265 (define (check-identity source transformer)
266   (lettmp (sink)
267           (transformer source sink)
268           (if (not (file=? source sink))
269               (error "mismatch"))))
270
271 ;;
272 ;; Monadic pipe support.
273 ;;
274
275 (define pipeM
276   (package
277    (define (new procs source sink producer)
278      (package
279       (define (dump)
280         (write (list procs source sink producer))
281         (newline))
282       (define (add-proc command pid)
283         (new (cons (list command pid) procs) source sink producer))
284       (define (commands)
285         (map car procs))
286       (define (pids)
287         (map cadr procs))
288       (define (set-source source')
289         (new procs source' sink producer))
290       (define (set-sink sink')
291         (new procs source sink' producer))
292       (define (set-producer producer')
293         (if producer
294             (throw "producer already set"))
295         (new procs source sink producer'))))))
296
297
298 (define (pipe:do . commands)
299   (let loop ((M (pipeM::new '() CLOSED_FD CLOSED_FD #f)) (cmds commands))
300     (if (null? cmds)
301         (begin
302           (if M::producer (M::producer))
303           (if (not (null? M::procs))
304               (let* ((retcodes (wait-processes (map stringify (M::commands))
305                                                (M::pids) #t))
306                      (results (map (lambda (p r) (append p (list r)))
307                                    M::procs retcodes))
308                      (failed (filter (lambda (x) (not (= 0 (caddr x))))
309                                      results)))
310                 (if (not (null? failed))
311                     (throw failed))))) ; xxx nicer reporting
312         (if (and (= 2 (length cmds)) (number? (cadr cmds)))
313             ;; hack: if it's an fd, use it as sink
314             (let ((M' ((car cmds) (M::set-sink (cadr cmds)))))
315               (if (> M::source 2) (close M::source))
316               (if (> (cadr cmds) 2) (close (cadr cmds)))
317               (loop M' '()))
318             (let ((M' ((car cmds) M)))
319               (if (> M::source 2) (close M::source))
320               (loop M' (cdr cmds)))))))
321
322 (define (pipe:open pathname flags)
323   (lambda (M)
324     (M::set-source (open pathname flags))))
325
326 (define (pipe:defer producer)
327   (lambda (M)
328     (let* ((p (outbound-pipe))
329            (M' (M::set-source (:read-end p))))
330       (M'::set-producer (lambda ()
331                           (producer (:write-end p))
332                           (close (:write-end p)))))))
333 (define (pipe:echo data)
334  (pipe:defer (lambda (sink) (display data (fdopen sink "wb")))))
335
336 (define (pipe:spawn command)
337   (lambda (M)
338     (define (do-spawn M new-source)
339       (let ((pid (spawn-process-fd command M::source M::sink
340                                    (if (> *verbose* 0)
341                                        STDERR_FILENO CLOSED_FD)))
342             (M' (M::set-source new-source)))
343         (M'::add-proc command pid)))
344     (if (= CLOSED_FD M::sink)
345         (let* ((p (pipe))
346                (M' (do-spawn (M::set-sink (:write-end p)) (:read-end p))))
347           (close (:write-end p))
348           (M'::set-sink CLOSED_FD))
349         (do-spawn M CLOSED_FD))))
350
351 (define (pipe:splice sink)
352   (lambda (M)
353     (splice M::source sink)
354     (M::set-source CLOSED_FD)))
355
356 (define (pipe:write-to pathname flags mode)
357   (open pathname flags mode))
358
359 ;;
360 ;; Monadic transformer support.
361 ;;
362
363 (define (tr:do . commands)
364   (let loop ((tmpfiles '()) (source  #f) (cmds commands))
365     (if (null? cmds)
366         (for-each remove-temporary-file tmpfiles)
367         (let* ((v ((car cmds) tmpfiles source))
368                (tmpfiles' (car v))
369                (sink (cadr v))
370                (error (caddr v)))
371           (if error
372               (begin
373                 (for-each remove-temporary-file tmpfiles')
374                 (throw error)))
375           (loop tmpfiles' sink (cdr cmds))))))
376
377 (define (tr:open pathname)
378   (lambda (tmpfiles source)
379     (list tmpfiles pathname #f)))
380
381 (define (tr:spawn input command)
382   (lambda (tmpfiles source)
383     (if (and (member '**in** command) (not source))
384         (error (string-append (stringify cmd) " needs an input")))
385     (let* ((t (make-temporary-file))
386            (cmd (map (lambda (x)
387                        (cond
388                         ((equal? '**in** x) source)
389                         ((equal? '**out** x) t)
390                         (else x))) command)))
391       (catch (list (cons t tmpfiles) t *error*)
392              (call-popen cmd input)
393              (if (and (member '**out** command) (not (file-exists? t)))
394                  (error (string-append (stringify cmd)
395                                        " did not produce '" t "'.")))
396              (list (cons t tmpfiles) t #f)))))
397
398 (define (tr:write-to pathname)
399   (lambda (tmpfiles source)
400     (rename source pathname)
401     (list tmpfiles pathname #f)))
402
403 (define (tr:pipe-do . commands)
404   (lambda (tmpfiles source)
405     (let ((t (make-temporary-file)))
406       (apply pipe:do
407         `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
408           ,@commands
409           ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
410       (list (cons t tmpfiles) t #f))))
411
412 (define (tr:assert-identity reference)
413   (lambda (tmpfiles source)
414     (if (not (file=? source reference))
415         (error "mismatch"))
416     (list tmpfiles source #f)))
417
418 (define (tr:assert-weak-identity reference)
419   (lambda (tmpfiles source)
420     (if (not (text-file=? source reference))
421         (error "mismatch"))
422     (list tmpfiles source #f)))
423
424 (define (tr:call-with-content function . args)
425   (lambda (tmpfiles source)
426     (catch (list tmpfiles source *error*)
427            (apply function `(,(call-with-input-file source read-all) ,@args)))
428     (list tmpfiles source #f)))