diff options
| -rw-r--r-- | desmo-apply.scm | 55 | ||||
| -rw-r--r-- | desmo-logs.scm | 2 | ||||
| -rw-r--r-- | desmo-status.scm | 2 | ||||
| -rw-r--r-- | desmoctl.scm | 31 | ||||
| -rw-r--r-- | examples/desmo-config.scm | 19 | ||||
| -rw-r--r-- | modules.list | 1 | ||||
| -rw-r--r-- | requirements.list | 3 | ||||
| -rw-r--r-- | utils.scm | 14 |
8 files changed, 105 insertions, 22 deletions
diff --git a/desmo-apply.scm b/desmo-apply.scm index 0eed930..24ae760 100644 --- a/desmo-apply.scm +++ b/desmo-apply.scm @@ -1,7 +1,54 @@ (module desmo-apply (run-apply) (import scheme - (chicken base)) - (define (run-apply opts) - (print "TODO") - 'todo)) + (chicken base) + shell + test + utils) + + (define (run-apply cfg) + (let* ((cluster (assoc 'cluster cfg)) + (nodes (cdr cluster))) + + (map gather-node-facts nodes) + + (print "TODO") + 'todo)) + + (define (get-ssh-command node) + (let* ((alist (cdr node)) + (ssh-user-pair (assoc 'ssh-user alist)) + (ssh-hostname-pair (assoc 'ssh-hostname alist)) + (ssh-command-pair (assoc 'ssh-command alist))) + (cond ((not ssh-user-pair) + '(cfg-error "ssh-user not specified")) + ((not ssh-hostname-pair) + '(cfg-error "ssh-hostname not specified")) + ((not ssh-command-pair) + '(cfg-error "ssh-command not specified")) + (else + (string-append (cadr ssh-command-pair) + " " + (cadr ssh-user-pair) + "@" + (cadr ssh-hostname-pair)))))) + + (inline-tests + (test-group + "get-ssh-command" + (test "returns error if ssh-user not specified" 'cfg-error + (car (get-ssh-command '(node (ssh-hostname "foo") (ssh-command "bar"))))) + (test "returns error if ssh-hostname not specified" 'cfg-error + (car (get-ssh-command '(node (ssh-user "foo") (ssh-command "bar"))))) + (test "returns error if ssh-command not specified" 'cfg-error + (car (get-ssh-command '(node (ssh-user "foo") (ssh-hostname "bar"))))) + (test "returns ssh command if all specified" "ssh foo@bar" + (get-ssh-command '(node (ssh-user "foo") (ssh-hostname "bar") (ssh-command "ssh")))))) + + (define (gather-node-facts node) + (let* ((ssh-command (get-ssh-command node)) + (jls-command "jls") + (combined (string-append ssh-command " " jls-command)) + (result (capture ,combined))) + ; TODO parse result + (not (equal? result #!eof))))) diff --git a/desmo-logs.scm b/desmo-logs.scm index 46a3133..880bada 100644 --- a/desmo-logs.scm +++ b/desmo-logs.scm @@ -1,7 +1,7 @@ (module desmo-logs (run-logs) (import scheme (chicken base)) - (define (run-logs opts) + (define (run-logs cfg) (print "TODO") 'todo)) diff --git a/desmo-status.scm b/desmo-status.scm index 47faa94..6dbeb40 100644 --- a/desmo-status.scm +++ b/desmo-status.scm @@ -1,7 +1,7 @@ (module desmo-status (run-status) (import scheme (chicken base)) - (define (run-status opts) + (define (run-status cfg) (print "TODO") 'todo)) diff --git a/desmoctl.scm b/desmoctl.scm index 792ef69..5fc5bb3 100644 --- a/desmoctl.scm +++ b/desmoctl.scm @@ -2,24 +2,15 @@ (chicken base) (chicken process-context) (chicken format) + (chicken pretty-print) matchable test + utils desmo-apply desmo-status desmo-logs ) -(define should-run-inline-tests? - (let ((v (get-environment-variable "INLINE_TESTS"))) - (and (string? v) - (string=? v "1")))) - -(define-syntax inline-tests - (syntax-rules () - ((_ expr ...) - (if should-run-inline-tests? - (begin expr ...))))) - ; CLI arg parser (define usage-string @@ -113,15 +104,23 @@ ;; (print (format "debug: cli-subcommand: ~A" cli-subcommand)) ;; (print (format "debug: cli-opts: ~A" cli-opts)) +; read in config + +(define cfg-content + (read (open-input-file (cadr (assoc 'cfg-path cli-opts))))) + +(print "debug: cfg-content") +(pretty-print cfg-content) + ; evaluate parsed command -(define (eval-subcommand subcmd opts) +(define (eval-subcommand subcmd cfg) (match subcmd - ['cmd-apply (run-apply opts)] - ['cmd-status (run-status opts)] - ['cmd-logs (run-logs opts)] + ['cmd-apply (run-apply cfg)] + ['cmd-status (run-status cfg)] + ['cmd-logs (run-logs cfg)] ['cmd-help (print usage-string) 'done] [other (print `(eval-error ,(format "invalid subcommand: ~A" other)))])) -(eval-subcommand cli-subcommand cli-opts) +(eval-subcommand cli-subcommand cfg-content) diff --git a/examples/desmo-config.scm b/examples/desmo-config.scm new file mode 100644 index 0000000..5ca34ca --- /dev/null +++ b/examples/desmo-config.scm @@ -0,0 +1,19 @@ +((cluster + (node (name "node1") + (tags "tag1") + (ssh-hostname "2001:db8:0:1::1") + (ssh-user "root") + (ssh-command "ssh -i ~/.ssh/desmo_rsa -o StrictHostKeyChecking=no -o UserKnownHostsFile=/dev/null")) + (node (name "node2") + (ssh-user "root") + (ssh-hostname "2001:db8:0:1::2") + (ssh-command "ssh -i ~/.ssh/desmo_rsa -o StrictHostKeyChecking=no -o UserKnownHostsFile=/dev/null")) + (node (name "node3") + (ssh-user "root") + (ssh-hostname "2001:db8:0:1::3") + (ssh-command "ssh -i ~/.ssh/desmo_rsa -o StrictHostKeyChecking=no -o UserKnownHostsFile=/dev/null"))) + (service (name "service1") + (port 80) + (protocol "tcp") + (requires-tag "tag1"))) + diff --git a/modules.list b/modules.list index 3b22352..a5a47e7 100644 --- a/modules.list +++ b/modules.list @@ -1,3 +1,4 @@ +utils desmo-status desmo-logs desmo-apply
\ No newline at end of file diff --git a/requirements.list b/requirements.list new file mode 100644 index 0000000..ab31915 --- /dev/null +++ b/requirements.list @@ -0,0 +1,3 @@ +(test "1.2") +(matchable "1.1") +(shell "0.4") diff --git a/utils.scm b/utils.scm new file mode 100644 index 0000000..a131717 --- /dev/null +++ b/utils.scm @@ -0,0 +1,14 @@ +(module utils (inline-tests) + (import scheme + (chicken base) + (chicken process-context)) + + (define-syntax inline-tests + (syntax-rules () + ((_ expr ...) + (let* ((v (get-environment-variable "INLINE_TESTS")) + (should-run-inline-tests? (and (string? v) + (string=? v "1")))) + (if should-run-inline-tests? + (begin expr ...))))))) + |