diff --git a/.envrc b/.envrc index 46e2e25..6d7f1ca 100644 --- a/.envrc +++ b/.envrc @@ -1,2 +1,2 @@ export DATABASE_URL="sqlite:lib/crossfire.sqlite" -[ ! -d lib ] && mkdir lib +[ -d lib ] || mkdir -p lib/projects diff --git a/crossfire/migrations/20201113-add-initial-tables.sql b/crossfire/migrations/20201113-add-initial-tables.sql index d944f63..d94685f 100644 --- a/crossfire/migrations/20201113-add-initial-tables.sql +++ b/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, diff --git a/crossfire/protocol.rkt b/crossfire/protocol.rkt index 7e31eb8..bb0a86b 100644 --- a/crossfire/protocol.rkt +++ b/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))) diff --git a/crossfire/static-support.rkt b/crossfire/static-support.rkt index 36b551a..20a1a60 100644 --- a/crossfire/static-support.rkt +++ b/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)])))