begin network comms module

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 <https://www.gnu.org/licenses/>.
+
+(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)