ok now it's an MVP (some features still missing,,)
This commit is contained in:
parent
18381a5e01
commit
05b3e97a66
|
|
@ -16,10 +16,10 @@
|
|||
;; 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 file/tar racket/bool racket/file racket/function racket/list racket/match racket/path
|
||||
racket/string racket/unit racket/vector syntax/parse/define
|
||||
(require file/tar racket/bool racket/contract racket/file racket/format racket/function racket/list
|
||||
racket/match racket/path racket/string racket/unit racket/vector syntax/parse/define
|
||||
(only-in file/sha1 bytes->hex-string)
|
||||
(for-syntax racket/base racket/syntax)
|
||||
(for-syntax racket/base racket/list racket/syntax)
|
||||
"codegen.rkt" "comms.rkt" "info.rkt" "manifest.rkt" "not-crypto.rkt" "protocol.rkt")
|
||||
|
||||
(define *program* (format "~a-client" (#%info-lookup 'collection)))
|
||||
|
|
@ -34,6 +34,43 @@
|
|||
(define *cf-private-cache* (build-path ".crossfire" "cache.rktd"))
|
||||
(define *cf-tmp-targz* (build-path ".crossfire" "project.tgz"))
|
||||
|
||||
(define server-wrapper@ (make-rpc-wrapper-unit server^))
|
||||
|
||||
(define (call-with-server-connection func)
|
||||
(match-define (list client-node server-node) (call-with-input-file *client-key-file* read))
|
||||
|
||||
(define (noshutdown)
|
||||
(current-to-node server-node)
|
||||
(current-comms (make-comms client-node))
|
||||
(current-tm (make-transaction-manager client-node (current-comms)))
|
||||
(comms-set-node-info (current-comms) server-node)
|
||||
(comms-connect (current-comms) (node-id server-node)))
|
||||
|
||||
(define (shutdown)
|
||||
(tm-shutdown (current-tm))
|
||||
(comms-shutdown (current-comms)))
|
||||
|
||||
(dynamic-wind noshutdown func shutdown))
|
||||
|
||||
(define-simple-macro (with-server-connection body ...+)
|
||||
#:with no-hygiene
|
||||
(datum->syntax (first (syntax-e #'(body ...)))
|
||||
'(define-values/invoke-unit server-wrapper@ (import) (export server^)))
|
||||
(call-with-server-connection
|
||||
(lambda ()
|
||||
no-hygiene
|
||||
body ...)))
|
||||
|
||||
(define (read-manifest project-dir)
|
||||
(define (report-contract-error ex)
|
||||
(error "failed to parse manifest! make sure it matches the example formats"))
|
||||
|
||||
(with-handlers ([exn:fail:contract? report-contract-error])
|
||||
(parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read))))
|
||||
|
||||
|
||||
;; command functions
|
||||
|
||||
(define (cmd-new project-name mode)
|
||||
(define project-root (build-path project-name))
|
||||
(when (or (file-exists? project-root) (directory-exists? project-root)
|
||||
|
|
@ -90,7 +127,7 @@
|
|||
(define (cmd-check project-dir)
|
||||
(define messages '())
|
||||
|
||||
(define mf (parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read)))
|
||||
(define mf (read-manifest project-dir))
|
||||
(define mode (first (manifest-data-ref mf 'mode)))
|
||||
|
||||
(when (and (symbol=? mode 'stdio)
|
||||
|
|
@ -106,13 +143,11 @@
|
|||
|
||||
|
||||
(define (cmd-submit project-dir)
|
||||
(define mf (parse-manifest (call-with-input-file (build-path project-dir "manifest.rktd") read)))
|
||||
(match-define (list client-node server-node) (call-with-input-file *client-key-file* read))
|
||||
(define mf (read-manifest project-dir))
|
||||
|
||||
;; create targz
|
||||
(define tmp-targz (build-path project-dir *cf-tmp-targz*))
|
||||
(parameterize ([current-directory project-dir])
|
||||
(define out (current-output-port))
|
||||
(tar-gzip tmp-targz "."
|
||||
#:exists-ok? #t
|
||||
#:path-filter (lambda (p)
|
||||
|
|
@ -122,21 +157,55 @@
|
|||
[(list 'same) #t]
|
||||
[_ (error "not shonks...")]))))
|
||||
|
||||
;; connect to server
|
||||
(define server-wrapper@ (make-rpc-wrapper-unit server^))
|
||||
(define-values/invoke-unit server-wrapper@ (import) (export server^))
|
||||
(with-server-connection
|
||||
(new-project (serialize-manifest mf) (file->bytes tmp-targz))))
|
||||
|
||||
(current-to-node server-node)
|
||||
(current-comms (make-comms client-node))
|
||||
(current-tm (make-transaction-manager client-node (current-comms)))
|
||||
(comms-set-node-info (current-comms) server-node)
|
||||
(comms-connect (current-comms) (node-id server-node))
|
||||
|
||||
(new-project (serialize-manifest mf) (file->bytes tmp-targz))
|
||||
(define (cmd-delete id)
|
||||
(with-server-connection
|
||||
(delete-project id)))
|
||||
|
||||
(tm-shutdown (current-tm))
|
||||
(comms-shutdown (current-comms))
|
||||
(void))
|
||||
|
||||
(define (cmd-status)
|
||||
(define projects
|
||||
(with-server-connection
|
||||
(get-projects)))
|
||||
(cons '("project id" "name" "progress" "matches")
|
||||
(let ([body (for/list ([proj (in-list projects)])
|
||||
(list (~a (project-info-id proj))
|
||||
(project-info-name proj)
|
||||
(format "~a%" (inexact->exact (* 100 (project-info-progress proj))))
|
||||
(~a (project-info-matches proj))))])
|
||||
(if (empty? body)
|
||||
'(("" " - no projects - " ""))
|
||||
body))))
|
||||
|
||||
|
||||
(define all-printable? (listof (integer-in 32 126)))
|
||||
(define all-byte? (listof (integer-in 0 255)))
|
||||
(define (cmd-show id)
|
||||
;; if it's all printable, make it a string
|
||||
;; if it's all bytes, make it a bytes
|
||||
;; otherwise, ....
|
||||
(define (format-match m)
|
||||
(define fmt-width
|
||||
;; determine the number of digits needed to print in hex
|
||||
(let ([max-size (ceiling (log (apply max m) 16))])
|
||||
;; adjust the digit count to the nearest power of 2 (4 digits, 8 digits, 16 digits, etc)
|
||||
(expt 2 (inexact->exact (ceiling (log max-size 2))))))
|
||||
(cond
|
||||
[(all-printable? m) (~s (list->string (map integer->char m)))]
|
||||
[(all-byte? m) (~s (apply bytes m))]
|
||||
[else (string-join (map (lambda (x) (~r x #:base 16 #:min-width fmt-width #:pad-string "0"))
|
||||
m))]))
|
||||
|
||||
(define matches
|
||||
(with-server-connection
|
||||
(get-project-matches id)))
|
||||
(if (empty? matches)
|
||||
(list "no matches... :(")
|
||||
(for/list ([m (in-list matches)] [i (in-naturals)])
|
||||
(format "match ~a: ~a" i (format-match m)))))
|
||||
|
||||
|
||||
(define (cmd-setup config)
|
||||
|
|
@ -144,6 +213,8 @@
|
|||
(with-output-to-file *client-key-file* (lambda () (write config)) #:exists 'replace))
|
||||
|
||||
|
||||
;; command parsing / UI
|
||||
|
||||
(module+ main
|
||||
(require racket/cmdline)
|
||||
|
||||
|
|
@ -171,6 +242,19 @@
|
|||
(report-status "error: ~a" warning))
|
||||
(report-fatal-error "check was not successful due to above messages")]))
|
||||
|
||||
(define (interactive-status)
|
||||
(define status-tbl (cmd-status))
|
||||
(define max-widths (for/list ([_ (in-list (first status-tbl))] [i (in-naturals)])
|
||||
(apply max (map (lambda (x) (string-length (list-ref x i))) status-tbl))))
|
||||
(for ([row (in-list status-tbl)])
|
||||
(for ([item (in-list row)] [width (in-list max-widths)])
|
||||
(write-string (~a item #:width (+ 2 width))))
|
||||
(write-string "\n")))
|
||||
|
||||
(define (interactive-show id)
|
||||
(for ([line (in-list (cmd-show id))])
|
||||
(displayln line)))
|
||||
|
||||
(define-simple-macro (subcommand (name:id description:str) body ...)
|
||||
#:with name-str (datum->syntax #'name (symbol->string (syntax-e #'name)))
|
||||
(list name-str
|
||||
|
|
@ -218,6 +302,23 @@
|
|||
(cmd-submit (current-directory))
|
||||
(report-status "project submitted!! time for crab"))
|
||||
|
||||
(subcommand (delete "Delete an executed or completed project")
|
||||
#:args (id-str)
|
||||
(define id (or (string->number id-str)
|
||||
(error "must provide numeric ID")))
|
||||
(cmd-delete id)
|
||||
(report-status "project ~a deleted" id))
|
||||
|
||||
(subcommand (status "Summary of project status on server")
|
||||
#:args ()
|
||||
(interactive-status))
|
||||
|
||||
(subcommand (show "Show information about a project on the server")
|
||||
#:args (id-str)
|
||||
(define id (or (string->number id-str)
|
||||
(error "must provide numeric ID")))
|
||||
(interactive-show id))
|
||||
|
||||
(subcommand (setup "Set up access to a crossfire server")
|
||||
#:args (config-file)
|
||||
(unless (file-exists? config-file)
|
||||
|
|
|
|||
|
|
@ -44,14 +44,22 @@
|
|||
|
||||
;; ok gamer move time
|
||||
(define-runtime-path codegen-template "templates/codegen.rktc")
|
||||
(define-runtime-path header-template "templates/header.rktc")
|
||||
(define-runtime-path makefile-template "templates/Makefile.rkt")
|
||||
(define-runtime-path manifest-template "templates/manifest.rktrktd")
|
||||
|
||||
;; TODO : make configurable
|
||||
(define c-type "uint64_t")
|
||||
(define c-type-fmt "%lx")
|
||||
|
||||
(define (generate-support-code mf)
|
||||
(define vars (hash 'pattern (vector-map integer-set-contents (manifest-pattern mf))
|
||||
'mode (first (manifest-data-ref mf 'mode))))
|
||||
'mode (first (manifest-data-ref mf 'mode))
|
||||
'c-type c-type
|
||||
'c-type-fmt c-type-fmt))
|
||||
(hash
|
||||
"crossfire.c" (eval-template codegen-template vars)
|
||||
"crossfire.h" (eval-template header-template vars)
|
||||
"Makefile" (eval-template makefile-template vars)))
|
||||
|
||||
(define (generate-manifest mode)
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@
|
|||
new-project
|
||||
get-projects
|
||||
get-project-file
|
||||
get-project-matches
|
||||
delete-project
|
||||
agent-report-state])
|
||||
|
||||
|
|
@ -40,3 +41,8 @@
|
|||
|
||||
(define-signature client^
|
||||
[todo])
|
||||
|
||||
(struct node-info [id name arch type resources online?] #:prefab)
|
||||
;; manifest is the raw source format
|
||||
(struct project-info [id name manifest progress matches] #:prefab)
|
||||
(provide (struct-out node-info) (struct-out project-info))
|
||||
|
|
|
|||
|
|
@ -109,7 +109,6 @@
|
|||
(define-stmt q-get-tasks "select id, name, manifest, complete from task")
|
||||
(define-stmt q-set-task-complete "update task set complete=1 where id=?")
|
||||
(define-stmt q-task-exists "select 1 from task where id=?")
|
||||
(define-stmt q-delete-task "delete from task where id=?")
|
||||
|
||||
(define-stmt q-get-task-log
|
||||
"select worker, time_wall_start, duration, pattern from task_log where taskid=?")
|
||||
|
|
@ -118,6 +117,10 @@
|
|||
values (?, ?, ?, ?, ?)")
|
||||
(define-stmt q-add-task-match
|
||||
"insert into task_match (taskid, worker, time_wall, match) values (?, ?, ?, ?)")
|
||||
(define-stmt q-get-task-matches
|
||||
"select worker, time_wall, match from task_match where taskid=?")
|
||||
(define-stmt q-count-task-match
|
||||
"select count(*) from task_match where taskid=?")
|
||||
|
||||
;; utils
|
||||
|
||||
|
|
@ -172,9 +175,7 @@
|
|||
(file->bytes path))
|
||||
|
||||
|
||||
(struct node-info [id name arch type resources online?] #:prefab)
|
||||
;; manifest is the raw source format
|
||||
(struct project-info [id name manifest complete?] #:prefab)
|
||||
;; rpc helpers
|
||||
|
||||
(define (get-nodes type)
|
||||
(define type-str (symbol->string type))
|
||||
|
|
@ -312,8 +313,26 @@
|
|||
|
||||
(define (get-projects)
|
||||
(enforce-subject 'client)
|
||||
|
||||
(define (get-progress id mf)
|
||||
(define parsed-mf (parse-manifest mf))
|
||||
(define total-size (manifest-psize parsed-mf))
|
||||
(define completed-size
|
||||
(for/sum ([(_1 _2 _3 pat-fasl) (in-query (current-db) q-get-task-log id)])
|
||||
(define sub (make-integer-set (fasl->s-exp pat-fasl)))
|
||||
(integer-set-count sub)))
|
||||
(/ completed-size total-size))
|
||||
|
||||
(for/list ([(id name manifest complete?) (in-query (current-db) q-get-tasks)])
|
||||
(project-info id name (fasl->s-exp manifest) complete?)))
|
||||
(define mf (fasl->s-exp manifest))
|
||||
;; XXX this should be a join t b h
|
||||
(define matches (query-value (current-db) q-count-task-match id))
|
||||
(define progress
|
||||
(if (zero? complete?)
|
||||
;; XXX this could also _maybe_ be a join but idk
|
||||
(get-progress id mf)
|
||||
1.0))
|
||||
(project-info id name mf progress matches)))
|
||||
|
||||
(define/contract (get-project-file taskid)
|
||||
(-> integer? bytes?)
|
||||
|
|
@ -321,7 +340,12 @@
|
|||
(with-handlers ([exn:fail? (lambda (ex) (error "unable to fetch the requested file"))])
|
||||
(server-get-file taskid)))
|
||||
|
||||
(define/contract (cancel-project taskid)
|
||||
(define/contract (get-project-matches taskid)
|
||||
(-> integer? (listof (listof integer?)))
|
||||
(for/list ([(worker time-wall match-fasl) (in-query (current-db) q-get-task-matches taskid)])
|
||||
(fasl->s-exp match-fasl)))
|
||||
|
||||
(define/contract (delete-project taskid)
|
||||
(-> integer? void?)
|
||||
(enforce-subject 'client)
|
||||
(call-with-transaction (current-db) (lambda ()
|
||||
|
|
|
|||
|
|
@ -23,12 +23,7 @@
|
|||
#include <stdint.h>
|
||||
#include <stdbool.h>
|
||||
|
||||
@;; TODO : make configurable
|
||||
@(define c-type "uint64_t")
|
||||
@(define c-type-fmt "%lx")
|
||||
|
||||
typedef @c-type vartype;
|
||||
typedef bool (*callback)( @(add-between (for/list ([_ (in-vector pattern)]) "vartype") ",") );
|
||||
#include "crossfire.h"
|
||||
|
||||
typedef struct {
|
||||
vartype start;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,31 @@
|
|||
@;; 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/>.
|
||||
|
||||
@;; vim: ft=c
|
||||
|
||||
#pragma once
|
||||
|
||||
#include <stdbool.h>
|
||||
#include <stdint.h>
|
||||
|
||||
typedef @c-type vartype;
|
||||
@(define args (add-between (for/list ([_ (in-vector pattern)]) "vartype") ","))
|
||||
typedef bool (*callback)( @args );
|
||||
|
||||
int crossfire_main(int argc, char* argv[], callback cb);
|
||||
|
||||
void cf_report_success( @args );
|
||||
Loading…
Reference in New Issue