Don't use rsa keys by default for now.

This commit is contained in:
Alex Shinn 2015-04-26 23:45:43 +09:00
parent 00691b64f1
commit 31997cb514
5 changed files with 71 additions and 38 deletions

View file

@ -650,6 +650,8 @@
(define (rsa-key->sexp key name email . o)
(let ((password (and (pair? o) (not (equal? "" (car o))) (car o))))
(cond
(key
`((name ,name)
(email ,email)
(bits ,(rsa-key-bits key))
@ -667,11 +669,17 @@
`((private-key
(modulus ,(integer->hex-string (rsa-key-n key)))
(exponent ,d)))))
(else '())))))
(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)

View file

@ -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))

View file

@ -83,10 +83,18 @@
(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))))
(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)
@ -95,7 +103,17 @@
(string-append name " <" (or email "") ">")
(or name email "")))))
(else #f))
email))))
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?))))

View file

@ -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)

View file

@ -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)))