From 0bc80beb699000826b8e9415a7b254c92dc86a5a Mon Sep 17 00:00:00 2001 From: Jan Tuomi Date: Wed, 24 Jan 2024 16:57:56 +0200 Subject: Do things --- desmoctl.scm | 282 ++++++++++++++++++++++++++++++++++++++++++----------------- 1 file changed, 203 insertions(+), 79 deletions(-) (limited to 'desmoctl.scm') 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)) -- cgit v1.3