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

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)
(cond
((conf-get cfg '(command package description)))
((conf-get cfg '(command upload description)))
;; Crazy hack, make this more robust, probably opt-in.
((and (pair? docs) (pair? (car docs)) (eq? 'inline (caar docs))
(regexp-search
@ -473,12 +474,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Reg-key - register an RSA key pair with a repository.
(define (remote-uri cfg path)
(make-path (or (conf-get cfg 'host) "http://snow-fort.org")
path))
(define (remote-uri cfg name path)
(or (conf-get cfg name)
(make-path (or (conf-get cfg 'host) "http://snow-fort.org")
path)))
(define (remote-command cfg path params)
(let ((uri (remote-uri cfg path)))
(define (remote-command cfg name path params)
(let ((uri (remote-uri cfg name path)))
(sxml-display-as-text (read (http-post uri (cons '(fmt . "sexp") params))))
(newline)))
@ -496,6 +498,7 @@
(rsa-pub-key-str
(write-to-string (rsa-key->sexp rsa-pub-key name email))))
(remote-command cfg
'(command reg-key uri)
"/pkg/reg"
`((u (file . "pub-key.scm")
(value . ,rsa-pub-key-str))))))
@ -579,7 +582,7 @@
`(sig (file . "package.sig")
(value . ,(write-to-string
(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 (non-homogeneous)
@ -743,7 +746,7 @@
(local-path (make-path local-dir "repo.scm"))
(local-tmp (string-append local-path ".tmp."
(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 (guard (exn (else #f))
(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")
;;(config filename "path to configuration file")
(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-user-repository dirname "repository cache dir for non-root users")
(install-prefix string "prefix directory for installation")
@ -85,7 +86,8 @@
(library-prefix (list symbol))
(email string)))
(define reg-key-spec
'((email string)))
'((uri string)
(email string)))
(define sign-spec
'((output filename #\o)
(digest symbol #\d)
@ -99,11 +101,13 @@
(version-file existing-filename)
(doc existing-filename)
(doc-from-scribble boolean)
(description string)
(test existing-filename)
(sig-file existing-filename)
))
(define upload-spec
package-spec)
`((uri string)
,@package-spec))
(define update-spec
'())