implement basic project support

.envrc

@@ -1,2 +1,2 @@
 export DATABASE_URL="sqlite:lib/crossfire.sqlite"
-[ ! -d lib ] && mkdir lib
+[ -d lib ] || mkdir -p lib/projects

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

@@ -13,7 +13,8 @@ create table node_resource(nodeid integer not null, resource text not null,
                            foreign key(nodeid) references node(id));
 -- }
 -- @up {
-create table task(id integer primary key, name text not null, manifest blob not null);
+create table task(id integer primary key, name text not null, manifest blob not null,
+                  committed boolean not null);
 -- }
 -- @up {
 create table task_log(taskid integer not null, worker integer not null,

crossfire/protocol.rkt

@@ -20,7 +20,9 @@
          racket/bool racket/fasl racket/file racket/match racket/runtime-path racket/path
          racket/set racket/string
          north/base north/adapter/base north/adapter/sqlite
-         "comms.rkt" "not-crypto.rkt")
+         "comms.rkt" "not-crypto.rkt"
+         ;; port-fsync
+         (submod "static-support.rkt" misc-calls))
 
 ;; configuration
 
@@ -28,6 +30,7 @@
 
 (define SERVER-DATA-DIR (if PRODUCTION? "/var/lib/crossfire/" "lib/"))
 (define SERVER-DB-PATH (build-path SERVER-DATA-DIR "crossfire.sqlite"))
+(define SERVER-FILES-PATH (build-path SERVER-DATA-DIR "projects/"))
 (define AGENT-ARCH-PREFIX "arch_")
 (define AGENT-BINARY "crossfire-agent")
 
@@ -77,11 +80,61 @@
 (define-stmt q-get-node-type "select type from node where id=?")
 (define-stmt q-get-node-info "select name, arch, type, secret from node where id=?")
 
