diff options
| -rw-r--r-- | README.md | 4 | ||||
| -rw-r--r-- | desmoctl.scm | 281 | ||||
| -rw-r--r-- | examples/apply-config-eval | 7 | ||||
| -rw-r--r-- | examples/build-manifest | 9 | ||||
| -rw-r--r-- | examples/desmorc | 4 |
5 files changed, 244 insertions, 61 deletions
@@ -10,6 +10,10 @@ Install dependencies: chicken-install -from-list requirements.list +In addition to Chicken dependencies, you need to have these available in PATH: + + tar + ## Building and running Run the tool in the interpreter: diff --git a/desmoctl.scm b/desmoctl.scm index 42a8c1f..cbc4cea 100644 --- a/desmoctl.scm +++ b/desmoctl.scm @@ -13,6 +13,7 @@ http-client intarweb uri-common + shell ) ;;;;;;;;;;;;;;; @@ -56,17 +57,33 @@ (with-exception-handler (lambda (e) (k (catcher e))) fn)))) +(inline-tests + (test-group "try-catch" + (test "returns fn return value when no exn thrown" 'done + (try-catch (lambda (e) 'caught) (lambda () 'done))) + (test "returns catcher return value when exn thrown" 'caught + (try-catch (lambda (e) 'caught) (lambda () (car '())))))) + (define default-cfg `((user-cfg-path - ,(string-append (get-environment-variable "HOME") "/" ".desmorc")) + . ,(string-append (get-environment-variable "HOME") "/" ".desmorc")) (mgmt-api-url - "http://localhost:9939") - (mgmt-api-key ""))) + . "http://localhost:9939") + (mgmt-api-key + . "") + )) (define (is-flag-like? args) (let ([first-char (string-ref (car args) 0)]) (eq? #\- first-char))) +(inline-tests + (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"))))) + (define (assert-parse-or-exit result) (if (eq? (car result) 'parse-error) (begin (print (cadr result)) @@ -76,9 +93,27 @@ (define (to-json-string datum) (with-output-to-string (lambda () (write-json datum)))) +(inline-tests + (test-group "to-json-string" + (test "transforms alist to json object" "{\"a\":123}" + (to-json-string '((a . 123)))) + (test "transforms vector to json array" "[1,2,3]" + (to-json-string #(1 2 3))) + (test "transforms bool to json bool" "true" + (to-json-string #t)))) + (define (from-json-string json) (read-json json)) +(inline-tests + (test-group "from-json-string" + (test "transforms json object to alist" '((a . 123)) + (from-json-string "{\"a\":123}")) + (test "transforms json array to vector" #(1 2 3) + (from-json-string "[1,2,3]")) + (test "transforms json bool to bool" #(#t) + (from-json-string "[true]")))) + (define (alist-keys alist) (map (lambda (elem) (symbol->string (car elem))) alist)) @@ -87,6 +122,11 @@ "" (string-append s (string-repeat s (- n 1))))) +(inline-tests + (test-group "string-repeat" + (test "should return repeated string" "foofoofoo" + (string-repeat "foo" 3)))) + (define (pretty-print-alists alists) (define (pp alist) (define (pp-pair pair) @@ -99,39 +139,28 @@ "No data" (for-each pp alists))) +(define (string-empty? s) + (= (string-length s) 0)) + (inline-tests - (test-group "utils" - (test-group "try-catch" - (test "returns fn return value when no exn thrown" 'done - (try-catch (lambda (e) 'caught) (lambda () 'done))) - (test "returns catcher return value when exn thrown" 'caught - (try-catch (lambda (e) 'caught) (lambda () (car '()))))) - - (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")))) - - (test-group "to-json-string" - (test "transforms alist to json object" "{\"a\":123}" - (to-json-string '((a . 123)))) - (test "transforms vector to json array" "[1,2,3]" - (to-json-string #(1 2 3))) - (test "transforms bool to json bool" "true" - (to-json-string #t))) - - (test-group "from-json-string" - (test "transforms json object to alist" '((a . 123)) - (from-json-string "{\"a\":123}")) - (test "transforms json array to vector" #(1 2 3) - (from-json-string "[1,2,3]")) - (test "transforms json bool to bool" #(#t) - (from-json-string "[true]"))) + (test-group "string-empty?" + (test "should return true for empty string" #t + (string-empty? "")) + (test "should return false for non-empty string" #f + (string-empty? "foobar")))) - (test-group "string-repeat" - (test "should return repeated string" "foofoofoo" - (string-repeat "foo" 3))))) +(define (shell-command-capture cmd) + (match (capture ,cmd) + [#!eof '(shell-err eof)] + [(? string-empty?) '(shell-err empty)] + [other `(shell-ok ,other)])) + +(inline-tests + (test-group "shell-command-capture" + (test "successful command should return shell-ok" '(shell-ok "123\n") + (shell-command-capture "echo 123")) + (test "failing command should return shell-err" 'shell-err + (car (shell-command-capture "cmd-does-not-exist"))))) ;;;;;;;;;;;;;;;;; ;; API adapter ;; @@ -160,14 +189,14 @@ #f read-string)) (define (post-prison post-fn cfg prison-json) - (let* ((api-url (cadr (assoc 'mgmt-api-url cfg))) - (api-key (cadr (assoc 'mgmt-api-key cfg))) + (let* ((api-url (cdr (assoc 'mgmt-api-url cfg))) + (api-key (cdr (assoc 'mgmt-api-key cfg))) (req-url (string-append api-url "/prisons"))) (post-fn req-url api-key prison-json))) (define (get-prisons get-fn cfg) - (let* ((api-url (cadr (assoc 'mgmt-api-url cfg))) - (api-key (cadr (assoc 'mgmt-api-key cfg))) + (let* ((api-url (cdr (assoc 'mgmt-api-url cfg))) + (api-key (cdr (assoc 'mgmt-api-key cfg))) (req-url (string-append api-url "/prisons"))) (get-fn req-url api-key))) @@ -176,12 +205,12 @@ (test-group "get-prisons" (test "should create correct query" '("http://example.com/prisons" "bar") (get-prisons mock-get-fn - '((mgmt-api-url "http://example.com") (mgmt-api-key "bar"))))) + '((mgmt-api-url . "http://example.com") (mgmt-api-key . "bar"))))) (test-group "post-prison" (test "should create correct query" '("http://example.com/prisons" "bar" "{\"a\":\"b\"}") (post-prison mock-post-fn - '((mgmt-api-url "http://example.com") (mgmt-api-key "bar")) + '((mgmt-api-url . "http://example.com") (mgmt-api-key . "bar")) "{\"a\":\"b\"}"))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -190,14 +219,21 @@ (define apply-usage-string (format (string-append - "Usage: desmoctl apply [-f path] SUBCOMMAND~%" + "Usage: desmoctl apply [-f|-F path] SUBCOMMAND~%" "~%" "Apply the config at PATH.~%" + "Flags:~%" + " -f path Path to the prison config~%" + " -F path Path to a Scheme program that evaluates to the prison config-%." "~%" "Subcommands:~%" " help Show this help text" ))) +(define default-apply-cfg + '((apply-config-eval + . #f))) + (define (parse-apply-flags opts args) "Returns an alist of opts" (match args @@ -206,7 +242,11 @@ `(parse-error ,apply-usage-string) `(parse-ok ,opts))] [("-f" path . rest) - (parse-apply-flags (cons `(apply-config-path ,path) opts) + (parse-apply-flags (cons `(apply-config-path . ,path) opts) + rest)] + [("-F" path . rest) + (parse-apply-flags (append `((apply-config-path . ,path) + (apply-config-eval . #t)) opts) rest)] [(? is-flag-like?) `(parse-error ,apply-usage-string)] @@ -215,12 +255,12 @@ [_ `(parse-error ,apply-usage-string)])) -(define (parse-subcommand-apply args) - (match (parse-apply-flags '() args) +(define (parse-subcommand-apply apply-cfg args) + (match (parse-apply-flags apply-cfg args) [('parse-ok 'subcmd-apply-help) `(parse-ok subcmd-apply-help ())] - [('parse-ok . rest) - `(parse-ok subcmd-apply ,(car rest))] + [('parse-ok opts) + `(parse-ok subcmd-apply ,opts)] [other other])) @@ -237,26 +277,35 @@ (car (parse-apply-flags '() '())))) (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")))))) + (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") + (apply-config-eval . #t))) + (parse-subcommand-apply '() '("-F" "foo.txt")))))) (define (run-apply cfg) - (define apply-config-content - (let* ((path (cadr (assoc 'apply-config-path cfg))) + (define content-raw + (let* ((path (or (cdr (assoc 'apply-config-path cfg)) + (begin (print "Error: no path to apply config supplied") + (exit 1)))) (catcher (lambda (e) - (print (format "Error: no user config found at ~A" path)) + (print (format "Error: no apply config found at ~A" path)) (exit 1))) (open-apply-cfg (lambda () (read (open-input-file path))))) (try-catch catcher open-apply-cfg))) + (define content (if (cdr (assoc 'apply-config-eval cfg)) + (eval content-raw) + content-raw)) + (if *debug?* (begin (debug-print "apply cfg:") - (pretty-print apply-config-content))) + (pretty-print content))) - (define apply-lst (vector->list apply-config-content)) + (define apply-lst (vector->list content)) (print (format "Applying all defined prisons (~A)..." (length apply-lst))) @@ -297,6 +346,117 @@ (pretty-print-alists prisons)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Parse and eval "build" subcommand ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define default-build-cfg + '((build-manifest-path + . "desmo.manifest") + (build-manifest-eval + . #f) + (build-archive-path + . "desmo_archive.txz"))) + +(define build-usage-string + (format (string-append + "Usage: desmoctl build [-f|-F path] [-o path] SUBCOMMAND~%" + "~%" + "Build a desmo workload archive according to the build manifest.~%" + "~%" + "Flags:~%" + " -f path Path to the build manifest~%" + " -F path Path to a Scheme program that evaluates to the build manifest-%" + " -o path Output archive path" + "~%" + "Subcommands:~%" + " help Show this help text" + ))) + +(define (parse-build-flags opts args) + "Returns an alist of opts" + (match args + [() + (if (null? opts) + `(parse-error ,build-usage-string) + `(parse-ok ,opts))] + [("-f" path . rest) + (parse-build-flags (cons `(build-manifest-path . ,path) opts) + rest)] + [("-F" path . rest) + (parse-build-flags (append `((build-manifest-eval . ,path) + (build-manifest-eval . #t)) opts) + rest)] + [("-o" path . rest) + (parse-build-flags (cons `(build-archive-path . ,path) opts) + rest)] + [(? is-flag-like?) + `(parse-error ,build-usage-string)] + [("help") + `(parse-ok subcmd-build-help)] + [_ + `(parse-error ,build-usage-string)])) + +(define (parse-subcommand-build build-cfg args) + (match (parse-build-flags build-cfg args) + [('parse-ok 'subcmd-build-help) + `(parse-ok subcmd-build-help ())] + [('parse-ok opts) + `(parse-ok subcmd-build ,opts)] + [other + other])) + +(define (run-build cfg) + (print "Reading build manifest...") + + (define manifest-path + (cdr (or (assoc 'build-manifest-path cfg) + (begin (print "Error: no path to build manifest supplied") + (exit 1))))) + + (define content-raw + (let* ((catcher (lambda (e) + (print (format "Error: no build manifest found at ~A" manifest-path)) + (exit 1))) + (open-build-manifest (lambda () (read (open-input-file manifest-path))))) + (try-catch catcher open-build-manifest))) + + (define content (if (cdr (assoc 'build-manifest-eval cfg)) + (eval content-raw) + content-raw)) + + (if *debug?* + (begin (debug-print "manifest content:") + (pretty-print content))) + + (define files-list + (let ((pair (assoc 'files content))) + (if pair + (vector->list (cdr pair)) + '()))) + + (define manifest-json + (to-json-string content)) + + (debug-print (format "manifest-json: ~A" manifest-json)) + + (define archive-path (cdr (assoc 'build-archive-path cfg))) + + (define tar-cmd + (apply string-append "2>&1 tar cvf " archive-path " " manifest-path " " files-list)) + + (debug-print "tar-cmd:") + (debug-print tar-cmd) + + (print (format "Building archive ~A..." archive-path)) + + (define tar-output (shell-command-capture tar-cmd)) + + (match (car tar-output) + ['shell-ok (print (format "Archive ~A built." archive-path))] + [other (print (format "Failed to build archive ~A." archive-path)) + (exit 1)])) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Parse flags and subcommand ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -336,12 +496,12 @@ (define (parse-subcommand args) (match args - [("build") - '(parse-ok subcmd-build ())] + [("build" . rest) + (parse-subcommand-build default-build-cfg rest)] [("push") '(parse-ok subcmd-push ())] [("apply" . rest) - (parse-subcommand-apply rest)] + (parse-subcommand-apply default-apply-cfg rest)] [("status") '(parse-ok subcmd-status ())] [("logs") @@ -373,6 +533,9 @@ (define (eval-subcommand subcmd cfg) (match subcmd + ['subcmd-build (run-build cfg)] + ['subcmd-push (print "TODO push") + (exit 1)] ['subcmd-apply (run-apply cfg)] ['subcmd-status (run-status cfg)] ['subcmd-logs (print "TODO logs") @@ -399,7 +562,7 @@ (cadr top-level-flags-parse-result)) (define user-cfg - (let* ((path (cadr (assoc 'user-cfg-path cfg-with-flags))) + (let* ((path (cdr (assoc 'user-cfg-path cfg-with-flags))) (catcher (lambda (e) (print (format "Note: no user config found at ~A" path)) '())) diff --git a/examples/apply-config-eval b/examples/apply-config-eval new file mode 100644 index 0000000..80678cb --- /dev/null +++ b/examples/apply-config-eval @@ -0,0 +1,7 @@ +(let ((replicas 9)) + + `#(((name . "foobar") + (base . "14.0-RELEASE-base") + (packages . #()) + (commands . #()) + (replicas . ,(+ 1 replicas))))) diff --git a/examples/build-manifest b/examples/build-manifest new file mode 100644 index 0000000..d0c0e56 --- /dev/null +++ b/examples/build-manifest @@ -0,0 +1,9 @@ +((packages + . #("nginx")) + (files + . #("nginx.conf")) + (build-commands + . #("sysrc nginx_enable=YES")) + (start-command + . "nginx -c nginx.conf")) + diff --git a/examples/desmorc b/examples/desmorc index 53ff809..9841c81 100644 --- a/examples/desmorc +++ b/examples/desmorc @@ -1,2 +1,2 @@ -((mgmt-api-url "http://localhost:9939") - (mgmt-api-key "foobar")) +((mgmt-api-url . "http://localhost:9939") + (mgmt-api-key . "foobar")) |