update agent embedding system

.envrc

@@ -1,3 +1,2 @@
-export LD_LIBRARY_PATH="$PWD/lib:$LD_LIBRARY_PATH"
 export DATABASE_URL="sqlite:lib/crossfire.sqlite"
 [ ! -d lib ] && mkdir lib

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 monocypher dev-migrate dev-rollback
+.PHONY: all check clean dev-migrate dev-rollback
 
 all:
 	raco setup ./crossfire/
@@ -26,12 +26,6 @@ check:
 clean:
 	$(RM) -r crossfire/doc crossfire/compiled crossfire/scribblings/compiled lib/
 
-monocypher: lib/monocypher.so
-
-lib/monocypher.so: /usr/include/monocypher/monocypher.c /usr/include/monocypher/monocypher-ed25519.c
-	[ -d lib ] || mkdir lib
-	$(CC) -o $@ -O3 -pipe -shared $^
-
 dev-migrate:
 	raco north migrate -p crossfire/migrations -f
 

agent-deployment/.gitignore

@@ -0,0 +1,4 @@
+*.o
+*.zo
+/crossfire-agent
+/vendor/

agent-deployment/Makefile

@@ -17,10 +17,10 @@
 
 .PHONY: all clean
 
-APP_NAME=run
+APP_NAME=crossfire-agent
 RKT_NAME=$(APP_NAME).rkt
 
-MONOCYPHER_INC=/usr/include/monocypher
+MONOCYPHER_VERSION=3.1.1
 
 ####################################################################################################
 
@@ -28,17 +28,26 @@ LIBS=-ldl -lm
 # for musl
 #LIBS=-lffi -lucontext
 
+VENDOR_DIR=vendor
+MONOCYPHER_DIR=$(VENDOR_DIR)/monocypher-$(MONOCYPHER_VERSION)
+MONOCYPHER_URL=https://monocypher.org/download/monocypher-$(MONOCYPHER_VERSION).tar.gz
+
 all: $(APP_NAME)
 
 # main build
-$(APP_NAME): main_bc.c app.o monocypher.o monocypher-ed25519.o
+$(APP_NAME): main_bc.c app.o $(MONOCYPHER_DIR)/lib/libmonocypher.a
-	$(CC) -o $@ -pipe -fPIC -O3 -DAPP_NAME='"$(APP_NAME)"' -I$(MONOCYPHER_INC) -static $^ \
+	$(CC) -o $@ -pipe -fPIC -O3 -DAPP_NAME='"$(APP_NAME)"' -I$(MONOCYPHER_DIR)/src -static $^ \
-		-lracket3m -lrktio $(LIBS)
+		-L$(MONOCYPHER_DIR)/lib \
+		-lracket3m -lrktio -lmonocypher $(LIBS)
 
-monocypher.o: $(MONOCYPHER_INC)/monocypher.c
+$(MONOCYPHER_DIR)/lib/libmonocypher.a: $(MONOCYPHER_DIR)/.extracted
-	$(CC) -o $@ -pipe -fPIC -O3 -I$(MONOCYPHER_INC) -c $^
+	cd $(MONOCYPHER_DIR) && $(MAKE) USE_ED22519=true static-library
-monocypher-ed25519.o: $(MONOCYPHER_INC)/monocypher-ed25519.c
+
-	$(CC) -o $@ -pipe -fPIC -O3 -I$(MONOCYPHER_INC) -c $^
+$(MONOCYPHER_DIR)/.extracted: $(MONOCYPHER_DIR).tar.gz
+	tar xf $< -C $(VENDOR_DIR) && touch $@
+
+$(MONOCYPHER_DIR).tar.gz:
+	wget -O $@ $(MONOCYPHER_URL) || curl -o $@ $(MONOCYPHER_URL)
 
 # this is faster than --c-mods by a lot
 # it's less portable but like, we're containerized already so it'll work

agent-deployment/main_bc.c

@@ -23,8 +23,10 @@
 
 #include <monocypher.h>
 
