Work on apply

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 ...)))))))
+