188 lines
7.5 KiB
Racket
188 lines
7.5 KiB
Racket
#lang racket/base
|
|
;; crossfire: distributed brute force infrastructure
|
|
;;
|
|
;; Copyright (C) 2020 haskal
|
|
;;
|
|
;; This program is free software: you can redistribute it and/or modify
|
|
;; it under the terms of the GNU Affero General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
;;
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU Affero General Public License for more details.
|
|
;;
|
|
;; 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/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")
|
|
|
|
;; configuration
|
|
|
|
(define PRODUCTION? #f)
|
|
|
|
(define SERVER-DATA-DIR (if PRODUCTION? "/var/lib/crossfire/" "lib/"))
|
|
(define SERVER-DB-PATH (build-path SERVER-DATA-DIR "crossfire.sqlite"))
|
|
(define AGENT-ARCH-PREFIX "arch_")
|
|
(define AGENT-BINARY "crossfire-agent")
|
|
|
|
;; comms node for server (without secret key)
|
|
(define current-server-public-node (make-parameter #f))
|
|
|
|
;; north migrations
|
|
(define-runtime-path migrations-dir "migrations/")
|
|
|
|
;; database
|
|
|
|
(define current-db (make-parameter #f))
|
|
|
|
(define (open-server-db [mode 'read/write])
|
|
(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)])
|
|
;; these are the steps taken by the north cli tool (it's a bit verbose but at least it's all
|
|
;; programmatically accessible...)
|
|
;; i also use a runtime path to be a bit more robust
|
|
(define base (path->migration migrations-dir))
|
|
(define adapter (sqlite-adapter db))
|
|
(adapter-init adapter)
|
|
(define current-revision (adapter-current-revision adapter))
|
|
(define target-revision (migration-revision (migration-most-recent base)))
|
|
(define plan (migration-plan base current-revision target-revision))
|
|
(for ([migration (in-list plan)])
|
|
(displayln (format "applying migration: ~a" (migration-revision migration)))
|
|
(adapter-apply! adapter (migration-revision migration) (migration-up migration)))
|
|
(void))
|
|
|
|
(define-syntax-rule (define-stmt name what)
|
|
(define name (virtual-statement what)))
|
|
|
|
(define-stmt q-new-node "insert into node (name, arch, type, secret) 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, arch from node where type=?")
|
|
(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=?")
|
|
(define-stmt q-get-node-info "select name, arch, type, secret from node where id=?")
|
|
|
|
;; rpc calls
|
|
|
|
(define-rpc-type server)
|
|
|
|
(struct node-info [id name arch type resources online?] #:transparent)
|
|
|
|
(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-all-resources type-str)))
|
|
(for/list ([(id name arch) (in-query (current-db) q-get-nodes type-str)])
|
|
(define online? (and (current-comms) (comms-channel-available? (current-comms) id)))
|
|
(node-info id name arch type (hash-ref resources id) online?)))
|
|
|
|
(define (make-node name arch type resources)
|
|
(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)))
|
|
(for ([res (in-list resources)])
|
|
(query-exec (current-db) q-add-node-res id res))
|
|
(values id public))))
|
|
|
|
(define (configure-agent-binary agent-node agent-arch server-node)
|
|
;; TODO : assumes unix
|
|
(define binary
|
|
(file->bytes
|
|
(build-path SERVER-DATA-DIR (string-append AGENT-ARCH-PREFIX agent-arch) AGENT-BINARY)))
|
|
|
|
(define (configure.linux-gnu)
|
|
(define trailing-data (s-exp->fasl (list agent-node server-node)))
|
|
;; write 32 bit unsigned big endian trailer size (including size)
|
|
(define trailing-size
|
|
(integer->integer-bytes (+ 4 (bytes-length trailing-data)) 4 #f #t))
|
|
(bytes-append binary trailing-data trailing-size))
|
|
|
|
(match (string-split agent-arch "-")
|
|
[(list _ ... "linux" "gnu") (configure.linux-gnu)]
|
|
[_ (error "XXX: don't know how to configure arch" agent-arch)]))
|
|
|
|
(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-subject 'client)
|
|
(get-nodes 'agent))
|
|
|
|
(define-rpc server (new-agent name arch resources)
|
|
(enforce-subject 'client)
|
|
(define-values [id public] (make-node name arch 'agent 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-subject 'client)
|
|
(match (query-maybe-row (current-db) q-get-node-info id)
|
|
[(vector name arch "agent" secret)
|
|
(configure-agent-binary (node id name 'agent (crypto-sign-public-key secret) secret #f #f)
|
|
arch (current-server-public-node))]
|
|
[_ (error "invalid id or wrong node type")]))
|
|
|
|
;; agent rpcs
|
|
|
|
(define-rpc server (agent-report something)
|
|
(enforce-subject 'agent)
|
|
(error "TODO"))
|
|
|
|
|
|
;; command line usage
|
|
(module+ main
|
|
(require racket/cmdline)
|
|
(current-db (open-server-db 'create))
|
|
(migrate-server-db)
|
|
(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)))
|
|
(with-output-to-file "/tmp/crossfire-agent.configured"
|
|
(lambda () (write-bytes data)))
|
|
; (make-node "agent0" "x86_64" 'agent '("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)
|
|
)
|