track node resources

crossfire/migrations/20201113-add-initial-tables.sql

@@ -3,21 +3,14 @@
 -- @revision: e50ab485d8590ead53c2518396c04f81
 -- @description: Creates some initial core tables for crossfire.
 -- @up {
-PRAGMA foreign_keys = ON;
--- }
--- @up {
 create table node(id integer primary key, name text not null,
                   type text check(type in ("client", "agent")) not null,
                   secret blob(32) not null)
 -- }
 -- @up {
-create table resource(id integer primary key, name text not null);
+create table node_resource(nodeid integer not null, resource text not null,
--- }
+                           unique (nodeid, resource),
--- @up {
+                           foreign key(nodeid) references node(id));
-create table node_resource(nodeid integer not null, resid integer not null,
-                           unique (nodeid, resid),
-                           foreign key(resid) references resources(id),
-                           foreign key(nodeid) references nodes(id));
 -- }
 -- @up {
 create table task(id integer primary key, name text not null, manifest blob not null);
@@ -28,7 +21,7 @@ create table task_log(taskid integer not null, worker integer not null,
                       time_end timestamp check(time_end >= time_start) not null,
                       pattern blob not null,
                       foreign key (taskid) references tasks(id),
-                      foreign key (worker) references nodes(id));
+                      foreign key (worker) references node(id));
 -- }
 -- @up {
 create table task_match(taskid integer not null, time timestamp not null, match blob not null,
@@ -48,8 +41,5 @@ drop table task;
 drop table node_resource;
 -- }
 -- @down {
-drop table resource;
--- }
--- @down {
 drop table node;
 -- }

crossfire/protocol.rkt

@@ -35,7 +35,9 @@
 (define current-db (make-parameter #f))
 
 (define (open-server-db [mode 'read/write])
-  (sqlite3-connect #:database SERVER-DB-PATH #:mode mode))
+  (let ([db (sqlite3-connect #:database SERVER-DB-PATH #:mode mode)])
+    (query-exec db "pragma foreign_keys=1;")
+    db))
 
 ;; this allows the server to be capable of migrating itself
 (define (migrate-server-db [db (current-db)])
@@ -57,25 +59,35 @@
   (define name (virtual-statement what)))
 
 (define-stmt q-new-node "insert into node (name, type, secret) values (?, ?, ?)")
+(define-stmt q-assign-node-res "insert into node_resource (nodeid, resource) values (?, ?)")
 (define-stmt q-get-nodes "select id, name from node where type=?")
+(define-stmt q-get-resources
+  "select nodeid, resource from node_resource inner join node on node.id = node_resource.nodeid
+       where node.type = ?")
 
 ;; rpc calls
 
 (define-rpc-type server)
 
-(struct node-info [id name online?] #:transparent)
+(struct node-info [id name resources online?] #:transparent)
 
 (define (get-nodes type)
-  (for/list ([(id name) (in-query (current-db) q-get-nodes (symbol->string type))])
+  (define type-str (symbol->string type))
-    (define online? (comms-channel-available? (current-comms) id))
+  (define resources (rows->dict #:key "nodeid" #:value "resource" #:value-mode '(list)
-    (node-info id name online?)))
+                                (query (current-db) q-get-resources type-str)))
+  (for/list ([(id name) (in-query (current-db) q-get-nodes type-str)])
+    (define online? (and (current-comms) (comms-channel-available? (current-comms) id)))
+    (node-info id name (hash-ref resources id) online?)))
 
-(define (make-agent name)
+(define (make-agent name resources)
-  (define secret (crypto-sign-make-key))
+  (call-with-transaction (current-db) (lambda ()
-  (define public (crypto-sign-public-key secret))
+    (define secret (crypto-sign-make-key))
-  (define info (simple-result-info (query (current-db) q-new-node name "agent" secret)))
+    (define public (crypto-sign-public-key secret))
-  (define id (cdr (assoc 'insert-id info)))
+    (define info (simple-result-info (query (current-db) q-new-node name "agent" secret)))
-  (values id public))
+    (define id (cdr (assoc 'insert-id info)))
+    (for ([res (in-list resources)])
+      (query-exec (current-db) q-assign-node-res id res))
+    (values id public))))
 
 (define (enforce type)
   (unless (symbol=? type (node-type (current-from-node)))
@@ -87,9 +99,9 @@
   (enforce 'client)
   (get-nodes 'agent))
 
-(define-rpc server (new-agent name)
+(define-rpc server (new-agent name resources)
   (enforce 'client)
-  (define-values [id public] (make-agent name))
+  (define-values [id public] (make-agent name resources))
   (define comms-node (node id name 'agent public #f #f #f))
   (comms-set-node-info (current-comms) comms-node)
   id)
@@ -109,5 +121,8 @@
 ;; command line usage
 (module+ main
   (require racket/cmdline)
-  (current-db (open-server-db))
+  (current-db (open-server-db 'create))
-  (make-agent "meow"))
+  (migrate-server-db)
+  ;;(make-agent "agent0" '("gpu" "hifive"))
+  (get-nodes 'agent)
+  (get-nodes 'meow))