Do things

12 files changed, 231 insertions, 200 deletions

diff --git a/build.sh b/build.sh
index 1f36c6f..0b865b0 100755
--- a/build.sh
+++ b/build.sh
@@ -1,18 +1,31 @@
 #!/bin/bash
 
-set -euxo pipefail
+# if the first flag is -h or --help, then show usage
+if [[ $1 == "-h" || $1 == "--help" ]]; then
+    echo "Usage: build.sh [OPTION]"
+    echo "Builds the desmoctl binary."
+    echo ""
+    echo "Options:"
+    echo "  -h, --help    Show this help message"
+    echo "  -d, --debug   Enable debugging"
+    exit 0
+fi
 
-CSC_FLAGS=-O3
 BUILD_DIR=build
 
-mkdir -p ${BUILD_DIR}
-cd ${BUILD_DIR}
+# if the first flag is --debug or -d, then set CHICKEN_DEBUGGER=localhost:9999 and add -d3 to CSC_FLAGS
+if [[ $1 == "--debug" || $1 == "-d" ]]; then
+    export CHICKEN_DEBUGGER=localhost:9999
+    export CSC_FLAGS="-d3"
+else
+    export CHICKEN_DEBUGGER=
+    export CSC_FLAGS=-O3
+fi
 
-modules=$(cat ../modules.list)
+set -euxo pipefail
 
-for mod in $modules; do
-    csc ${CSC_FLAGS} -c -static -J ../${mod}.scm -unit ${mod} -o ${mod}.o
-done
+mkdir -p ${BUILD_DIR}
+cd ${BUILD_DIR}
 
-csc ${CSC_FLAGS} -o desmoctl -static -uses desmo-apply ../desmoctl.scm
+csc ${CSC_FLAGS} -o desmoctl -static ../desmoctl.scm
 chmod +x desmoctl
