ensemble config tool, fix some bugz

src/std/actor-v18/ensemble-config.ss

@@ -13,6 +13,9 @@
 ;;; domain: <domain>
 ;;; ;;; [optional] root path for ensemble executions
 ;;; root: <path>
+;;; ;;; [optional] supervisor public address (over TLS)
+;;; public-address: <inet-address>
+;;;
 ;;; ;;; supervisory services
 ;;; services: (
 ;;;  ;;; supervisor config
@@ -206,6 +209,7 @@
     [config: 'ensemble-v0
      (merge-select old new domain:) ...
      (merge-select old new root:) ...
+     (merge-select old new public-address:) ...
      (merge-plist old new services:) ...
      (merge-alist old new roles:) ...
      (merge-plist old new preload:) ...

src/std/actor-v18/ensemble-supervisor.ss

@@ -32,7 +32,9 @@
       (create-directory* root/log))
     (parameterize ((current-log-directory (or root/log (ensemble-log-directory))))
       (let* ((cfg      (ensemble-config-merge
-                        (default-ensemble-config (config-get! cfg domain:))
+                        (default-ensemble-config
+                          (config-get! cfg domain:)
+                          (config-get  cfg public-address:))
                         cfg))
              (root     (: (config-get! cfg root:)     :string))
              (domain   (: (config-get! cfg domain:)   :symbol))
@@ -51,14 +53,14 @@
                 (wait-for-actor! 'supervisor)
                 (thunk)))))))))
 
