diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index 862d158a..91287ac3 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -1010,13 +1010,29 @@ (substring-cursor file (string-cursor-next file pos)) 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) (let* ((url (package-url repo pkg)) (raw (fetch-package cfg url))) (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))) - ((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))) (else (let ((snowball (maybe-gunzip raw))) diff --git a/lib/chibi/snow/package.scm b/lib/chibi/snow/package.scm index 48acb6b5..28f07019 100644 --- a/lib/chibi/snow/package.scm +++ b/lib/chibi/snow/package.scm @@ -96,9 +96,8 @@ (define (package-url repo pkg) (let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?)))) - (if (and url (uri-has-scheme? url)) - url - (uri-with-path (string->path-uri 'http (repo-url repo)) url)))) + (and url + (uri-resolve url (string->path-uri 'http (repo-url repo)))))) (define (package-version pkg) (and (pair? pkg) (assoc-get (cdr pkg) 'version eq?))) @@ -161,13 +160,15 @@ (or (and (pair? pkg) (assoc-get-list (cdr pkg) 'installed-files)) '())) (define (library-name->path name) - (call-with-output-string - (lambda (out) - (let lp ((name name)) - (display (car name) out) - (cond ((pair? (cdr name)) - (write-char #\/ out) - (lp (cdr name)))))))) + (if (null? name) + "" + (call-with-output-string + (lambda (out) + (let lp ((name name)) + (display (car name) out) + (cond ((pair? (cdr name)) + (write-char #\/ out) + (lp (cdr name))))))))) ;; map a library to the path name it would be found in (sans extension) (define (library->path library) @@ -205,7 +206,8 @@ (and (pair? lib) (assoc-get (cdr lib) 'url eq?))) (define (library-dependencies lib) - (assoc-get-list (cdr lib) 'depends)) + (cond ((assq 'depends (cdr lib)) => cdr) + (else '()))) (define (parse-library-name str) (cond diff --git a/tools/snow-chibi b/tools/snow-chibi index 8385f48d..6ca3a999 100755 --- a/tools/snow-chibi +++ b/tools/snow-chibi @@ -56,6 +56,8 @@ ;; name type aliases doc '((verbose? boolean (#\v "verbose") "print additional informative messages") (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") (host string "base uri of snow repository") (repository-uri string "uri of snow repository file")