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)))