From d181f28c243395b6ffee3959224683cd4c4e7ef1 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Tue, 1 Jul 2014 22:23:47 +0900 Subject: [PATCH] Allowing --uri arguments for reg-key and upload. --- lib/chibi/snow/commands.scm | 17 ++++++++++------- tools/snow-chibi | 8 ++++++-- 2 files changed, 16 insertions(+), 9 deletions(-) diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index b8968b36..862d158a 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -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)))) diff --git a/tools/snow-chibi b/tools/snow-chibi index 58330d56..8385f48d 100755 --- a/tools/snow-chibi +++ b/tools/snow-chibi @@ -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 '())