implement agent management commands

Makefile

@@ -15,7 +15,7 @@
 # You should have received a copy of the GNU Affero General Public License
 # along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
-.PHONY: all check clean dev-migrate dev-rollback
+.PHONY: all check clean dev-migrate dev-rollback dev-make-agent
 
 all:
 	raco pkg install ./crossfire
@@ -31,3 +31,9 @@ dev-migrate:
 
 dev-rollback:
 	raco north rollback -p crossfire/migrations -f
+
+dev-make-agent:
+	cd agent-deployment && $(MAKE)
+	[ -d lib ] || mkdir lib
+	cd agent-deployment && for dir in arch_*; do \
+		mkdir ../lib/$$dir; cp $$dir/crossfire-agent ../lib/$$dir/; done

README.md

@@ -198,6 +198,7 @@ contributions welcome,,,,
     - ✅ `crossfire status`: check status of server / task summary
     - ✅ `crossfire show`: shows task details
     - ✅ `crossfire setup`: sets up access to a server
+    - ✅ `crossfire agent`: manage agents
 - low priority: gui interface (racket/gui & framework time)
 
 ## misc

crossfire/agent.rkt

@@ -376,6 +376,7 @@
   (with-handlers ([exn:break? (lambda (_)
                                 (log-agent-info "connection cancelled")
                                 (exit))])
+    ;; TODO : use net/dns dns lookup if it's a hostname because glibc crashes lol
     (let loop ([sleep-time 1])
       (define maybe-exn
         (with-handlers ([exn:fail? identity])

crossfire/client.rkt

@@ -17,7 +17,8 @@
 ;; along with this program.  If not, see <https://www.gnu.org/licenses/>.
 
 (require file/tar racket/bool racket/contract racket/file racket/format racket/function racket/list
-         racket/match racket/path racket/string racket/unit racket/vector syntax/parse/define
+         racket/match racket/path racket/random racket/string racket/unit racket/vector
+         syntax/parse/define
          (only-in file/sha1 bytes->hex-string)
          (for-syntax racket/base racket/list racket/syntax)
          "codegen.rkt" "comms.rkt" "info.rkt" "manifest.rkt" "not-crypto.rkt" "protocol.rkt")
@@ -177,7 +178,7 @@
                             (format "~a%" (inexact->exact (* 100 (project-info-progress proj))))
                             (~a (project-info-matches proj))))])
           (if (empty? body)
-            '(("" " - no projects - " ""))
+            '(("" " - no projects - " "" ""))
             body))))
 
 
@@ -208,6 +209,36 @@
       (format "match ~a: ~a" i (format-match m)))))
 
 
+(define (cmd-agent-list)
+  (define agents (with-server-connection (get-agents)))
+  (cons '("id" "name" "arch" "resources" "status")
+        (if (empty? agents)
+          '(("" " - no agents - " "" "" ""))
+          (for/list ([info (in-list agents)])
+            (list (~a (node-info-id info))
+                  (~a (node-info-name info))
+                  (~a (node-info-arch info))
+                  (~a (string-join (map ~a (sort (node-info-resources info) string<?)) ", "))
+                  (if (node-info-online? info) "ONLINE" "OFFLINE"))))))
+
+(define (cmd-agent-create name arch resources out-port)
+  (with-server-connection
+    (define id (new-agent name arch resources))
+    ;; TODO : streaming
+    (write-bytes (get-agent-deployment id) out-port)
+    id))
+
+(define (cmd-agent-delete id)
+  (with-server-connection
+    (delete-agent id)))
+
+(define (cmd-get-deployment id out-port)
+  (with-server-connection
+    ;; TODO : streaming
+    (write-bytes (get-agent-deployment id) out-port)
+    (void)))
+
+
 (define (cmd-setup config)
   (make-parent-directory* *client-key-file*)
   (with-output-to-file *client-key-file* (lambda () (write config)) #:exists 'replace))
@@ -242,18 +273,16 @@
          (report-status "error: ~a" warning))
        (report-fatal-error "check was not successful due to above messages")]))
 
