Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-09 14:07:34 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Allowing --uri arguments for reg-key and upload.

Browse source
This commit is contained in:
Alex Shinn 2014-07-01 22:23:47 +09:00
parent 3b410c5ac1
commit d181f28c24
2 changed files with 16 additions and 9 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

17
lib/chibi/snow/commands.scm
View file

@ -300,6 +300,7 @@
(define (package-description cfg spec libs docs) (define (package-description cfg spec libs docs)
(cond (cond
((conf-get cfg '(command package description))) ((conf-get cfg '(command package description)))
((conf-get cfg '(command upload description)))
;; Crazy hack, make this more robust, probably opt-in. ;; Crazy hack, make this more robust, probably opt-in.
((and (pair? docs) (pair? (car docs)) (eq? 'inline (caar docs)) ((and (pair? docs) (pair? (car docs)) (eq? 'inline (caar docs))
(regexp-search (regexp-search
@ -473,12 +474,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reg-key - register an RSA key pair with a repository. ;; Reg-key - register an RSA key pair with a repository.
(define (remote-uri cfg path) (define (remote-uri cfg name path)
(make-path (or (conf-get cfg 'host) "http://snow-fort.org") (or (conf-get cfg name)
path)) (make-path (or (conf-get cfg 'host) "http://snow-fort.org")
path)))
(define (remote-command cfg path params) (define (remote-command cfg name path params)
(let ((uri (remote-uri cfg path))) (let ((uri (remote-uri cfg name path)))
(sxml-display-as-text (read (http-post uri (cons '(fmt . "sexp") params)))) (sxml-display-as-text (read (http-post uri (cons '(fmt . "sexp") params))))
(newline))) (newline)))
@ -496,6 +498,7 @@
(rsa-pub-key-str (rsa-pub-key-str
(write-to-string (rsa-key->sexp rsa-pub-key name email)))) (write-to-string (rsa-key->sexp rsa-pub-key name email))))
(remote-command cfg (remote-command cfg
'(command reg-key uri)
"/pkg/reg" "/pkg/reg"
`((u (file . "pub-key.scm") `((u (file . "pub-key.scm")
(value . ,rsa-pub-key-str)))))) (value . ,rsa-pub-key-str))))))
@ -579,7 +582,7 @@
`(sig (file . "package.sig") `(sig (file . "package.sig")
(value . ,(write-to-string (value . ,(write-to-string
(generate-signature cfg package)))))))) (generate-signature cfg package))))))))
(remote-command cfg "/pkg/put" (list pkg sig)))) (remote-command cfg '(command package uri) "/pkg/put" (list pkg sig))))
(define (command/upload cfg spec . o) (define (command/upload cfg spec . o)
(define (non-homogeneous) (define (non-homogeneous)
@ -743,7 +746,7 @@
(local-path (make-path local-dir "repo.scm")) (local-path (make-path local-dir "repo.scm"))
(local-tmp (string-append local-path ".tmp." (local-tmp (string-append local-path ".tmp."
(number->string (current-second)))) (number->string (current-second))))
(repo-uri (remote-uri cfg "/s/repo.scm")) (repo-uri (remote-uri cfg 'repository-uri "/s/repo.scm"))
(repo-str (call-with-input-url repo-uri port->string)) (repo-str (call-with-input-url repo-uri port->string))
(repo (guard (exn (else #f)) (repo (guard (exn (else #f))
(let ((repo (read (open-input-string repo-str)))) (let ((repo (read (open-input-string repo-str))))

8
tools/snow-chibi
View file

@ -58,6 +58,7 @@
(always-yes? boolean (#\y "always-yes") "answer all questions with yes") (always-yes? boolean (#\y "always-yes") "answer all questions with yes")
;;(config filename "path to configuration file") ;;(config filename "path to configuration file")
(host string "base uri of snow repository") (host string "base uri of snow repository")
(repository-uri string "uri of snow repository file")
(local-root-repository dirname "repository cache dir for root") (local-root-repository dirname "repository cache dir for root")
(local-user-repository dirname "repository cache dir for non-root users") (local-user-repository dirname "repository cache dir for non-root users")
(install-prefix string "prefix directory for installation") (install-prefix string "prefix directory for installation")
@ -85,7 +86,8 @@
(library-prefix (list symbol)) (library-prefix (list symbol))
(email string))) (email string)))
(define reg-key-spec (define reg-key-spec
'((email string))) '((uri string)
(email string)))
(define sign-spec (define sign-spec
'((output filename #\o) '((output filename #\o)
(digest symbol #\d) (digest symbol #\d)
@ -99,11 +101,13 @@
(version-file existing-filename) (version-file existing-filename)
(doc existing-filename) (doc existing-filename)
(doc-from-scribble boolean) (doc-from-scribble boolean)
(description string)
(test existing-filename) (test existing-filename)
(sig-file existing-filename) (sig-file existing-filename)
)) ))
(define upload-spec (define upload-spec
package-spec) `((uri string)
,@package-spec))
(define update-spec (define update-spec
'()) '())