From 31997cb51479af35ef5ccaf6ac6ac53580b7d33a Mon Sep 17 00:00:00 2001
From: Alex Shinn <alexshinn@gmail.com>
Date: Sun, 26 Apr 2015 23:45:43 +0900
Subject: [PATCH] Don't use rsa keys by default for now.
---
lib/chibi/snow/commands.scm | 58 +++++++++++++++++++++---------------
lib/chibi/snow/interface.scm | 2 ++
lib/chibi/snow/package.scm | 42 ++++++++++++++++++--------
lib/chibi/snow/package.sld | 3 +-
tools/snow-chibi | 4 ++-
5 files changed, 71 insertions(+), 38 deletions(-)
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)))