-  (define (interactive-status)
+  (define (print-table table)
-    (define status-tbl (cmd-status))
+    (define max-widths (for/list ([_ (in-list (first table))] [i (in-naturals)])
-    (define max-widths (for/list ([_ (in-list (first status-tbl))] [i (in-naturals)])
+                         (apply max (map (lambda (x) (string-length (list-ref x i))) table))))
-                         (apply max (map (lambda (x) (string-length (list-ref x i))) status-tbl))))
+    (for ([row (in-list table)])
-    (for ([row (in-list status-tbl)])
       (for ([item (in-list row)] [width (in-list max-widths)])
         (write-string (~a item #:width (+ 2 width))))
       (write-string "\n")))
 
-  (define (interactive-show id)
+  (define (make-random-filename)
-    (for ([line (in-list (cmd-show id))])
+    (string-append (bytes->hex-string (crypto-random-bytes 8)) ".agent"))
-      (displayln line)))
 
   (define-simple-macro (subcommand (name:id description:str) body ...)
     #:with name-str (datum->syntax #'name (symbol->string (syntax-e #'name)))
@@ -274,6 +303,10 @@
     (define name (make-hash (list cmds ...))))
 
   (define flag-mode (make-parameter "stdio"))
+  (define flag-agent (make-parameter #f))
+  (define flag-agent-name (make-parameter #f))
+  (define flag-agent-arch (make-parameter #f))
+  (define flag-agent-res (make-parameter '()))
   (define-commands *commands*
     (subcommand (new "Create a new crossfire project")
       #:once-each [("-m" "--mode") mode "Project mode (stdio [default] or callback)"
@@ -311,13 +344,61 @@
 
     (subcommand (status "Summary of project status on server")
       #:args ()
-      (interactive-status))
+      (print-table (cmd-status)))
 
     (subcommand (show "Show information about a project on the server")
       #:args (id-str)
       (define id (or (string->number id-str)
                      (error "must provide numeric ID")))
-      (interactive-show id))
+      (for ([line (in-list (cmd-show id))])
+        (displayln line)))
+
+    (subcommand (agent "Manage crossfire agents")
+      #:once-any
+      [("-l" "--list") "List agents" (flag-agent (list 'list #f))]
+      [("-c" "--create") "Create a new agent" (flag-agent (list 'create #f))]
+      [("-d" "--delete") aid "Delete an agent" (flag-agent (list 'delete aid))]
+      [("-g" "--get-binary") aid "Redownload the binary for an agent" (flag-agent (list 'get aid))]
+      #:once-each
+      [("-a" "--arch") arch "For --create, the agent CPU architecture" (flag-agent-arch arch)]
+      [("-n" "--name") name "For --create, the agent name" (flag-agent-name name)]
+      #:multi
+      [("-r" "--resource") res "For --create, resources to associate with the agent"
+                           (flag-agent-res (cons res (flag-agent-res)))]
+      #:args ()
+      (define (do-final out-name)
+        (define perms (file-or-directory-permissions out-name 'bits))
+        (file-or-directory-permissions out-name (bitwise-ior perms #o111))
+        (report-status "agent executable saved to ~a" out-name))
+
+      (match (flag-agent)
+        [(list 'list _)
+         (print-table (cmd-agent-list))]
+        [(list 'create _)
+         (when (or (false? (flag-agent-name))
+                   (false? (flag-agent-arch)))
+           (error "you must provide -n and -a for this command"))
+         (define out-name (make-random-filename))
+         (call-with-output-file out-name
+           (lambda (o)
+             (define aid (cmd-agent-create (flag-agent-name) (flag-agent-arch) (flag-agent-res) o))
+             (report-status "created agent ~a" aid)))
+         (do-final out-name)]
+        [(list 'delete aid-str)
+         (define aid (string->number aid-str))
+         (unless aid
+           (error "invalid agent id provided"))
+         (cmd-agent-delete aid)
+         (report-status "deleted agent ~a" aid)]
+        [(list 'get aid-str)
+         (define aid (string->number aid-str))
+         (unless aid
+           (error "invalid agent id provided"))
+         (define out-name (make-random-filename))
+         (call-with-output-file out-name
+           (lambda (o) (cmd-get-deployment aid o)))
+         (do-final out-name)]
+        [_ (error "you must provide -l, -c, -d, or -g for this command")]))
 
     (subcommand (setup "Set up access to a crossfire server")
       #:args (config-file)

crossfire/comms.rkt

@@ -221,7 +221,7 @@
       (lambda ()
         (with-handlers ([exn:fail? (lambda (ex) (thread-send from ex #f))])
           (match (hash-ref node-registry id #f)
-            [#f (thread-send from (make-error "no such node" id) #f)]
+            [#f (thread-send from (make-error (format "no such node ~a" id)) #f)]
             [(node id name type pubkey seckey host port)
              (when (and host port)
                (make-peer-thread (lambda () (tcp-connect host port)) local-msg-channel))
@@ -463,7 +463,7 @@
        (match-define (cons to-id (cons rpc-id rpc-data)) data)
        (send-transaction from to-id rpc-id rpc-data)]
       ['shutdown (set! run-tm #f) (cleanup) (thread-send from (void) #f)]
-      [_ (thread-send from (make-error "invalid transaction thread msg" #f))]))
+      [_ (thread-send from (make-error "invalid transaction thread msg") #f)]))
 
   (define (handle-incoming msg)
     (match msg

crossfire/server.rkt

@@ -293,7 +293,11 @@
   (enforce-subject 'client)
   (call-with-transaction (current-db) (lambda ()
     (enforce-object id 'agent)
-    (query-exec (current-db) q-delete-node id)))
+    (with-handlers
+      ([exn:fail:sql?
+         (lambda (_)
+           (error "failed to delete agent, perhaps there are some projects referencing it?"))])
+      (query-exec (current-db) q-delete-node id))))
   (comms-delete-node (current-comms) id)
   (agent-handler-delete-agent id)
   (void))
@@ -646,7 +650,7 @@
            (define right-arch? (or (member "any" needed-arch) (member arch needed-arch)))
            (if (and right-arch?
                     (task-has-work? head)
-                    (subset? available-resources needed-resources))
+                    (subset? needed-resources available-resources))
              (create-assignment! head)
              (select-task! tail))]))