+(define-stmt q-new-task "insert into task (name, manifest, committed) values (?, ?, 0)")
+(define-stmt q-get-task-id-commit "select id, committed from task")
+(define-stmt q-set-task-commit "update task set committed=1 where id=?")
+(define-stmt q-delete-task "delete from task where id=?")
+(define-stmt q-get-tasks "select id, name, manifest from task")
+
+;; utils
+
+(define (query/insert-id db stmt . args)
+  (define info (simple-result-info (apply query db stmt args)))
+  (cdr (assoc 'insert-id info)))
+
+;; cleanly recovers from potential crash situations
+(define (server-cleanup-unused-files)
+  (define existing-ids (mutable-set))
+  (call-with-transaction (current-db) (lambda ()
+    (define (cleanup id exists? path)
+      (displayln (format "removing corrupted/incomplete task ~a" id))
+      (when exists? (delete-file path))
+      (query-exec (current-db) q-delete-task id))
+    (for ([(id committed) (in-query (current-db) q-get-task-id-commit)])
+      (set-add! existing-ids (number->string id))
+      (define path (build-path SERVER-FILES-PATH (number->string id)))
+      (define exists? (file-exists? path))
+      (define committed? (= 1 committed))
+      (cond
+        ;; potentially crashed while file was fsync'd but the directory was not
+        [(and committed? (not exists?)) (cleanup id exists? path)]
+        ;; crashed between row insert and file fsync
+        [(not committed?) (cleanup id exists? path)]
+        [else (void)]))))
+  ;; delete any unaffiliated files
+  (for ([subpath (in-directory SERVER-FILES-PATH)])
+    (define name (path->string (file-name-from-path subpath)))
+    (unless (set-member? existing-ids name)
+      (delete-file subpath)))
+  (void))
+
+;; commits a file corresponding to the task
+(define (server-commit-file taskid data)
+  (define path (build-path SERVER-FILES-PATH (number->string taskid)))
+  (call-with-output-file path
+    (lambda (out)
+      (write-bytes data out)
+      (port-fsync out))
+    #:mode 'binary
+    #:exists 'truncate)
+  (query-exec (current-db) q-set-task-commit taskid))
+
 ;; rpc calls
 
 (define-rpc-type server)
 
-(struct node-info [id name arch type resources online?] #:transparent)
+(struct node-info [id name arch type resources online?] #:prefab)
+(struct project-info [id name manifest] #:prefab)
 
 (define (get-nodes type)
   (define type-str (symbol->string type))
@@ -95,9 +148,7 @@
   (call-with-transaction (current-db) (lambda ()
     (define secret (crypto-sign-make-key))
     (define public (crypto-sign-public-key secret))
-    (define info
-      (simple-result-info (query (current-db) q-new-node name arch (symbol->string type) secret)))
-    (define id (cdr (assoc 'insert-id info)))
+    (define id (query/insert-id (current-db) q-new-node name arch (symbol->string type) secret))
     (for ([res (in-list resources)])
       (query-exec (current-db) q-add-node-res id res))
     (values id public))))
@@ -118,6 +169,12 @@
     [(list _ ... "linux" "gnu") (configure.linux-gnu)]
     [_ (error "XXX: don't know how to configure arch" agent-arch)]))
 
+(define (make-task name manifest tar)
+  (define manifest-data (s-exp->fasl manifest))
+  (define id (query/insert-id (current-db) q-new-task name manifest-data))
+  (server-commit-file id tar)
+  id)
+
 (define (enforce-subject type)
   (unless (symbol=? type (node-type (current-from-node)))
     (error "unauthorized")))
@@ -161,6 +218,17 @@
                              arch (current-server-public-node))]
     [_ (error "invalid id or wrong node type")]))
 
+;; client rpcs :: projects
+
+(define-rpc server (new-project name manifest tar)
+  (enforce-subject 'client)
+  (make-task name manifest tar))
+
+(define-rpc server (get-projects)
+  (enforce-subject 'client)
+  (for/list ([(id name manifest) (in-query (current-db) q-get-tasks)])
+    (project-info id name (fasl->s-exp manifest))))
+
 ;; agent rpcs
 
 (define-rpc server (agent-report something)
@@ -173,6 +241,11 @@
   (require racket/cmdline)
   (current-db (open-server-db 'create))
   (migrate-server-db)
+
+  (parameterize ([current-from-node (node 100 "meow" 'client #f #f #f #f)])
+    ((rpc-impl server get-projects)))
+
+  ; (make-task "meow-task" '((meow . 10)) #"this is some extra data")
   ; (define data (configure-agent-binary (node 10 "meow0" 'agent #f #f #f #f)
   ;                                      "aarch64-unknown-linux-gnu"
   ;                                      (node 0 "server" 'server #f #f "meow.systems" 1337)))

crossfire/static-support.rkt

@@ -82,3 +82,32 @@
     (error "static ffi entry not found" name))
 
   (cast ent _fun-opaque type))
+
+;; misc ffi calls not provided by racket (because ????)
+;; racket should have fsync like cmon
+(module+ misc-calls
+  (require ffi/unsafe/port racket/match)
+
+  (provide port-fsync)
+
+  (define port-fsync.unix
+    ;; lazy time
+    (let ([fsync-call #f])
+      (lambda (port)
+        (define fd (unsafe-port->file-descriptor port))
+        (when (false? fd) (error "invalid port provided"))
+        (when (false? fsync-call)
+          (set! fsync-call
+            (get-ffi-obj/runtime
+              "fsync" (ffi-lib/runtime "libc" '("6" "7"))
+              (_fun #:save-errno 'posix _int -> (res : _int)
+                    -> (unless (zero? res)
+                         (raise (exn:fail:filesystem:errno (format "fsync: errno ~a" (saved-errno))
+                                                           (current-continuation-marks)
+                                                           (cons (saved-errno) 'posix))))))))
+        (fsync-call fd))))
+
+  (define (port-fsync port)
+    (match (system-type 'os)
+      ['unix (port-fsync.unix port)]
+      [x (error "don't know how to fsync on" x)])))