Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 13:49:17 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Asking for confirmation instead of failing automatically

Browse source 
on digest and signature mismatches.
This commit is contained in:
Alex Shinn 2014-07-08 22:44:51 +09:00
parent 6be655083c
commit 1e69cbc90f
3 changed files with 33 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
lib/chibi/snow/commands.scm
View file

@ -1010,13 +1010,29 @@
(substring-cursor file (string-cursor-next file pos)) (substring-cursor file (string-cursor-next file pos))
file))) file)))
(define (package-maybe-digest-mismatches impl cfg pkg raw)
(and (not (conf-get cfg 'ignore-digests?))
(let ((res (package-digest-mismatches cfg pkg raw)))
(and res
(not (yes-or-no? cfg "Package checksum mismatches: " res
"\nProceed anyway?"))
res))))
(define (package-maybe-signature-mismatches repo impl cfg pkg raw)
(and (not (conf-get cfg 'ignore-signature?))
(let ((res (package-signature-mismatches repo cfg pkg raw)))
(and res
(not (yes-or-no? cfg "Package signature mismatches: " res
"\nProceed anyway?"))
res))))
(define (install-package repo impl cfg pkg) (define (install-package repo impl cfg pkg)
(let* ((url (package-url repo pkg)) (let* ((url (package-url repo pkg))
(raw (fetch-package cfg url))) (raw (fetch-package cfg url)))
(cond (cond
((package-digest-mismatches cfg pkg raw) ((package-maybe-digest-mismatches impl cfg pkg raw)
=> (lambda (x) (die 2 "package checksum didn't match: " x))) => (lambda (x) (die 2 "package checksum didn't match: " x)))
((package-signature-mismatches repo cfg pkg raw) ((package-maybe-signature-mismatches repo impl cfg pkg raw)
=> (lambda (x) (die 2 "package signature didn't match: " x))) => (lambda (x) (die 2 "package signature didn't match: " x)))
(else (else
(let ((snowball (maybe-gunzip raw))) (let ((snowball (maybe-gunzip raw)))

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

@ -96,9 +96,8 @@
(define (package-url repo pkg) (define (package-url repo pkg)
(let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?)))) (let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?))))
(if (and url (uri-has-scheme? url)) (and url
url (uri-resolve url (string->path-uri 'http (repo-url repo))))))
(uri-with-path (string->path-uri 'http (repo-url repo)) url))))
(define (package-version pkg) (define (package-version pkg)
(and (pair? pkg) (assoc-get (cdr pkg) 'version eq?))) (and (pair? pkg) (assoc-get (cdr pkg) 'version eq?)))
@ -161,13 +160,15 @@
(or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '())) (or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '()))
(define (library-name->path name) (define (library-name->path name)
(call-with-output-string (if (null? name)
(lambda (out) ""
(let lp ((name name)) (call-with-output-string
(display (car name) out) (lambda (out)
(cond ((pair? (cdr name)) (let lp ((name name))
(write-char #\/ out) (display (car name) out)
(lp (cdr name)))))))) (cond ((pair? (cdr name))
(write-char #\/ out)
(lp (cdr name)))))))))
;; map a library to the path name it would be found in (sans extension) ;; map a library to the path name it would be found in (sans extension)
(define (library->path library) (define (library->path library)
@ -205,7 +206,8 @@
(and (pair? lib) (assoc-get (cdr lib) 'url eq?))) (and (pair? lib) (assoc-get (cdr lib) 'url eq?)))
(define (library-dependencies lib) (define (library-dependencies lib)
(assoc-get-list (cdr lib) 'depends)) (cond ((assq 'depends (cdr lib)) => cdr)
(else '())))
(define (parse-library-name str) (define (parse-library-name str)
(cond (cond

2
tools/snow-chibi
View file

@ -56,6 +56,8 @@
;; name type aliases doc ;; name type aliases doc
'((verbose? boolean (#\v "verbose") "print additional informative messages") '((verbose? boolean (#\v "verbose") "print additional informative messages")
(always-yes? boolean (#\y "always-yes") "answer all questions with yes") (always-yes? boolean (#\y "always-yes") "answer all questions with yes")
(ignore-signature? boolean ("ignore-sig") "don't verify package signatures")
(ignore-digest? boolean ("ignore-digest") "don't verify package checksums")
;;(config filename "path to configuration file") ;;(config filename "path to configuration file")
(host string "base uri of snow repository") (host string "base uri of snow repository")
(repository-uri string "uri of snow repository file") (repository-uri string "uri of snow repository file")