Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-11 23:17:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing bug in invalid-signature-reason, allowing a proc value in update-repo-package.

Browse source
This commit is contained in:
Alex Shinn 2015-05-19 22:46:36 +09:00
parent ad59eee89f
commit f255c35695
1 changed files with 14 additions and 10 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

24
lib/chibi/snow/fort.scm
View file

@ -74,17 +74,17 @@
(actual-digest ((lookup-digest digest-name) snowball))
(sig (assoc-get (cdr sig-spec) 'rsa))
(email (assoc-get (cdr sig-spec) 'email))
(rsa-key-sexp (find (rsa-identity=? email)
(repo-publishers cfg)))
(publisher (find (rsa-identity=? email)
(repo-publishers cfg)))
(verify-rsa? (conf-get cfg 'verify-signatures?))
(rsa-key (and verify-rsa?
(pair? rsa-key-sexp)
(extract-rsa-public-key (cdr rsa-key-sexp)))))
(pair? publisher)
(extract-rsa-public-key (cdr publisher)))))
(cond
((not (equal? digest actual-digest))
(string-append "the " digest-name " digest in the signature <" digest
"> didn't match the actual value: <" actual-digest ">"))
((and rsa-key-sexp (not rsa-key))
((not publisher)
(string-append "unknown publisher: " email))
((and verify-rsa?
(not (rsa-verify? rsa-key
@ -179,8 +179,11 @@
(rewrite-repo
cfg
(lambda (repo)
(let ((repo (if (pair? repo) repo '(repository))))
`(,(car repo) ,value ,@(remove rem-pred (cdr repo)))))))
(let*-values (((repo) (if (pair? repo) repo '(repository)))
((drop keep) (partition rem-pred (cdr repo))))
`(,(car repo)
,(if (procedure? value) (value repo drop) value)
,@keep)))))
(define (update-repo-object cfg key-field value)
(let* ((type (car value))
@ -192,7 +195,7 @@
(equal? key-value (assoc-get (cdr x) key-field eq?))))))
(update-repo cfg pred value)))
(define (update-repo-package cfg pkg)
(define (update-repo-package cfg pkg . o)
(let* ((email (package-email pkg))
(auth-pred (lambda (x) (equal? email (package-email x))))
(pkg-pred
@ -210,8 +213,9 @@
(rem-pred
(lambda (x)
(and (pair? x) (eq? 'package (car x))
(auth-pred x) (pkg-pred x)))))
(update-repo cfg rem-pred pkg)))
(auth-pred x) (pkg-pred x))))
(value (if (pair? o) (lambda (repo drop) ((car o) repo drop pkg)) pkg)))
(update-repo cfg rem-pred value)))
(define (fail msg . args)
`(span (@ (style . "background:red")) ,msg ,@args))