security-and-privacy/gnupg
security-and-privacy/gnupg
1
0
Fork 0
mirror of git://git.gnupg.org/gnupg.git synced 2025-01-08 12:44:23 +01:00
Code Activity

gpgscm: Handle exceptions in the transformation monad.

Browse Source 
* tests/gpgscm/tests.scm (pipe:do): Raise errors.
(tr:spawn): Catch and return errors.
(tr:call-with-content): Likewise.
(tr:{open,write-to,pipe-do,assert-identity,assert-weak-identity}):
Adapt.

Signed-off-by: Justus Winter <justus@g10code.com>
This commit is contained in:
Justus Winter 2016-06-23 17:18:13 +02:00
parent 1e822654c1
commit 145910afc0
1 changed files with 23 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
tests/gpgscm/tests.scm
View File

@ -364,12 +364,19 @@
(let loop ((tmpfiles '()) (source #f) (cmds commands)) (let loop ((tmpfiles '()) (source #f) (cmds commands))
(if (null? cmds) (if (null? cmds)
(for-each remove-temporary-file tmpfiles) (for-each remove-temporary-file tmpfiles)
(let ((v ((car cmds) tmpfiles source))) (let* ((v ((car cmds) tmpfiles source))
(loop (car v) (cadr v) (cdr cmds)))))) (tmpfiles' (car v))
(sink (cadr v))
(error (caddr v)))
(if error
(begin
(for-each remove-temporary-file tmpfiles')
(throw error)))
(loop tmpfiles' sink (cdr cmds))))))
(define (tr:open pathname) (define (tr:open pathname)
(lambda (tmpfiles source) (lambda (tmpfiles source)
(list tmpfiles pathname))) (list tmpfiles pathname #f)))
(define (tr:spawn input command) (define (tr:spawn input command)
(lambda (tmpfiles source) (lambda (tmpfiles source)
@ -381,15 +388,17 @@
((equal? '**in** x) source) ((equal? '**in** x) source)
((equal? '**out** x) t) ((equal? '**out** x) t)
(else x))) command))) (else x))) command)))
(call-popen cmd input) (catch (list (cons t tmpfiles) t *error*)
(if (and (member '**out** command) (not (file-exists? t))) (call-popen cmd input)
(error (string-append (stringify cmd) " did not produce '" t "'."))) (if (and (member '**out** command) (not (file-exists? t)))
(list (cons t tmpfiles) t)))) (error (string-append (stringify cmd)
" did not produce '" t "'.")))
(list (cons t tmpfiles) t #f)))))
(define (tr:write-to pathname) (define (tr:write-to pathname)
(lambda (tmpfiles source) (lambda (tmpfiles source)
(rename source pathname) (rename source pathname)
(list tmpfiles pathname))) (list tmpfiles pathname #f)))
(define (tr:pipe-do . commands) (define (tr:pipe-do . commands)
(lambda (tmpfiles source) (lambda (tmpfiles source)
@ -398,21 +407,22 @@
`(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '()) `(,@(if source `(,(pipe:open source (logior O_RDONLY O_BINARY))) '())
,@commands ,@commands
,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600))) ,(pipe:write-to t (logior O_WRONLY O_BINARY O_CREAT) #o600)))
(list (cons t tmpfiles) t)))) (list (cons t tmpfiles) t #f))))
(define (tr:assert-identity reference) (define (tr:assert-identity reference)
(lambda (tmpfiles source) (lambda (tmpfiles source)
(if (not (file=? source reference)) (if (not (file=? source reference))
(error "mismatch")) (error "mismatch"))
(list tmpfiles source))) (list tmpfiles source #f)))
(define (tr:assert-weak-identity reference) (define (tr:assert-weak-identity reference)
(lambda (tmpfiles source) (lambda (tmpfiles source)
(if (not (text-file=? source reference)) (if (not (text-file=? source reference))
(error "mismatch")) (error "mismatch"))
(list tmpfiles source))) (list tmpfiles source #f)))
(define (tr:call-with-content function . args) (define (tr:call-with-content function . args)
(lambda (tmpfiles source) (lambda (tmpfiles source)
(apply function `(,(call-with-input-file source read-all) ,@args)) (catch (list tmpfiles source *error*)
(list tmpfiles source))) (apply function `(,(call-with-input-file source read-all) ,@args)))
(list tmpfiles source #f)))