-(def (default-ensemble-config domain)
+(def (default-ensemble-config domain (public-address #f))
   [config: 'ensemble-v0
            domain: domain
            root: (path-normalize (current-directory))
-           services: [supervisor: (default-ensemble-supervisor-config domain)
+           services: [supervisor: (default-ensemble-supervisor-config domain public-address)
                       registry:   (default-ensemble-registry-config domain)]])
 
-(def (default-ensemble-supervisor-config domain)
+(def (default-ensemble-supervisor-config domain (public-address #f))
   (parameterize ((ensemble-domain domain))
     (let ((supervisor-id (cons 'supervisor domain))
           (registry-id (cons 'registry domain)))
@@ -75,7 +77,10 @@
                log-level: 'INFO
                log-dir: (ensemble-server-log-directory supervisor-id)
                log-file: (ensemble-server-log-file supervisor-id "server.log")
-               addresses: [(ensemble-server-unix-addr supervisor-id)]
+               addresses: [(ensemble-server-unix-addr supervisor-id)
+                           (if public-address
+                             [[tls: public-address]]
+                             []) ...]
                known-servers: [[registry-id (ensemble-server-unix-addr registry-id)]]])))
 
 (def (default-ensemble-registry-config domain)

src/std/actor-v18/filesystem.ss

@@ -160,9 +160,12 @@
 
     (def (upload-finish key type blob-path deploy-path)
       (def (tar-expand base)
-        (let (expand-path (path-expand deploy-path base))
+        (let (expand-path
+              (if (string-empty? deploy-path)
+                base
+                (path-expand deploy-path base)))
           (create-directory* expand-path)
-          (invoke "tar" ["xzf" "-C" expand-path blob-path])))
+          (invoke "tar" ["xzf" blob-path] directory: expand-path)))
       (try
        (cond
         ((equal? type '(exe . gz))

src/std/actor-v18/supervisor.ss

@@ -147,7 +147,8 @@
             (ensemble-server-config-merge base-role-cfg role-server-cfg))))
 
       (def (get-server-config role domain server-id)
-        (let* ((server-id (server-identifier-at-domain server-id domain))
+        (let* ((domain (ensemble-subdomain domain))
+               (server-id (server-identifier-at-domain server-id domain))
                (base-cfg  (get-base-server-config server-id))
                (role-cfg  (get-role-server-config role server-id)))
           (ensemble-server-config-merge base-cfg role-cfg)))

src/tools/build.ss

@@ -14,6 +14,7 @@
     "gxensemble/admin"
     "gxensemble/env"
     "gxensemble/control"
+    "gxensemble/config"
     "gxensemble/ca"
     "gxensemble/list"
     "gxensemble/misc"

src/tools/env.ss

@@ -1,16 +1,27 @@
 ;;; -*- Gerbil -*-
 ;;; © vyzo
 ;;; common environment context for tools
-(import (only-in :std/cli/getopt flag))
+(import (only-in :std/cli/getopt flag option))
 (export #t)
 
 (def global-env-flag
   (flag 'global-env "-g" "--global-env"
         help: "use the user global env even in local package context"))
 
+(def gerbil-path-option
+  (option 'gerbil-path "-G" "--gerbil-path"
+    help: "specifies the GERBIL_PATH for ensemble operations"))
+
 (def (setup-local-env! opt)
-  (unless (hash-get opt 'global-env)
-    (setup-local-pkg-env! #f)))
+  (cond
+   ((hash-get opt 'gerbil-path)
+    => (lambda (path)
+         (unless (file-exists? path)
+           (create-directory* path))
+         (setenv "GERBIL_PATH" path)
+         (add-load-path! (path-expand "lib" path))))
+   ((not (hash-get opt 'global-env))
+    (setup-local-pkg-env! #f))))
 
 (def (setup-local-pkg-env! create?)
   (unless (getenv "GERBIL_PATH" #f)

src/tools/gxensemble.ss

@@ -13,6 +13,7 @@
     program: "gxensemble"
     help: "the Gerbil Actor Ensemble Manager"
     global-env-flag
+    gerbil-path-option
     supervisor-cmd
     registry-cmd
     run-cmd
@@ -27,7 +28,8 @@
     admin-cmd
     list-cmd
     ca-cmd
-    package-cmd))
+    package-cmd
+    config-cmd))
 
 (defrule (defcommand-table name body ...)
   (def name
@@ -49,7 +51,8 @@
   (shutdown         do-shutdown)
   (admin            do-admin)
   (ca               do-ca)
-  (package          do-package))
+  (package          do-package)
+  (config           do-config))
 
 (defcommand-table env-commands
   (known-servers do-env-known-servers)
@@ -92,6 +95,12 @@
   (setup   do-ca-setup)
   (cert    do-ca-cert))
 
+(defcommand-table config-commands
+  (ensemble do-config-ensemble)
+  (role     do-config-role)
+  (server   do-config-server)
+  (workers  do-config-workers))
+
 (defrule (dispatch-command cmd opt commands)
   (let (table (force commands))
     (cond
@@ -110,10 +119,6 @@
         program: name
         gopts ...))))
 
-(def (gxensemble-main cmd opt)
-  (setup-local-env! opt)
-  (dispatch-command cmd opt main-commands))
-
 (defcommand-nested do-admin admin-commands "gxensemble admin"
   admin-cookie-cmd
   admin-creds-cmd
@@ -146,6 +151,12 @@
   control-shutdown-cmd
   control-restart-cmd)
 
+(defcommand-nested do-config config-commands "gxensemble config"
+  config-ensemble-cmd
+  config-role-cmd
+  config-preload-server-cmd
+  config-preload-workers-cmd)
+
 (defcommand-nested do-list list-commands "gxensemble list"
   list-servers-cmd
   list-actors-cmd
@@ -154,3 +165,7 @@
 (defcommand-nested do-ca ca-commands "gxensemble ca"
   ca-setup-cmd
   ca-cert-cmd)
+
+(def (gxensemble-main cmd opt)
+  (setup-local-env! opt)
+  (dispatch-command cmd opt main-commands))

src/tools/gxensemble/cmd.ss

@@ -5,6 +5,7 @@
         ./admin
         ./env
         ./control
+        ./config
         ./ca
         ./list
         ./misc
@@ -14,6 +15,7 @@
   (import: ./admin
            ./env
            ./control
+           ./config
            ./ca
            ./list
            ./misc

src/tools/gxensemble/config.ss

@@ -0,0 +1,73 @@
+;;; -*- Gerbil -*-
+;;; © vyzo
+;;; actor ensemble management tool
+(import :std/config
+        :std/actor
+        :std/sugar
+        ./util)
+(export #t)
+
+;;; ensemble configuration commands
+(def (do-config-ensemble opt)
+  (let-hash opt
+    (let (cfg (get-ensemble-config))
+      (if .?view
+        (write-config cfg pretty: .?pretty)
+        (begin
+          (cond (.?ensemble-domain         => (cut config-push! cfg domain: <>)))
+          (cond (.?ensemble-root           => (cut config-push! cfg root: <>)))
+          (cond (.?ensemble-public-address => (cut config-push! cfg public-address: <>)))
+          (save-config! cfg (ensemble-config-path)))))))
+
+(def (do-config-role opt)
+  (let-hash opt
+    (let* ((cfg (get-ensemble-config))
+           (role       (or .?role (error "role must be specified")))
+           (role-alist (config-get cfg roles: []))
+           (role-cfg   (agetq role role-alist []))
+           (role-server-cfg
+            (config-get role-cfg server-config: (empty-ensemble-server-config))))
+      (cond (.?exe           => (cut config-push! role-cfg exe: <>)))
+      (cond (.?prefix        => (cut config-push! role-cfg prefix: <>)))
+      (cond (.?suffix        => (cut config-push! role-cfg suffix: <>)))
+      (cond (.?policy        => (cut config-push! role-cfg policy: <>)))
+      (cond (.?env           => (cut config-push! role-server-cfg env: <>)))
+      (cond (.?envvars       => (cut config-push! role-server-cfg envvars: <>)))
+      (cond (.?known-servers => (cut config-push! role-server-cfg known-server: <>)))
+      (when .?application
+        (let (default-config-path
+               (path-expand (symbol->string .application)
+                 (path-expand "config"
+                   (gerbil-path))))
+          (unless (or .?config (file-exists? default-config-path))
+            (error "application config must be specified"))
+          (let* ((config-path (or .config default-config-path))
+                 (app-config (call-with-input-file config-path read-config))
+                 (app-alist  (config-get role-server-cfg application: [])))
+            (cond
+             ((assq .application app-alist)
+              => (lambda (p) (set-cdr! p app-config)))
+             (else
+              (set! app-alist [[.application app-config ...] app-alist ...])))
+            (config-push! role-server-cfg application: app-alist))))
+      (config-push! role-cfg server-config: role-server-cfg)
+      (cond
+       ((assq role role-alist)
+        => (lambda (p) (set-cdr! p role-cfg)))
+       (else
+        (set! role-alist [[role role-cfg ...] role-alist ...])))
+      (config-push! cfg roles: role-alist)
+      (save-config! cfg (ensemble-config-path)))))
+
+(def (do-config-server opt)
+  (error "TODO: configure preloaded server"))
+
+(def (do-config-workers opt)
+  (error "TODO: configure preloaded workers"))
+
+
+(def (get-ensemble-config)
+  (let (path (ensemble-config-path))
+    (if (file-exists? path)
+      (load-ensemble-config-file path)
+      (empty-ensemble-config))))