From 0bc80beb699000826b8e9415a7b254c92dc86a5a Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Wed, 24 Jan 2024 16:57:56 +0200 Subject: Do things --- build.sh | 31 +++-- desmo-apply.scm | 54 --------- desmo-logs.scm | 7 -- desmo-status.scm | 7 -- desmoctl.scm | 282 +++++++++++++++++++++++++++++++++------------- examples/apply-config | 5 + examples/desmo-config.scm | 19 ---- examples/desmorc | 1 + init.scm | 6 - modules.list | 4 - run.scm | 2 +- utils.scm | 15 --- 12 files changed, 232 insertions(+), 201 deletions(-) delete mode 100644 desmo-apply.scm delete mode 100644 desmo-logs.scm delete mode 100644 desmo-status.scm create mode 100644 examples/apply-config delete mode 100644 examples/desmo-config.scm create mode 100644 examples/desmorc delete mode 100644 init.scm delete mode 100644 modules.list delete mode 100644 utils.scm 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 initial-opts - '((cfg-path "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 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 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" "foo.conf")))))) + +;; Evaluate subcommand + +(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)))])) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parse & eval "apply" subcommand ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define apply-usage-string + (format (string-append + "Usage: desmoctl apply [-f path] SUBCOMMAND~%" + "~%" + "Apply the config at PATH.~%" + "~%" + "Subcommands:~%" + " help Show this help text" + ))) + +(define (parse-apply-flags args) + (match args + [("-f" path) + `(parse-ok ((apply-config-path ,path)))] [("help") - '(parse-ok cmd-help ())] - [_ `(parse-error ,usage-string)])) + `(parse-ok subcmd-apply-help)] + [_ + `(parse-error ,apply-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-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 '()))))) + +(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])) -(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)]) +(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 cli-opts (cadr top-level-flags-parse-result)) -(define cli-subcommand-args (caddr top-level-flags-parse-result)) +(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 (format "debug: cli-opts: ~A" cli-opts)) -;; (print (format "debug: cli-subcommand-args: ~A" cli-subcommand-args)) + (print "apply cfg:") + (pretty-print apply-config-content) -(define subcommand-parse-result (parse-subcommand cli-subcommand-args)) + (print "TODO run-apply")) -(cond - [(eq? (car subcommand-parse-result) 'parse-error) - (print (cadr subcommand-parse-result)) - (exit 1)]) +;;;;;;;;;;;;;;;;; +;; Run the CLI ;; +;;;;;;;;;;;;;;;;; -(define cli-subcommand (cadr subcommand-parse-result)) -(define cli-opts (append (caddr subcommand-parse-result) cli-opts)) +(define (run-desmoctl) + (define top-level-flags-parse-result + (parse-top-level-flags default-cfg + (command-line-arguments))) -;; (print (format "debug: cli-subcommand: ~A" cli-subcommand)) -;; (print (format "debug: cli-opts: ~A" cli-opts)) + (assert-parse-or-exit top-level-flags-parse-result) -; read in config + (define cfg-with-flags + (cadr top-level-flags-parse-result)) -(define cfg-content - (read (open-input-file (cadr (assoc 'cfg-path cli-opts))))) + (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: cfg-content") -(pretty-print cfg-content) + (print "debug: user-cfg") + (pretty-print user-cfg) -; evaluate parsed command + (define subcommand-parse-result + (parse-subcommand (caddr top-level-flags-parse-result))) -(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)))])) + (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 ...)))))) - -- cgit v1.3