-extern const char _binary_app_zo_start;
+#define rkt_app_start _binary_app_zo_start
-extern const char _binary_app_zo_end;
+#define rkt_app_end _binary_app_zo_end
+extern const char rkt_app_start;
+extern const char rkt_app_end;
 
 // ffi defs
 typedef struct {
@@ -69,7 +71,7 @@ static int run_bc(Scheme_Env* e, int argc, char* argv[]) {
     volatile mz_jmp_buf* save;
     mz_jmp_buf fresh;
     int rv = 0;
-    size_t load_size = ((uintptr_t) &_binary_app_zo_end) - ((uintptr_t) &_binary_app_zo_start);
+    size_t load_size = ((uintptr_t) &rkt_app_end) - ((uintptr_t) &rkt_app_start);
     Scheme_Object* l = NULL;
     Scheme_Object* a[2] = { NULL, NULL };
 
@@ -82,8 +84,8 @@ static int run_bc(Scheme_Env* e, int argc, char* argv[]) {
 
     bc_setup_ffi_table(e);
 
-    scheme_register_embedded_load(load_size, &_binary_app_zo_start);
+    scheme_register_embedded_load(load_size, &rkt_app_start);
-    scheme_embedded_load(load_size, &_binary_app_zo_start, 1);
+    scheme_embedded_load(load_size, &rkt_app_start, 1);
 
     l = scheme_make_null();
     l = scheme_make_pair(scheme_intern_symbol(APP_NAME), l);

crossfire/not-crypto.rkt

@@ -33,7 +33,7 @@
 (define ((bytes-len/c len) bs)
   (and bytes? bs) (= len (bytes-length bs)))
 
-(define monocypher (ffi-lib/runtime "monocypher"))
+(define monocypher (ffi-lib/runtime "libmonocypher"))
 
 (define-syntax (define/ffi stx)
   (syntax-case stx ()

crossfire/protocol.rkt

@@ -16,7 +16,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/>.
 
-(require db/base db/sqlite3 racket/bool racket/match racket/runtime-path racket/path
+(require db/base db/sqlite3 racket/bool racket/match racket/runtime-path racket/path racket/set
          north/base north/adapter/base north/adapter/sqlite
          "comms.rkt" "not-crypto.rkt")
 
@@ -59,11 +59,15 @@
   (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-add-node-res "insert or ignore into node_resource (nodeid, resource) values (?, ?)")
+(define-stmt q-del-node-res "delete from node_resource where nodeid=? and resource=?")
 (define-stmt q-get-nodes "select id, name from node where type=?")
-(define-stmt q-get-resources
+(define-stmt q-get-all-resources
   "select nodeid, resource from node_resource inner join node on node.id = node_resource.nodeid
        where node.type = ?")
+(define-stmt q-get-node-resources "select resource from node_resource where nodeid=?")
+(define-stmt q-edit-node "update node set name=? where id=?")
+(define-stmt q-get-node-type "select type from node where id=?")
 
 ;; rpc calls
 
@@ -74,7 +78,7 @@
 (define (get-nodes type)
   (define type-str (symbol->string type))
   (define resources (rows->dict #:key "nodeid" #:value "resource" #:value-mode '(list)
-                                (query (current-db) q-get-resources type-str)))
+                                (query (current-db) q-get-all-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?)))
@@ -86,35 +90,54 @@
     (define info (simple-result-info (query (current-db) q-new-node name "agent" secret)))
     (define id (cdr (assoc 'insert-id info)))
     (for ([res (in-list resources)])
-      (query-exec (current-db) q-assign-node-res id res))
+      (query-exec (current-db) q-add-node-res id res))
     (values id public))))
 
-(define (enforce type)
+(define (enforce-subject type)
   (unless (symbol=? type (node-type (current-from-node)))
     (error "unauthorized")))
 
+(define (enforce-object id type)
+  (match (query-maybe-value (current-db) q-get-node-type id)
+    [#f (error "node doesn't exist" id)]
+    [(== (symbol->string type)) (void)]
+    [x (error "wrong node type" x)]))
+
 ;; client rpcs
 
 (define-rpc server (get-agents)
-  (enforce 'client)
+  (enforce-subject 'client)
   (get-nodes 'agent))
 
 (define-rpc server (new-agent name resources)
-  (enforce 'client)
+  (enforce-subject 'client)
   (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)
 
+(define-rpc server (edit-agent id name resources)
+  (enforce-subject 'client)
+  (call-with-transaction (current-db) (lambda ()
+    (enforce-object id 'agent)
+    (define existing-resource (list->set (query-list (current-db) q-get-node-resources id)))
+    (define new-resource (list->set resources))
+    (query-exec (current-db) q-edit-node name id)
+    (for ([res (in-set (set-subtract new-resource existing-resource))])
+      (query-exec (current-db) q-add-node-res id res))
+    (for ([res (in-set (set-subtract existing-resource new-resource))])
+      (query-exec (current-db) q-del-node-res id res)))))
+
 (define-rpc server (get-agent-deployment id)
-  (enforce 'client)
+  (enforce-subject 'client)
+  (enforce-object id 'agent)
   ;; bake secret key into binary and ship it i guess
   (error "TODO"))
 
 ;; agent rpcs
 
 (define-rpc server (agent-report something)
-  (enforce 'agent)
+  (enforce-subject 'agent)
   (error "TODO"))
 
 
@@ -124,5 +147,7 @@
   (current-db (open-server-db 'create))
   (migrate-server-db)
   ;;(make-agent "agent0" '("gpu" "hifive"))
+  (parameterize ([current-from-node (node 100 "meow" 'client #f #f #f #f)])
+    ((rpc-impl server edit-agent) 1 "meow0" '("cpu" "hifive")))
   (get-nodes 'agent)
   (get-nodes 'meow))

static/.gitignore

@@ -1,3 +0,0 @@
-*.o
-*.zo
-/run