diff --git a/crossfire/comms.rkt b/crossfire/comms.rkt new file mode 100644 index 0000000..278971d --- /dev/null +++ b/crossfire/comms.rkt @@ -0,0 +1,188 @@ +#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 . + +(require racket/bool racket/engine racket/fasl racket/match racket/tcp + "not-crypto.rkt") + +(struct msg [from-id] #:prefab) +(struct msg:hello msg [type pubkey] #:prefab) + +(struct signed [fasl signature] #:prefab) +(struct locked [fasl nonce mac] #:prefab) + +(define TIMEOUT 30) +(struct node [id name type pubkey seckey host port] #:transparent) + +(define (make-error str) + (exn:fail (format "error: ~a" str) (current-continuation-marks))) + +(define (thread-sendrecv to type data) + (thread-send to (cons (current-thread) (cons type data))) + (match (thread-receive) + [(? exn? e) (raise e)] + [x x])) + +(define (comms-event-loop my-node) + (define (peer-handshake el-thread in out) + (define eph-sk (crypto-key-exchange-make-key)) + (define eph-pk (crypto-key-exchange-public-key eph-sk)) + (define hello-msg (s-exp->fasl (msg:hello (node-id my-node) (node-type my-node) eph-pk))) + (s-exp->fasl (signed hello-msg + (crypto-sign (node-seckey my-node) (node-pubkey my-node) hello-msg)) out) + (flush-output out) + (match (fasl->s-exp in) + [(signed msg-signed signature) + (define msg (fasl->s-exp msg-signed)) + (match msg + [(msg:hello from-id type pubkey) + (define peer-data (thread-sendrecv el-thread 'get-node-info from-id)) + (when (false? peer-data) + (error "nonexistent peer tried to connect" from-id type pubkey)) + (unless (equal? type (node-type peer-data)) + (error "peer type mismatch" from-id type (node-type peer-data))) + (unless (crypto-check signature (node-pubkey peer-data) msg-signed) + (error "invalid signature received during handshake")) + (define session-key (crypto-key-exchange eph-sk pubkey)) + (crypto-wipe eph-sk) + (cons peer-data session-key)] + [_ (error "invalid message type recieved during handshake")])] + [_ (error "invalid data recieved during handshake")])) + + (define (peer-thread el-thread in out) + ;; run handshake process with a timeout + (match-define (cons peer-data session-key) + (let ([eng (engine (lambda (_) (peer-handshake el-thread in out)))]) + (if (engine-run (* 1000 TIMEOUT) eng) + (engine-result eng) + (begin (engine-kill eng) + (error "handshake timeout"))))) + + (displayln "handshake complete") + (displayln (format "negotiated ~s" session-key)) + (thread-sendrecv el-thread 'register-channel (node-id peer-data)) + + (define (handle-in-msg) + (match (fasl->s-exp in) + [(locked fasl nonce mac) + (match (crypto-unlock session-key nonce mac fasl) + [#f (error "corrupted message from peer" (node-id peer-data))] + [(? msg? m) + (unless (= (msg-from-id m) (node-id peer-data)) + (error "mismatched node id" (msg-from-id m) (node-id peer-data))) + (thread-sendrecv el-thread 'dispatch-msg (cons (node-id my-node) m))] + [_ (error "invalid data from peer" (node-id peer-data))])] + [_ (error "invalid data recieved from peer" (node-id peer-data))])) + + (define (handle-out-msg) + (match (thread-receive) + [(? msg? m) + (define fasl (s-exp->fasl m)) + (define nonce (crypto-lock-make-nonce)) + (define-values [ct mac] (crypto-lock session-key nonce fasl)) + (fasl->s-exp (locked ct nonce mac) out) + (flush-output out)] + [x (error "invalid thread msg" x)])) + + (let loop () + (match (sync (thread-receive-evt) in) + [(? input-port?) (handle-in-msg)] + [_ (handle-out-msg)]) + (loop)) + + (void)) + + (define (make-peer-thread el-thread ports-proc) + (define cust (make-custodian)) + (define new-thd + (parameterize ([current-custodian cust]) + (define-values [in out] (ports-proc)) + (thread (lambda () (peer-thread el-thread in out))))) + (thread (lambda () + (thread-wait new-thd) + (custodian-shutdown-all cust))) + new-thd) + + + (define el-thread (current-thread)) + (define peer-registry (make-hash)) + (define node-registry (make-hash)) + (hash-set! node-registry (node-id my-node) my-node) + + (define listener-thread #f) + + (define (handle-listen port) + (when (false? listener-thread) + (set! listener-thread + (thread + (lambda () + (define listener (tcp-listen port 4 #t)) + (let loop () + (make-peer-thread el-thread (lambda () (tcp-accept listener))) + (loop))))))) + + (define (handle-connect data) + (match-define (cons host port) data) + (make-peer-thread el-thread (lambda () (tcp-connect host port)))) + + (let loop () + (match-define (cons from (cons type data)) (thread-receive)) + (match type + ['listen (handle-listen data) (thread-send from (void))] + ['connect (handle-connect data) (thread-send from (void))] + ['get-node-info (thread-send from (hash-ref node-registry data (lambda () #f)))] + ['set-node-info (hash-set! node-registry (node-id data) data) (thread-send from (void))] + ['register-channel + (when (hash-has-key? peer-registry data) + (kill-thread (hash-ref peer-registry data))) + (hash-set! peer-registry data from) + (thread-send from (void))] + ['dispatch-msg + (match-define (cons peer-id msg) data) + (match (hash-ref peer-registry peer-id) + [#f (thread-send from (make-error "no such peer connection"))] + [thd (thread-send thd data) (thread-send from (void))])] + [_ (thread-send from (make-error "unknown thread message type"))]) + (loop))) + + +(define (make-comms my-node) + (thread (lambda () (comms-event-loop my-node)))) + +(define server-sk #"aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa") +(define server-pk (crypto-sign-public-key server-sk)) +(define client-sk #"bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb") +(define client-pk (crypto-sign-public-key client-sk)) + +(define server-node (node 0 "server" 'server server-pk server-sk "localhost" 1337)) +(define client-node (node 1 "client" 'client client-pk client-sk #f #f)) + +(require racket/cmdline) + +(define mode + (command-line #:args (mode) mode)) +(match mode + ["server" + (define comms (make-comms server-node)) + (thread-sendrecv comms 'set-node-info client-node) + (thread-sendrecv comms 'listen 1337)] + ["client" + (define comms (make-comms client-node)) + (thread-sendrecv comms 'set-node-info server-node) + (thread-sendrecv comms 'connect (cons "localhost" 1337))]) + +(sleep 9999)