diff options
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | desmo-apply.scm | 92 | ||||
| -rw-r--r-- | desmoctl.scm | 7 | ||||
| -rw-r--r-- | init.scm | 6 | ||||
| -rwxr-xr-x | run.scm | 6 | ||||
| -rw-r--r-- | utils.scm | 25 |
6 files changed, 73 insertions, 66 deletions
@@ -1 +1,2 @@ -build/
\ No newline at end of file +build/ +.DS_Store diff --git a/desmo-apply.scm b/desmo-apply.scm index 24ae760..b10cb08 100644 --- a/desmo-apply.scm +++ b/desmo-apply.scm @@ -1,54 +1,54 @@ (module desmo-apply (run-apply) - (import scheme - (chicken base) - shell - test - utils) + (import scheme + (chicken base) + shell + test + utils) - (define (run-apply cfg) - (let* ((cluster (assoc 'cluster cfg)) - (nodes (cdr cluster))) + (define (run-apply cfg) + (let* ((cluster (assoc 'cluster cfg)) + (nodes (cdr cluster))) - (map gather-node-facts nodes) + (map gather-node-facts nodes) - (print "TODO") - 'todo)) + (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)))))) + (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")))))) + (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))))) + (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/desmoctl.scm b/desmoctl.scm index 5fc5bb3..855625a 100644 --- a/desmoctl.scm +++ b/desmoctl.scm @@ -5,11 +5,12 @@ (chicken pretty-print) matchable test - utils + + utils desmo-apply desmo-status desmo-logs - ) + ) ; CLI arg parser @@ -60,6 +61,8 @@ (test "returns parse-ok for valid flag and subcommand" 'parse-ok (car (parse-top-level-flags initial-opts '("-f" "desmo.scm" "apply")))))) + + (define (parse-subcommand args) (match args [("apply") diff --git a/init.scm b/init.scm new file mode 100644 index 0000000..f9a69ee --- /dev/null +++ b/init.scm @@ -0,0 +1,6 @@ +;;; This file is intended to be loaded into csi + +(import (chicken io)) + +(let ((modules (read-lines (open-input-file "modules.list")))) + (for-each load modules)) @@ -1,9 +1,5 @@ #!/usr/bin/env csi -s -(import (chicken io)) - -(let ((modules (read-lines (open-input-file "modules.list")))) - (for-each load modules)) - +(load "init.scm") (load "desmoctl.scm") @@ -1,14 +1,15 @@ -(module utils (inline-tests) - (import scheme - (chicken base) - (chicken process-context)) +(module utils (*should-run-inline-tests?* inline-tests) + (import (scheme) + (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 ...))))))) + (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 ...)))))) |