mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Don't use rsa keys by default for now.
This commit is contained in:
parent
00691b64f1
commit
31997cb514
5 changed files with 71 additions and 38 deletions
|
@ -650,6 +650,8 @@
|
||||||
|
|
||||||
(define (rsa-key->sexp key name email . o)
|
(define (rsa-key->sexp key name email . o)
|
||||||
(let ((password (and (pair? o) (not (equal? "" (car o))) (car o))))
|
(let ((password (and (pair? o) (not (equal? "" (car o))) (car o))))
|
||||||
|
(cond
|
||||||
|
(key
|
||||||
`((name ,name)
|
`((name ,name)
|
||||||
(email ,email)
|
(email ,email)
|
||||||
(bits ,(rsa-key-bits key))
|
(bits ,(rsa-key-bits key))
|
||||||
|
@ -667,11 +669,17 @@
|
||||||
`((private-key
|
`((private-key
|
||||||
(modulus ,(integer->hex-string (rsa-key-n key)))
|
(modulus ,(integer->hex-string (rsa-key-n key)))
|
||||||
(exponent ,d)))))
|
(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)
|
(define (conf-gen-key cfg bits)
|
||||||
(show #t "Generating a new key, this may take quite a while...\n")
|
(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)
|
(rsa-key-gen bits)
|
||||||
(let* ((lo (max 3 (expt 2 (- bits 1))))
|
(let* ((lo (max 3 (expt 2 (- bits 1))))
|
||||||
(hi (expt 2 bits))
|
(hi (expt 2 bits))
|
||||||
|
@ -683,7 +691,7 @@
|
||||||
|
|
||||||
(define (command/gen-key cfg spec)
|
(define (command/gen-key cfg spec)
|
||||||
(show #t
|
(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 "
|
"We need a descriptive name, and an email address to "
|
||||||
"uniquely identify the key.\n")
|
"uniquely identify the key.\n")
|
||||||
(let* ((name (input cfg '(gen-key name) "Name: "))
|
(let* ((name (input cfg '(gen-key name) "Name: "))
|
||||||
|
@ -691,9 +699,11 @@
|
||||||
(passwd (input-password cfg '(gen-key password)
|
(passwd (input-password cfg '(gen-key password)
|
||||||
"Password for upload: "
|
"Password for upload: "
|
||||||
"Password (confirmation): "))
|
"Password (confirmation): "))
|
||||||
(bits (input-number cfg '(gen-key bits)
|
(bits (if (conf-get cfg '(command gen-key gen-rsa-key?))
|
||||||
"RSA key size in bits: " 512 64 20148))
|
(input-number cfg '(gen-key bits)
|
||||||
(key (conf-gen-key cfg 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))
|
(snow-dir (conf-get-snow-dir cfg))
|
||||||
(key-file (or (conf-get cfg 'key-file)
|
(key-file (or (conf-get cfg 'key-file)
|
||||||
(string-append snow-dir "/priv-key.scm")))
|
(string-append snow-dir "/priv-key.scm")))
|
||||||
|
@ -779,7 +789,7 @@
|
||||||
(append
|
(append
|
||||||
`(signature
|
`(signature
|
||||||
(email ,email))
|
(email ,email))
|
||||||
(if (conf-get cfg 'sign-uploads?)
|
(if (and rsa-key (conf-get cfg 'sign-uploads?))
|
||||||
(let* ((sig (fast-eval
|
(let* ((sig (fast-eval
|
||||||
`(rsa-sign (make-rsa-key ,(rsa-key-bits rsa-key)
|
`(rsa-sign (make-rsa-key ,(rsa-key-bits rsa-key)
|
||||||
,(rsa-key-n rsa-key)
|
,(rsa-key-n rsa-key)
|
||||||
|
|
|
@ -109,6 +109,8 @@
|
||||||
(cond
|
(cond
|
||||||
((not (number? res))
|
((not (number? res))
|
||||||
(fail "not a valid number"))
|
(fail "not a valid number"))
|
||||||
|
((equal? res default)
|
||||||
|
res)
|
||||||
((and lo (< res lo))
|
((and lo (< res lo))
|
||||||
(fail (each "too low, must be greater than " lo)))
|
(fail (each "too low, must be greater than " lo)))
|
||||||
((and hi (> res hi))
|
((and hi (> res hi))
|
||||||
|
|
|
@ -83,10 +83,18 @@
|
||||||
(and (pair? sig)
|
(and (pair? sig)
|
||||||
(assoc-get (cdr sig) 'email eq?)))))
|
(assoc-get (cdr sig) 'email eq?)))))
|
||||||
|
|
||||||
|
(define (strip-email str)
|
||||||
|
(string-trim (regexp-replace '(: "<" (* (~ (">"))) ">") str "")))
|
||||||
|
|
||||||
(define (package-author repo pkg . o)
|
(define (package-author repo pkg . o)
|
||||||
(and (package? pkg)
|
(let ((show-email? (and (pair? o) (car o))))
|
||||||
(let ((email (package-email pkg))
|
(cond
|
||||||
(show-email? (and (pair? o) (car o))))
|
((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
|
(or (cond
|
||||||
((repo-find-publisher repo email)
|
((repo-find-publisher repo email)
|
||||||
=> (lambda (pub)
|
=> (lambda (pub)
|
||||||
|
@ -95,7 +103,17 @@
|
||||||
(string-append name " <" (or email "") ">")
|
(string-append name " <" (or email "") ">")
|
||||||
(or name email "")))))
|
(or name email "")))))
|
||||||
(else #f))
|
(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)
|
(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?))))
|
||||||
|
|
|
@ -4,7 +4,7 @@
|
||||||
package-name package-email package-url package-version
|
package-name package-email package-url package-version
|
||||||
package-libraries package-programs package-data-files
|
package-libraries package-programs package-data-files
|
||||||
package-provides? package-dependencies package-test-dependencies
|
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-mismatches package-signature-mismatches
|
||||||
package-digest-ok? package-signature-ok?
|
package-digest-ok? package-signature-ok?
|
||||||
package->path package-name->meta-file
|
package->path package-name->meta-file
|
||||||
|
@ -37,6 +37,7 @@
|
||||||
(chibi filesystem)
|
(chibi filesystem)
|
||||||
(chibi io)
|
(chibi io)
|
||||||
(chibi pathname)
|
(chibi pathname)
|
||||||
|
(chibi regexp)
|
||||||
(chibi string)
|
(chibi string)
|
||||||
(chibi tar)
|
(chibi tar)
|
||||||
(chibi uri)
|
(chibi uri)
|
||||||
|
|
|
@ -106,7 +106,9 @@
|
||||||
(validity-period string)
|
(validity-period string)
|
||||||
(name string)
|
(name string)
|
||||||
(library-prefix (list symbol))
|
(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
|
(define reg-key-spec
|
||||||
'((uri string)
|
'((uri string)
|
||||||
(email string)))
|
(email string)))
|
||||||
|
|
Loading…
Add table
Reference in a new issue