Add http POST /prisons

5 files changed, 182 insertions, 84 deletions

diff --git a/README.md b/README.md
index ae0203f..1257f5f 100644
--- a/README.md
+++ b/README.md
@@ -6,10 +6,17 @@ A tool for controlling a desmofylakas cluster written in Chicken Scheme.
 
 Install [Chicken Scheme](https://wiki.call-cc.org/platforms).
 
+Install dependencies:
+
+    chicken-install -from-list requirements.list
+
+## Building and running
+
 Run the tool in the interpreter:
 
-    INLINE_TESTS=1 csi -s run.scm  # with tests
-    csi -s run.scm                 # without tests
+    # Set DEBUG=1 to show debug prints
+    # Set INLINE_TESTS=1 to run unit tests before execution
+    csi -s run.scm
 
 Compile a statically linked binary for production:
 
@@ -25,4 +32,4 @@ When adding new modules, add the module names to `modules.list`. The defined mod
 
 ## Copyright
 
-© Desmofylakas Core Team 2024
\ No newline at end of file
+© Desmofylakas Core Team 2024
diff --git a/desmoctl.scm b/desmoctl.scm
index 123f5b0..b9302da 100644
--- a/desmoctl.scm
+++ b/desmoctl.scm
@@ -4,8 +4,14 @@
         (chicken format)
         (chicken pretty-print)
 	(chicken condition)
+	(chicken port)
+	(chicken io)
+	medea
         matchable
         test
+	http-client
+	intarweb
+	uri-common
         )
 
 ;;;;;;;;;;;;;;;
@@ -17,12 +23,22 @@
     (and (string? v)
 	 (string=? v "1"))))
 
+(define *debug?*
+  (let ((v (get-environment-variable "DEBUG")))
+    (and (string? v)
+	 (string=? v "1"))))
+
 (define-syntax inline-tests
   (syntax-rules ()
     ((_ expr ...)
      (if *should-run-inline-tests?*
 	 (begin expr ...)))))
 
+(define (debug-print text)
+  (if *debug?*
+      (print "debug: " text)
+      (void)))
+
 (define (try-catch catcher fn)
   "Tries (fn) and calls (catcher exn) if fn throws"
   (handle-exceptions exn (catcher exn) (fn)))
@@ -31,22 +47,148 @@
   `((user-cfg-path
      ,(string-append (get-environment-variable "HOME") "/" ".desmorc"))
     (mgmt-api-url
-     "http://localhost:9939")))
+     "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))
 	     (exit 1))
       #f))
 
+(define (to-json-string datum)
+  (with-output-to-string (lambda () (write-json datum))))
+
+(define (from-json-string json)
+  (read-json json))
+
 (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")))))
+ (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]"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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 subcmd-apply-help)]
+    [_
+     `(parse-error ,apply-usage-string)]))
+
+(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 '())))))
+
+(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]))
+
+(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 (mock-post-fn . rest)
+  (print (format "mock-post-fn called with: ~A" rest))
+  rest)
+
+(define (post-fn url api-key json)
+  (with-input-from-request
+   (make-request method: 'POST
+                 uri: (uri-reference url)
+		 headers: (headers `((x-api-key ,api-key))))
+   json 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)))
+	 (req-url (string-append api-url "/prisons")))
+    (post-fn req-url api-key prison-json)))
+
+(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)))
+
+  (if *debug?*
+      (begin 
+	(debug-print "apply cfg:")
+	(pretty-print apply-config-content)))
+
+  (define apply-lst (vector->list apply-config-content))
+
+  (print (format "Applying all defined prisons (~A)..." (length apply-lst)))
+  
+  (define (apply-prison prison)
+    (print (format "Applying prison \"~A\"..." (cdr (assoc 'name prison))))
+    
+    (define apply-json (to-json-string prison))
+    
+    (debug-print "apply json:")
+    (debug-print apply-json)
+
+    (define api-response
+      (post-prison post-fn cfg apply-json))
+
+    (debug-print "api-response:")
+    (debug-print (format "~A" api-response)))
+
+  (for-each apply-prison apply-lst)
+
+  (print "Apply complete"))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Parse flags and subcommand ;;
@@ -119,7 +261,7 @@
    (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"))))))
+         (car (parse-subcommand '("apply" "-f" "foo.conf"))))))
 
 ;; Evaluate subcommand
 
@@ -137,70 +279,6 @@
     [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 subcmd-apply-help)]
-    [_
-     `(parse-error ,apply-usage-string)]))
-
-(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 '())))))
-
-(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]))
-
-(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 (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 "apply cfg:")
-  (pretty-print apply-config-content)
-
-  (print "TODO run-apply"))
-
 ;;;;;;;;;;;;;;;;;
 ;; Run the CLI ;;
 ;;;;;;;;;;;;;;;;;
@@ -223,8 +301,10 @@
 	   (open-user-cfg (lambda () (read (open-input-file path)))))
       (try-catch catcher open-user-cfg)))
 
-  (print "debug: user-cfg")
-  (pretty-print user-cfg)
+  (if *debug?*
+      (begin
+	(debug-print "user-cfg:")
+	(pretty-print user-cfg)))
 
   (define subcommand-parse-result
     (parse-subcommand (caddr top-level-flags-parse-result)))
@@ -236,18 +316,24 @@
   (define subcommand-cfg
     (caddr subcommand-parse-result))
 
-  (print "debug: subcommand-cfg")
-  (pretty-print subcommand-cfg)
+  (if *debug?*
+      (begin 
+	(debug-print "subcommand-cfg:")
+	(pretty-print subcommand-cfg)))
 
   (define cfg (append subcommand-cfg
 		      user-cfg
 		      default-cfg))
 
-  (print "debug: cfg")
-  (pretty-print cfg)
+  (if *debug?*
+      (begin
+	(debug-print "cfg:")
+	(pretty-print cfg)))
 
   (eval-subcommand subcommand cfg))
 
+;; When compiled, run the CLI when executable is run
+;; Interpreter should load ./run.scm
 (cond-expand
   (compiling (run-desmoctl))
   (else))
diff --git a/examples/apply-config b/examples/apply-config
index 343fe81..408be12 100644
--- a/examples/apply-config
+++ b/examples/apply-config
@@ -1,5 +1,5 @@
-((prison (name "foobar")
-	 (base "14.0-RELEASE-base")
-	 (packages ())
-	 (commands ())
-	 (replicas 3)))
+#(((name . "foobar")
+   (base . "14.0-RELEASE-base")
+   (packages . #())
+   (commands . #())
+   (replicas . 3)))
diff --git a/examples/desmorc b/examples/desmorc
index 331a201..53ff809 100644
--- a/examples/desmorc
+++ b/examples/desmorc
@@ -1 +1,2 @@
-((mgmt-api-url "http://localhost:9939"))
+((mgmt-api-url "http://localhost:9939")
+ (mgmt-api-key "foobar"))
diff --git a/requirements.list b/requirements.list
index ab31915..f2e5de5 100644
--- a/requirements.list
+++ b/requirements.list
@@ -1,3 +1,7 @@
 (test "1.2")
 (matchable "1.1")
 (shell "0.4")
+(medea "4")
+(openssl "2.2.5")
+(intarweb "2.1.0")
+(uri-common "2.0")