diff --git a/desmo-apply.scm b/desmo-apply.scm
deleted file mode 100644
index b10cb08..0000000
--- a/desmo-apply.scm
+++ /dev/null
@@ -1,54 +0,0 @@
-(module desmo-apply (run-apply)
-	(import scheme
-		(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
deleted file mode 100644
index 880bada..0000000
--- a/desmo-logs.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-(module desmo-logs (run-logs)
-  (import scheme
-          (chicken base))
-  (define (run-logs cfg)
-    (print "TODO")
-    'todo))
-
diff --git a/desmo-status.scm b/desmo-status.scm
deleted file mode 100644
index 6dbeb40..0000000
--- a/desmo-status.scm
+++ /dev/null
@@ -1,7 +0,0 @@
-(module desmo-status (run-status)
-  (import scheme
-          (chicken base))
-  (define (run-status cfg)
-    (print "TODO")
-    'todo))
-
diff --git a/desmoctl.scm b/desmoctl.scm
index 855625a..123f5b0 100644
--- a/desmoctl.scm
+++ b/desmoctl.scm
@@ -3,47 +3,83 @@
         (chicken process-context)
         (chicken format)
         (chicken pretty-print)
+	(chicken condition)
         matchable
         test
+        )
 
-	utils
-        desmo-apply
-        desmo-status
-        desmo-logs
-	)
+;;;;;;;;;;;;;;;
+;; Utilities ;;
+;;;;;;;;;;;;;;;
 
-; CLI arg parser
+(define *should-run-inline-tests?*
+  (let ((v (get-environment-variable "INLINE_TESTS")))
+    (and (string? v)
+	 (string=? v "1"))))
 
-(define usage-string
-  (format (string-append
-            "Usage: desmoctl [-f cfg-path] SUBCOMMAND~%~%"
-            "Subcommands:~%"
-            "    apply          Apply the cluster config~%"
-            "    status         Show cluster status~%"
-            "    logs           Show cluster logs~%"
-            "    help           Show this help text~%~%"
-            "Top-level flags:~%"
-            "    -f cfg-path    Path to the cluster config file (default: desmo.scm)")))
+(define-syntax inline-tests
+  (syntax-rules ()
+    ((_ expr ...)
+     (if *should-run-inline-tests?*
+	 (begin expr ...)))))
+
+(define (try-catch catcher fn)
+  "Tries (fn) and calls (catcher exn) if fn throws"
+  (handle-exceptions exn (catcher exn) (fn)))
 
-(define initial-opts
-  '((cfg-path "desmo.scm")))
+(define default-cfg
+  `((user-cfg-path
+     ,(string-append (get-environment-variable "HOME") "/" ".desmorc"))
+    (mgmt-api-url
+     "http://localhost:9939")))
 
 (define (is-flag-like? args)
   (let ([first-char (string-ref (car args) 0)])
     (eq? #\- first-char)))
 
+(define (assert-parse-or-exit result)
+  (if (eq? (car result) 'parse-error)
+      (begin (print (cadr result))
+	     (exit 1))
+      #f))
+
 (inline-tests
-  (test-group "is-flag-like?"
-              (test "returns true for valid list" #t (is-flag-like? '("-f" "desmo.scm")))
-              (test "returns false for invalid list" #f (is-flag-like? '("apply")))))
+ (test-group "is-flag-like?"
+   (test "returns true for valid list" #t (is-flag-like? '("-c" "desmo.scm")))
+   (test "returns false for invalid list" #f (is-flag-like? '("apply")))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parse flags and subcommand ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define usage-string
+  (format (string-append
+           "Usage: desmoctl [-c cfg-path] SUBCOMMAND~%"
+           "~%"
+           "Flags:~%"
+           "    -c cfg-path    Path to your user config file (default: $HOME/.desmorc)~%"
+           "~%"
+           "Workload subcommands:~%"
+           "    build          Build a workload archive~%"
+           "    push           Push a workload archive~%"
+           "~%"
+           "Orchestration subcommands:~%"
+           "    apply          Apply prison config~%"
+           "    status         Show prison status~%"
+           "    logs           Show logs~%"
+           "    help           Show this help text~%"
+           "~%"
+           "Run \"desmoctl SUBCOMMAND help\" to see help for a subcommand."
+           )))
+
 
-;;; Returns a list of parsed options and the remaining arguments.
 (define (parse-top-level-flags opts args)
+  "Returns a list of parsed options and the remaining arguments."
   (match args
     [()
      `(parse-ok ,opts '())]
-    [("-f" cfg-path . rest)
-     (parse-top-level-flags (cons `(cfg-path ,cfg-path) opts)
+    [("-c" user-cfg-path . rest)
+     (parse-top-level-flags (cons `(user-cfg-path ,user-cfg-path) opts)
                             rest)]
     [(? is-flag-like?)
      `(parse-error ,usage-string)]
@@ -51,79 +87,167 @@
      `(parse-ok ,opts ,args)]))
 
 (inline-tests
-  (test-group "parse-top-level-flags"
-              (test "returns parse-error for invalid flag" 'parse-error
-                    (car (parse-top-level-flags initial-opts '("--invalid-flag"))))
-              (test "returns parse-ok for empty args" 'parse-ok
-                    (car (parse-top-level-flags initial-opts '())))
-              (test "returns parse-ok for valid flag" 'parse-ok
-                    (car (parse-top-level-flags initial-opts '("-f" "foobar.scm" "status"))))
-              (test "returns parse-ok for valid flag and subcommand" 'parse-ok
-                    (car (parse-top-level-flags initial-opts '("-f" "desmo.scm" "apply"))))))
-
-
+ (test-group "parse-top-level-flags"
+   (test "returns parse-error for invalid flag" 'parse-error
+         (car (parse-top-level-flags default-cfg '("--invalid-flag"))))
+   (test "returns parse-ok for empty args" 'parse-ok
+         (car (parse-top-level-flags default-cfg '())))
+   (test "returns parse-ok for valid flag" 'parse-ok
+         (car (parse-top-level-flags default-cfg '("-c" "foobar.scm" "status"))))
+   (test "returns parse-ok for valid flag and subcommand" 'parse-ok
+         (car (parse-top-level-flags default-cfg '("-c" "desmo.scm" "apply"))))))
 
 (define (parse-subcommand args)
   (match args
-    [("apply")
-     '(parse-ok cmd-apply ())]
+    [("build")
+     '(parse-ok subcmd-build ())]
+    [("push")
+     '(parse-ok subcmd-push ())]
+    [("apply" . rest)
+     (parse-subcommand-apply rest)]
     [("status")
-     '(parse-ok cmd-status ())]
+     '(parse-ok subcmd-status ())]
     [("logs")
-     '(parse-ok cmd-logs ())]
+     '(parse-ok subcmd-logs ())]
     [("help")
-     '(parse-ok cmd-help ())]
-    [_ `(parse-error ,usage-string)]))
+     '(parse-ok subcmd-help ())]
+    [_
+     `(parse-error ,usage-string)]))
 
 (inline-tests
-  (test-group "parse-subcommand"
-              (test "returns parse-error for invalid subcommand" 'parse-error
-                    (car (parse-subcommand '("invalid-subcommand"))))
-              (test "returns parse-ok for valid subcommand" 'parse-ok
-                    (car (parse-subcommand '("apply"))))))
+ (test-group "parse-subcommand"
+   (test "returns parse-error for invalid subcommand" 'parse-error
+         (car (parse-subcommand '("invalid-subcommand"))))
+   (test "returns parse-ok for valid subcommand" 'parse-ok
+         (car (parse-subcommand '("apply" "foo.conf"))))))
 
-(define top-level-flags-parse-result (parse-top-level-flags initial-opts (command-line-arguments)))
-(cond
-  [(eq? (car top-level-flags-parse-result) 'parse-error)
-   (print (cadr top-level-flags-parse-result))
-   (exit 1)])
+;; Evaluate subcommand
 
-(define cli-opts (cadr top-level-flags-parse-result))
-(define cli-subcommand-args (caddr top-level-flags-parse-result))
+(define (eval-subcommand subcmd cfg)
+  (match subcmd
+    ['subcmd-apply (run-apply cfg)]
+    ['subcmd-status (print "TODO status")
+		    (exit 1)]
+    ['subcmd-logs (print "TODO logs")
+		  (exit 1)]
+    ['subcmd-help
+     (print usage-string) 'done]
+    ['subcmd-apply-help
+     (print apply-usage-string) 'done]
+    [other
+     (print `(eval-error ,(format "invalid subcommand: ~A" other)))]))
 
-;; (print (format "debug: cli-opts: ~A" cli-opts))
-;; (print (format "debug: cli-subcommand-args: ~A" cli-subcommand-args))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Parse & eval "apply" subcommand ;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define subcommand-parse-result (parse-subcommand cli-subcommand-args))
+(define apply-usage-string
+  (format (string-append
+           "Usage: desmoctl apply [-f path] SUBCOMMAND~%"
+           "~%"
+           "Apply the config at PATH.~%"
+	   "~%"
+	   "Subcommands:~%"
+	   "    help           Show this help text"
+           )))
 
-(cond
-  [(eq? (car subcommand-parse-result) 'parse-error)
-   (print (cadr subcommand-parse-result))
-   (exit 1)])
+(define (parse-apply-flags args)
+  (match args
+    [("-f" path)
+     `(parse-ok ((apply-config-path ,path)))]
+    [("help")
+     `(parse-ok subcmd-apply-help)]
+    [_
+     `(parse-error ,apply-usage-string)]))
 
-(define cli-subcommand (cadr subcommand-parse-result))
-(define cli-opts (append (caddr subcommand-parse-result) cli-opts))
+(inline-tests
+ (test-group "parse-apply-flags"
+   (test "returns parse-ok for valid args (-f some-path)" 'parse-ok
+         (car (parse-apply-flags '("-f"  "some-path"))))
+   (test "returns parse-ok for valid args (help)" 'parse-ok
+         (car (parse-apply-flags '("help"))))
+   (test "returns parse-error for invalid args" 'parse-error
+	 (car (parse-apply-flags '("foo" "bar"))))
+   (test "returns parse-error for empty args" 'parse-error
+	 (car (parse-apply-flags '())))))
 
-;; (print (format "debug: cli-subcommand: ~A" cli-subcommand))
-;; (print (format "debug: cli-opts: ~A" cli-opts))
+(define (parse-subcommand-apply args)
+  (match (parse-apply-flags args)
+    [('parse-ok 'subcmd-apply-help)
+     `(parse-ok subcmd-apply-help ())]
+    [('parse-ok . rest)
+     `(parse-ok subcmd-apply ,(car rest))]
+    [other
+     other]))
 
-; read in config
+(inline-tests
+ (test-group "parse-subcommand-apply"
+   (test "returns parse-ok for help command" '(parse-ok subcmd-apply-help ())
+	 (parse-subcommand-apply '("help")))
+   (test "returns parse-ok for -f foo.txt" '(parse-ok subcmd-apply ((apply-config-path "foo.txt")))
+	 (parse-subcommand-apply '("-f" "foo.txt")))))
 
-(define cfg-content
-  (read (open-input-file (cadr (assoc 'cfg-path cli-opts)))))
+(define (run-apply cfg)
+  (define apply-config-content
+    (let* ((path (cadr (assoc 'apply-config-path cfg)))
+	   (catcher (lambda (e)
+		      (print (format "Error: no user config found at ~A" path))
+		      (exit 1)))
+	   (open-apply-cfg (lambda () (read (open-input-file path)))))
+      (try-catch catcher open-apply-cfg)))
 
-(print "debug: cfg-content")
-(pretty-print cfg-content)
+  (print "apply cfg:")
+  (pretty-print apply-config-content)
 
-; evaluate parsed command
+  (print "TODO run-apply"))
 
-(define (eval-subcommand subcmd cfg)
-  (match subcmd
-    ['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)))]))
+;;;;;;;;;;;;;;;;;
+;; Run the CLI ;;
+;;;;;;;;;;;;;;;;;
+
+(define (run-desmoctl)
+  (define top-level-flags-parse-result
+    (parse-top-level-flags default-cfg
+			   (command-line-arguments)))
+
+  (assert-parse-or-exit top-level-flags-parse-result)
+
+  (define cfg-with-flags
+    (cadr top-level-flags-parse-result))
+
+  (define user-cfg
+    (let* ((path (cadr (assoc 'user-cfg-path cfg-with-flags)))
+	   (catcher (lambda (e)
+		      (print (format "Note: no user config found at ~A" path))
+		      '()))
+	   (open-user-cfg (lambda () (read (open-input-file path)))))
+      (try-catch catcher open-user-cfg)))
+
+  (print "debug: user-cfg")
+  (pretty-print user-cfg)
+
+  (define subcommand-parse-result
+    (parse-subcommand (caddr top-level-flags-parse-result)))
+
+  (assert-parse-or-exit subcommand-parse-result)
+
+  (define subcommand
+    (cadr subcommand-parse-result))
+  (define subcommand-cfg
+    (caddr subcommand-parse-result))
+
+  (print "debug: subcommand-cfg")
+  (pretty-print subcommand-cfg)
+
+  (define cfg (append subcommand-cfg
+		      user-cfg
+		      default-cfg))
+
+  (print "debug: cfg")
+  (pretty-print cfg)
 
-(eval-subcommand cli-subcommand cfg-content)
+  (eval-subcommand subcommand cfg))
 
+(cond-expand
+  (compiling (run-desmoctl))
+  (else))
diff --git a/examples/apply-config b/examples/apply-config
new file mode 100644
index 0000000..343fe81
--- /dev/null
+++ b/examples/apply-config
@@ -0,0 +1,5 @@
+((prison (name "foobar")
+	 (base "14.0-RELEASE-base")
+	 (packages ())
+	 (commands ())
+	 (replicas 3)))
diff --git a/examples/desmo-config.scm b/examples/desmo-config.scm
deleted file mode 100644
index 5ca34ca..0000000
--- a/examples/desmo-config.scm
+++ /dev/null
@@ -1,19 +0,0 @@
-((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/examples/desmorc b/examples/desmorc
new file mode 100644
index 0000000..331a201
--- /dev/null
+++ b/examples/desmorc
@@ -0,0 +1 @@
+((mgmt-api-url "http://localhost:9939"))
diff --git a/init.scm b/init.scm
deleted file mode 100644
index f9a69ee..0000000
--- a/init.scm
+++ /dev/null
@@ -1,6 +0,0 @@
-;;; 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))
diff --git a/modules.list b/modules.list
deleted file mode 100644
index a5a47e7..0000000
--- a/modules.list
+++ /dev/null
@@ -1,4 +0,0 @@
-utils
-desmo-status
-desmo-logs
-desmo-apply
\ No newline at end of file
diff --git a/run.scm b/run.scm
index 16476da..e3093bc 100755
--- a/run.scm
+++ b/run.scm
@@ -1,5 +1,5 @@
 #!/usr/bin/env csi -s
 
-(load "init.scm")
 (load "desmoctl.scm")
+(run-desmoctl)
 
diff --git a/utils.scm b/utils.scm
deleted file mode 100644
index 4647c07..0000000
--- a/utils.scm
+++ /dev/null
@@ -1,15 +0,0 @@
-(module utils (*should-run-inline-tests?* inline-tests)
-	(import (scheme)
-		(chicken process-context))
-
-	(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 ...))))))
-