add better task and agent work status to cli

crossfire/client.rkt

@@ -40,7 +40,7 @@
 (define (call-with-server-connection func)
   (match-define (list client-node server-node) (call-with-input-file *client-key-file* read))
 
-  (define (noshutdown)
+  (define (no-shutdown)
     (current-to-node server-node)
     (current-comms (make-comms client-node))
     (current-tm (make-transaction-manager client-node (current-comms)))
@@ -51,7 +51,9 @@
     (tm-shutdown (current-tm))
     (comms-shutdown (current-comms)))
 
-  (dynamic-wind noshutdown func shutdown))
+  ;; here's my absolutely genius naming scheme for networking stuff it's "shutdown" and
+  ;; "no shutdown" yes i'm an employee of Sysco Corporation™
+  (dynamic-wind no-shutdown func shutdown))
 
 (define-simple-macro (with-server-connection body ...+)
   #:with no-hygiene
@@ -171,12 +173,13 @@
   (define projects
     (with-server-connection
       (get-projects)))
-  (cons '("project id" "name" "progress" "matches")
+  (cons '("project id" "name" "progress" "matches" "active agents")
         (let ([body (for/list ([proj (in-list projects)])
                       (list (~a (project-info-id proj))
                             (project-info-name proj)
                             (format "~a%" (inexact->exact (* 100 (project-info-progress proj))))
-                            (~a (project-info-matches proj))))])
+                            (~a (project-info-matches proj))
+                            (~a (project-info-agent-state proj))))])
           (if (empty? body)
             '(("" " - no projects - " "" ""))
             body))))
@@ -210,16 +213,29 @@
 
 
 (define (cmd-agent-list)
-  (define agents (with-server-connection (get-agents)))
+  (define-values [agents projects]
+    (with-server-connection
+      (values (get-agents) (get-projects))))
   (cons '("id" "name" "arch" "resources" "status")
         (if (empty? agents)
           '(("" " - no agents - " "" "" ""))
           (for/list ([info (in-list agents)])
+            (define detailed-status
+              (if (node-info-online? info)
+                (let ([assignments
+                        (for/list ([proj (in-list projects)]
+                                   #:when (member (node-info-id info)
+                                                  (project-info-agent-state proj)))
+                          (project-info-id proj))])
+                  (if (empty? assignments)
+                    "online, idle"
+                    (format "working on ~a" assignments)))
+                "OFFLINE"))
             (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"))))))
+                  detailed-status)))))
 
 (define (cmd-agent-create name arch resources out-port)
   (with-server-connection

crossfire/protocol.rkt

@@ -44,5 +44,5 @@
 
 (struct node-info [id name arch type resources online?] #:prefab)
 ;; manifest is the raw source format
-(struct project-info [id name manifest progress matches] #:prefab)
+(struct project-info [id name manifest progress matches agent-state] #:prefab)
 (provide (struct-out node-info) (struct-out project-info))

crossfire/server.rkt

@@ -327,6 +327,12 @@
         (integer-set-count sub)))
     (/ completed-size total-size))
 
+  ;; map of task id to list of agent ids (that are actively working on an assignment in this task)
+  ;; TODO : provide a more detailed view of individual projects tbh. work log, match log, error log
+  ;; (this doesn't exist yet lol), which agents are able to do it, which agents gave up because of
+  ;; errors (also not implemented)
+  (define agent-states (agent-handler-get-status))
+
   (for/list ([(id name manifest complete?) (in-query (current-db) q-get-tasks)])
     (define mf (fasl->s-exp manifest))
     ;; XXX this should be a join t b h
@@ -336,7 +342,7 @@
         ;; XXX this could also _maybe_ be a join but idk
         (get-progress id mf)
         1.0))
-    (project-info id name mf progress matches)))
+    (project-info id name mf progress matches (hash-ref agent-states id '()))))
 
 (define/contract (get-project-file taskid)
   (-> integer? bytes?)
@@ -834,6 +840,12 @@
                           (cons 'agent-report (cons assignment-id state)))]
       [(cons 'cancel-task task-id)
        (handle-stop-task task-id)]
+      [(cons 'get-status ch)
+       (channel-put
+         ch
+         (for/hash ([(tid ts) (in-hash current-tasks)])
+           (define agent-ids (hash-keys (task-state-agent-todo ts)))
+           (values tid agent-ids)))]
       ['shutdown
        (for ([(id _) (in-hash agents)])
          (handle-delete-agent id))
@@ -868,6 +880,11 @@
 (define (agent-handler-cancel-task task-id [ah (current-agent-handler)])
   (thread-send ah (cons 'cancel-task task-id)))
 
+(define (agent-handler-get-status [ah (current-agent-handler)])
+  (define ch (make-channel))
+  (thread-send ah (cons 'get-status ch))
+  (channel-get ch))
+
 (define (agent-handler-shutdown [ah (current-agent-handler)])
   (thread-send ah 'shutdown)
   (thread-wait ah))