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)
|
||||
(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)
|
||||
|
|
|
@ -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))
|
||||
|
|
|
@ -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?))))
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
Loading…
Add table
Reference in a new issue