diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index d8ee1e16..bb093c14 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -650,28 +650,36 @@ (define (rsa-key->sexp key name email . o) (let ((password (and (pair? o) (not (equal? "" (car o))) (car o)))) - `((name ,name) - (email ,email) - (bits ,(rsa-key-bits key)) - ,@(cond (password `((password ,password))) (else '())) - ,@(cond - ((rsa-key-e key) - => (lambda (e) - `((public-key - (modulus ,(integer->hex-string (rsa-key-n key))) - (exponent ,e))))) - (else '())) - ,@(cond - ((rsa-key-d key) - => (lambda (d) - `((private-key - (modulus ,(integer->hex-string (rsa-key-n key))) - (exponent ,d))))) - (else '()))))) + (cond + (key + `((name ,name) + (email ,email) + (bits ,(rsa-key-bits key)) + ,@(cond (password `((password ,password))) (else '())) + ,@(cond + ((rsa-key-e key) + => (lambda (e) + `((public-key + (modulus ,(integer->hex-string (rsa-key-n key))) + (exponent ,e))))) + (else '())) + ,@(cond + ((rsa-key-d key) + => (lambda (d) + `((private-key + (modulus ,(integer->hex-string (rsa-key-n key))) + (exponent ,d))))) + (else '())))) + (password + `((name ,name) + (email ,email) + (password ,password))) + (else + (error "neither key nor password provided" email))))) (define (conf-gen-key cfg bits) (show #t "Generating a new key, this may take quite a while...\n") - (if (conf-get cfg 'gen-key-in-process?) + (if (conf-get cfg '(command gen-key gen-key-in-process?)) (rsa-key-gen bits) (let* ((lo (max 3 (expt 2 (- bits 1)))) (hi (expt 2 bits)) @@ -683,7 +691,7 @@ (define (command/gen-key cfg spec) (show #t - "Generate a new RSA key for signing packages.\n" + "Generate a new key for uploading packages.\n" "We need a descriptive name, and an email address to " "uniquely identify the key.\n") (let* ((name (input cfg '(gen-key name) "Name: ")) @@ -691,9 +699,11 @@ (passwd (input-password cfg '(gen-key password) "Password for upload: " "Password (confirmation): ")) - (bits (input-number cfg '(gen-key bits) - "RSA key size in bits: " 512 64 20148)) - (key (conf-gen-key cfg bits)) + (bits (if (conf-get cfg '(command gen-key gen-rsa-key?)) + (input-number cfg '(gen-key bits) + "RSA key size in bits: " 0 256 2048) + 0)) + (key (and (>= bits 256) (conf-gen-key cfg bits))) (snow-dir (conf-get-snow-dir cfg)) (key-file (or (conf-get cfg 'key-file) (string-append snow-dir "/priv-key.scm"))) @@ -779,7 +789,7 @@ (append `(signature (email ,email)) - (if (conf-get cfg 'sign-uploads?) + (if (and rsa-key (conf-get cfg 'sign-uploads?)) (let* ((sig (fast-eval `(rsa-sign (make-rsa-key ,(rsa-key-bits rsa-key) ,(rsa-key-n rsa-key) diff --git a/lib/chibi/snow/interface.scm b/lib/chibi/snow/interface.scm index e0866648..fe6a1181 100644 --- a/lib/chibi/snow/interface.scm +++ b/lib/chibi/snow/interface.scm @@ -109,6 +109,8 @@ (cond ((not (number? res)) (fail "not a valid number")) + ((equal? res default) + res) ((and lo (< res lo)) (fail (each "too low, must be greater than " lo))) ((and hi (> res hi)) diff --git a/lib/chibi/snow/package.scm b/lib/chibi/snow/package.scm index 86b51fa1..2f23b50f 100644 --- a/lib/chibi/snow/package.scm +++ b/lib/chibi/snow/package.scm @@ -83,19 +83,37 @@ (and (pair? sig) (assoc-get (cdr sig) 'email eq?))))) +(define (strip-email str) + (string-trim (regexp-replace '(: "<" (* (~ (">"))) ">") str ""))) + (define (package-author repo pkg . o) - (and (package? pkg) - (let ((email (package-email pkg)) - (show-email? (and (pair? o) (car o)))) - (or (cond - ((repo-find-publisher repo email) - => (lambda (pub) - (let ((name (assoc-get pub 'name))) - (if (and name show-email?) - (string-append name " <" (or email "") ">") - (or name email ""))))) - (else #f)) - email)))) + (let ((show-email? (and (pair? o) (car o)))) + (cond + ((not (package? pkg)) + #f) + ((assoc-get (cdr pkg) 'authors) + => (lambda (authors) (if show-email? authors (strip-email authors)))) + (else + (let ((email (package-email pkg))) + (or (cond + ((repo-find-publisher repo email) + => (lambda (pub) + (let ((name (assoc-get pub 'name))) + (if (and name show-email?) + (string-append name " <" (or email "") ">") + (or name email ""))))) + (else #f)) + email)))))) + +(define (package-maintainer repo pkg . o) + (let ((show-email? (and (pair? o) (car o)))) + (cond + ((not (package? pkg)) + #f) + ((assoc-get (cdr pkg) 'maintainers) + => (lambda (maint) (if show-email? maint (strip-email maint)))) + (else + #f)))) (define (package-url repo pkg) (let ((url (and (pair? pkg) (assoc-get (cdr pkg) 'url eq?)))) diff --git a/lib/chibi/snow/package.sld b/lib/chibi/snow/package.sld index 9602ee1d..2fcb3c00 100644 --- a/lib/chibi/snow/package.sld +++ b/lib/chibi/snow/package.sld @@ -4,7 +4,7 @@ package-name package-email package-url package-version package-libraries package-programs package-data-files package-provides? package-dependencies package-test-dependencies - package-installed-files package-author + package-installed-files package-author package-maintainer package-digest-mismatches package-signature-mismatches package-digest-ok? package-signature-ok? package->path package-name->meta-file @@ -37,6 +37,7 @@ (chibi filesystem) (chibi io) (chibi pathname) + (chibi regexp) (chibi string) (chibi tar) (chibi uri) diff --git a/tools/snow-chibi b/tools/snow-chibi index df6b2e95..e3cf4aae 100755 --- a/tools/snow-chibi +++ b/tools/snow-chibi @@ -106,7 +106,9 @@ (validity-period string) (name string) (library-prefix (list symbol)) - (email string))) + (email string) + (gen-rsa-key? boolean ("gen-rsa-key")) + (gen-key-in-process? boolean ("gen-key-in-process")))) (define reg-key-spec '((uri string) (email string)))