714 lines
31 KiB
Racket
714 lines
31 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 racket/async-channel racket/bool racket/engine racket/fasl racket/function racket/list
|
|
racket/logging racket/match racket/tcp racket/unit syntax/parse/define
|
|
(for-syntax racket/base racket/list racket/syntax racket/unit racket/unit-exptime)
|
|
"logging.rkt" "not-crypto.rkt" (submod "static-support.rkt" misc-calls))
|
|
|
|
;; logging!
|
|
(define-logger comms #:parent global-logger)
|
|
(define-logger tm #:parent global-logger)
|
|
|
|
;; define message types (they must all be prefab for fasl)
|
|
(struct msg [from-id] #:prefab)
|
|
(struct msg:hello msg [type pubkey] #:prefab)
|
|
(struct msg:meow msg [meow] #:prefab)
|
|
(struct msg:stream msg [trans-id] #:prefab)
|
|
(struct msg:transaction msg:stream [request? rpc-id data] #:prefab)
|
|
(struct msg:file-token msg:stream [size] #:prefab)
|
|
(struct msg:file-request msg:stream [offset] #:prefab)
|
|
(struct msg:file msg:stream [offset data] #:prefab)
|
|
|
|
;; frontend file transfer types
|
|
;; id: transaction id
|
|
;; port: an input port if local
|
|
;; chan: an async-channel if nonlocal
|
|
(struct file-transfer [id])
|
|
(struct file-transfer:local file-transfer [port progress])
|
|
(struct file-transfer:remote file-transfer [chan size])
|
|
(define (make-file-transfer port [progress void])
|
|
(unless (current-trans-id)
|
|
(error "not in a transaction!"))
|
|
(file-transfer:local (current-trans-id) port progress))
|
|
(define (make-nonlocal-file-transfer trans-id size)
|
|
(file-transfer:remote trans-id (make-async-channel) size))
|
|
;; connects a remote file transfer to an output port
|
|
;; but also errors if there was an error
|
|
(define (file-transfer-connect ft out-port [progress void])
|
|
(define total (file-transfer:remote-size ft))
|
|
(let loop ([written 0])
|
|
(progress written total)
|
|
(match (async-channel-get (file-transfer:remote-chan ft))
|
|
[(== eof) (progress total total)]
|
|
[(? bytes? b) (write-bytes b out-port)
|
|
(loop (+ written (bytes-length b)))]
|
|
[(? exn:fail? e) (raise e)]
|
|
[x (error "unexpected file transfer data" x)])))
|
|
(define file-transfer-size file-transfer:remote-size)
|
|
(provide make-file-transfer file-transfer-connect file-transfer-size file-transfer?)
|
|
|
|
;; signed and encrypted messages (wrapped in another layer of fasl because i'm lazy)
|
|
(struct signed [fasl signature] #:prefab)
|
|
(struct locked [fasl nonce mac] #:prefab)
|
|
|
|
;; 30 second timeout to execute the handshake, or the connection will be aborted
|
|
;; once the handshake is complete, the connection can stay open indefinitely with an indefinite
|
|
;; time between messages
|
|
(define *handshake-timeout* 30)
|
|
(define *transaction-timeout* 30)
|
|
(define *shutdown-timeout* 5)
|
|
|
|
;; interval to resend requests if no data
|
|
(define *file-transfer-soft-timeout* 30)
|
|
;; error out the file transfer if no data was transferred within this time
|
|
;; fairly long because idk slow internet connections and such
|
|
(define *file-transfer-idle-timeout* 600)
|
|
(define *file-transfer-chunk-size* 131072)
|
|
|
|
;; node info (not all fields will always be present)
|
|
;; type: 'server 'agent 'client
|
|
(struct node [id name type pubkey seckey host port] #:prefab)
|
|
(provide (struct-out node))
|
|
|
|
;; creates an exn:fail to be passed by thread mailbox
|
|
(define (make-error str)
|
|
(exn:fail (format "error: ~a" str) (current-continuation-marks)))
|
|
|
|
;; sends a message to the specified thread, and retrieves a response
|
|
;; if the response is an exn, raises it
|
|
(define (thread-sendrecv to type data)
|
|
(thread-send to (cons (current-thread) (cons type data)))
|
|
(match (thread-receive)
|
|
[(? exn? e) (raise e)]
|
|
[x x]))
|
|
|
|
;; runs the communications platform for a node
|
|
;; initially, a node object describing the local node is required
|
|
;; information about other nodes can be added after startup
|
|
;; uses thread mailboxes to process and respond to messages sequentially, which might include
|
|
;; mutating internal data (hence the serialization of operations from the mailbox, to avoid races)
|
|
(define (comms-event-loop my-node startup-thd)
|
|
;; this thread
|
|
(define el-thread (current-thread))
|
|
(current-comms el-thread)
|
|
|
|
;; performs a handshake with a new peer connection
|
|
;; raises exn:fail if any part of the handshake fails
|
|
(define (peer-handshake in out)
|
|
;; generate ephemeral keys for key exchange
|
|
(define eph-sk (crypto-key-exchange-make-key))
|
|
(define eph-pk (crypto-key-exchange-public-key eph-sk))
|
|
;; create a hello msg, containing our node meta and the ephemeral public key
|
|
(define hello-msg (s-exp->fasl (msg:hello (node-id my-node) (node-type my-node) eph-pk)))
|
|
;; sign the hello message using our node signing key
|
|
;; then send it
|
|
(s-exp->fasl (signed hello-msg
|
|
(crypto-sign (node-seckey my-node) (node-pubkey my-node) hello-msg)) out)
|
|
(flush-output out)
|
|
;; recieve the hello message from the other side
|
|
(match (fasl->s-exp in)
|
|
;; verify that it's a signed message, with the expected node key signature
|
|
[(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)))
|
|
;; check signature (the important part)
|
|
(unless (crypto-check signature (node-pubkey peer-data) msg-signed)
|
|
(error "invalid signature received during handshake"))
|
|
;; derive session key
|
|
(define session-key (crypto-key-exchange eph-sk pubkey))
|
|
;; wipe ephemeral secret key -- no need for it anymore
|
|
(crypto-wipe eph-sk)
|
|
(cons peer-data session-key)]
|
|
[_ (error "invalid message type recieved during handshake")])]
|
|
[_ (error "invalid data recieved during handshake")]))
|
|
|
|
;; encapsulates a message queue for one peer connection
|
|
;; sends and recieves encrypted data using the session key
|
|
(define (peer-thread peer-data session-key in out local-msg-channel)
|
|
(define run-queue #t)
|
|
|
|
;; handles tcp data in
|
|
(define (handle-in-msg)
|
|
(match (with-handlers ([exn:fail? (lambda (_) #f)]) (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))]
|
|
[data
|
|
(match (fasl->s-exp data)
|
|
[(? msg? m)
|
|
(unless (= (msg-from-id m) (node-id peer-data))
|
|
(error "mismatched node id" (msg-from-id m) (node-id peer-data)))
|
|
(async-channel-put local-msg-channel m)]
|
|
[_ (error "invalid msg data from peer" (node-id peer-data))])])]
|
|
[#f ;; likely EOF. could also be invalid fasl data that could not be deserialized
|
|
;; in either case, close the connection. there's not much else we can do
|
|
(set! run-queue #f)]
|
|
[_ (error "invalid data recieved from peer" (node-id peer-data))]))
|
|
|
|
;; handles a thread queue message to tcp out
|
|
(define (handle-out-msg)
|
|
(match (thread-receive)
|
|
[(? msg? m)
|
|
(define fasl (s-exp->fasl m))
|
|
;; use a random nonce each time
|
|
;; this doesn't need to be cryptographically secure RNG but we use it anyway, can't hurt
|
|
(define nonce (crypto-lock-make-nonce))
|
|
(define-values [ct mac] (crypto-lock session-key nonce fasl))
|
|
(s-exp->fasl (locked ct nonce mac) out)
|
|
(flush-output out)]
|
|
['stop (set! run-queue #f)]
|
|
[x (error "invalid thread msg" x)]))
|
|
|
|
;; handle mailbox <-> tcp
|
|
(let loop ()
|
|
(match (sync (thread-receive-evt) in)
|
|
[(? input-port?) (handle-in-msg)]
|
|
[_ (handle-out-msg)])
|
|
(when run-queue (loop))))
|
|
|
|
;; synchronously performs ports-proc to retrieve a new set of tcp ports, and a handshake
|
|
;; then starts a peer thread and a peer thread cleanup monitor
|
|
;; this cannot be run synchronously on the main loop because it does a thread-sendrecv
|
|
(define (make-peer-thread ports-proc local-msg-channel [cust (make-custodian)])
|
|
(define-values [new-thd peer-data session-key]
|
|
(parameterize ([current-custodian cust])
|
|
(define-values [in out] (ports-proc))
|
|
|
|
;; run handshake process with a timeout
|
|
(match-define (cons peer-data session-key)
|
|
;; engines are cool
|
|
;; we use an engine to limit runtime for the handshake
|
|
(let ([eng (engine (lambda (_) (peer-handshake in out)))])
|
|
(if (engine-run (* 1000 *handshake-timeout*) eng)
|
|
(engine-result eng)
|
|
(begin (engine-kill eng) (error "handshake timeout")))))
|
|
|
|
(values
|
|
(thread (lambda () (peer-thread peer-data session-key in out local-msg-channel)))
|
|
peer-data
|
|
session-key)))
|
|
|
|
(thread-sendrecv el-thread 'register-channel (cons (node-id peer-data) new-thd))
|
|
(log-comms-info "new node connection: ~a" (node-id peer-data))
|
|
|
|
;; monitor thread -- shuts down the custodian once the peer thread is done
|
|
(thread (lambda ()
|
|
(thread-wait new-thd)
|
|
(custodian-shutdown-all cust)
|
|
(crypto-wipe session-key)
|
|
(with-handlers ([exn:fail? void])
|
|
(thread-sendrecv el-thread 'deregister-channel (node-id peer-data)))))
|
|
new-thd)
|
|
|
|
;; async channel for messages sent to the local node
|
|
(define local-msg-channel (make-async-channel))
|
|
;; map of peer channels that are currently active
|
|
(define peer-registry (make-hash))
|
|
;; map of all known nodes
|
|
(define node-registry (make-hash))
|
|
;; insert ourselves, to start
|
|
(hash-set! node-registry (node-id my-node) my-node)
|
|
|
|
;; tcp listener, if this is a server
|
|
(define listener #f)
|
|
(define listener-thd #f)
|
|
|
|
(define run-comms #t)
|
|
|
|
;; starts the tcp listener
|
|
(define (handle-listen from port)
|
|
(with-handlers ([exn:fail? (lambda (ex) (thread-send from ex #f))])
|
|
(when (false? listener-thd)
|
|
(set! listener (tcp-listen port 4 #t))
|
|
(log-comms-info "listening on port ~a" port)
|
|
(set! listener-thd
|
|
(thread
|
|
(lambda ()
|
|
(define (cleanup) (set! listener-thd #f))
|
|
(with-handlers ([exn? (lambda (ex) (cleanup) (raise ex))])
|
|
(let loop ()
|
|
(make-peer-thread (lambda () (tcp-accept listener)) local-msg-channel)
|
|
(loop))))))
|
|
(thread-send from (void) #f))))
|
|
|
|
;; starts a connection and handshake process
|
|
;; calls back to from once the handshake is complete and the queue thread is registered
|
|
(define (handle-connect from id)
|
|
(thread
|
|
(lambda ()
|
|
(with-handlers ([exn:fail? (lambda (ex) (thread-send from ex #f))])
|
|
(match (hash-ref node-registry id #f)
|
|
[#f (thread-send from (make-error (format "no such node ~a" id)) #f)]
|
|
[(node id name type pubkey seckey host port)
|
|
(when (and host port)
|
|
(make-peer-thread (lambda () (tcp-connect host port)) local-msg-channel))
|
|
(thread-send from (void) #f)])))))
|
|
|
|
;; notify that startup is done
|
|
(thread-send startup-thd 'done #f)
|
|
(set! startup-thd #f)
|
|
|
|
;; main comms loop -- responds to thread mailbox items and peforms serialized data manipulation
|
|
(let loop ()
|
|
(match-define (cons from (cons type data)) (thread-receive))
|
|
(match type
|
|
;; this call doesn't return until there's an active listening socket. listen errors are
|
|
;; forwarded to the caller
|
|
['listen (handle-listen from data)]
|
|
;; likewise, once this call returns the peer handshake has completed and the queue thread is
|
|
;; active, and can be destroyed with destroy-channel
|
|
;; this call is guaranteed to return within max(HANDSHAKE-TIMEOUT, system tcp connect timeout)
|
|
['connect (handle-connect from data)]
|
|
['channel-available?
|
|
(thread-send
|
|
from (or (= data (node-id my-node)) (hash-has-key? peer-registry data) #f))]
|
|
['get-node-info (thread-send from (hash-ref node-registry data #f) #f)]
|
|
['set-node-info (hash-set! node-registry (node-id data) data) (thread-send from (void) #f)]
|
|
;; also call destroy-channel
|
|
['raw-delete-node (hash-remove! node-registry data) (thread-send from (void) #f)]
|
|
['register-channel
|
|
(match-define (cons peer-id thd) data)
|
|
(when (hash-has-key? peer-registry peer-id)
|
|
(kill-thread (hash-ref peer-registry peer-id)))
|
|
(hash-set! peer-registry peer-id thd)
|
|
(thread-send from (void) #f)]
|
|
;; remove channel, don't kill thread
|
|
['deregister-channel
|
|
(hash-remove! peer-registry data) (thread-send from (void) #f)]
|
|
;; remove channel, kill thread
|
|
['destroy-channel
|
|
(match (hash-ref peer-registry data #f)
|
|
[#f (void)]
|
|
[thd (thread-send thd 'stop #f)
|
|
(sync/timeout *shutdown-timeout* thd)
|
|
(kill-thread thd)
|
|
(hash-remove! peer-registry data)])
|
|
(thread-send from (void) #f)]
|
|
;; if this call forwards an exn:fail, it means the queue thread for this peer is dead, so you
|
|
;; need to either wait for the peer to reconnect if this is a server, or initiate a new
|
|
;; connect call if this is a client
|
|
;;
|
|
;; why is this a potentially-erroring call instead of another async channel?
|
|
;; if a sent message fails i wanted the sender to be notified as quickly as possible so the
|
|
;; sender can implement whatever retry or drop behavior is necessary based on the priority of
|
|
;; the message. i don't want the message to be sitting in an opaque retry queue forever
|
|
;;
|
|
;; note: for transactional behavior, implement a timeout. the remote node could fail to
|
|
;; respond ever, or might decide to force close the connection right as the message is being
|
|
;; transferred, in which case you wouldn't be notified that it failed
|
|
['dispatch-msg
|
|
(match-define (cons peer-id msg) data)
|
|
(if (= peer-id (node-id my-node))
|
|
(begin (async-channel-put local-msg-channel msg)
|
|
(thread-send from (void) #f))
|
|
(match (hash-ref peer-registry peer-id #f)
|
|
[#f (thread-send from (make-error "no such peer connection") #f)]
|
|
[thd
|
|
(match (thread-send thd msg #f)
|
|
[#f (kill-thread thd) (hash-remove! peer-registry peer-id)
|
|
(thread-send from (make-error "failed to dispatch to thread") #f)]
|
|
[_ (thread-send from (void) #f)])]))]
|
|
;; retrieves an async channel with the local received message queue
|
|
;; this can be used to fetch new messages without further interacting with the comms thread
|
|
['local-channel (thread-send from local-msg-channel #f)]
|
|
['shutdown
|
|
(for ([(_ thd) (in-hash peer-registry)])
|
|
(thread-send thd 'stop #f)
|
|
(sync/timeout *shutdown-timeout* thd)
|
|
(kill-thread thd))
|
|
(when listener-thd
|
|
(kill-thread listener-thd)
|
|
(tcp-close listener))
|
|
(set! run-comms #f)
|
|
(thread-send from (void) #f)]
|
|
[_ (thread-send from (make-error "unknown thread message type") #f)])
|
|
(when run-comms
|
|
(loop))))
|
|
|
|
;; creates the comms thread
|
|
(define (make-comms my-node)
|
|
(define this-thread (current-thread))
|
|
(define comms (thread (lambda () (comms-event-loop my-node this-thread))))
|
|
(thread-receive) ;; wait for startup
|
|
comms)
|
|
|
|
(define (comms-listen comms port)
|
|
(thread-sendrecv comms 'listen port))
|
|
|
|
(define (comms-connect comms id)
|
|
(thread-sendrecv comms 'connect id))
|
|
|
|
(define (comms-set-node-info comms info)
|
|
(thread-sendrecv comms 'set-node-info info))
|
|
|
|
(define (comms-get-node-info comms id)
|
|
(thread-sendrecv comms 'get-node-info id))
|
|
|
|
(define (comms-delete-node comms id)
|
|
(thread-sendrecv comms 'destroy-channel id)
|
|
(thread-sendrecv comms 'raw-delete-node id))
|
|
|
|
(define (comms-local-channel comms)
|
|
(thread-sendrecv comms 'local-channel (void)))
|
|
|
|
(define (comms-dispatch-msg comms to-id msg)
|
|
(thread-sendrecv comms 'dispatch-msg (cons to-id msg)))
|
|
|
|
(define (comms-channel-available? comms ch-id)
|
|
(thread-sendrecv comms 'channel-available? ch-id))
|
|
|
|
(define (comms-shutdown comms)
|
|
(thread-sendrecv comms 'shutdown (void)))
|
|
|
|
|
|
(define (comms-dispatch-msg/retry comms to-id msg [tries 3] [retry-delay 2])
|
|
(define (do-retry ex)
|
|
(when (<= tries 0)
|
|
(raise ex))
|
|
(sleep retry-delay)
|
|
(comms-dispatch-msg/retry comms to-id msg (sub1 tries) retry-delay))
|
|
(define maybe-exn
|
|
(with-handlers ([exn:fail? identity])
|
|
(unless (comms-channel-available? comms to-id)
|
|
(comms-connect comms to-id))
|
|
(comms-dispatch-msg comms to-id msg)
|
|
#f))
|
|
(when maybe-exn
|
|
(do-retry maybe-exn)))
|
|
|
|
(provide make-comms comms-listen comms-connect comms-get-node-info comms-set-node-info
|
|
comms-delete-node comms-channel-available? comms-shutdown)
|
|
|
|
;; transactional messages support
|
|
|
|
(define (transaction-manager my-node comms startup-thd)
|
|
(current-tm (current-thread))
|
|
(define run-tm #t)
|
|
(define trans-id 0)
|
|
|
|
(define local-channel (comms-local-channel comms))
|
|
(define rpc-table (make-hash))
|
|
(define dispatch-table (make-weak-hash))
|
|
|
|
(define (dispatch-table-add! node-id stream-id [thd (current-thread)])
|
|
(define id (cons node-id stream-id))
|
|
(define eph (make-ephemeron thd (cons thd id)))
|
|
(hash-set! dispatch-table thd eph))
|
|
|
|
(define (dispatch-table-dispatch node-id stream-id msg)
|
|
(for ([v (in-list (hash-values dispatch-table))])
|
|
(match (ephemeron-value v)
|
|
[(cons thd (cons (== node-id) (== stream-id)))
|
|
(thread-send thd msg #f)]
|
|
;; GC or no match
|
|
[_ (void)])))
|
|
|
|
(define (dispatch-table-all-threads)
|
|
(map car (filter identity (map ephemeron-value (hash-values dispatch-table)))))
|
|
|
|
(define tm-thread (current-thread))
|
|
(define tm-cust (make-custodian))
|
|
|
|
(define (make-trans-id)
|
|
(set! trans-id (add1 trans-id))
|
|
trans-id)
|
|
|
|
(define (cleanup)
|
|
(define thds (dispatch-table-all-threads))
|
|
(map break-thread thds)
|
|
(apply sync/timeout *transaction-timeout* thds)
|
|
(custodian-shutdown-all tm-cust))
|
|
|
|
(define (trans-data-serialize data)
|
|
(match data
|
|
[(? exn?)
|
|
(define-values (ty _) (struct-info data))
|
|
(define-values (name _2 _3 _4 _5 _6 _7 _8) (struct-type-info ty))
|
|
`(exn ,name ,(exn-message data))]
|
|
[x x]))
|
|
|
|
(define (trans-data-deserialize data)
|
|
(match data
|
|
;; try to pretty strictly make sure this is an exn: subtype because we use eval to resolve
|
|
;; the binding and call it -- we don't want this to be used to call arbitrary functions
|
|
[(list 'exn (and (? symbol? name) (app symbol->string (pregexp #px"^exn(:.*?[^\\?])?$")))
|
|
(? string? message))
|
|
;; for good measure, create a new empty namespace for the exn type lookup
|
|
(define constructor (parameterize ([current-namespace (make-base-namespace)])
|
|
(eval name)))
|
|
(constructor message (current-continuation-marks))]
|
|
[x x]))
|
|
|
|
(define (handle-remote-ft from-thd to-id trans-id size)
|
|
(log-tm-info "downloading file ~a" trans-id)
|
|
(define ft-obj (make-nonlocal-file-transfer trans-id size))
|
|
(define ft-chan (file-transfer:remote-chan ft-obj))
|
|
(thread-send from-thd ft-obj #f)
|
|
(with-handlers ([exn:fail? (lambda (ex) (async-channel-put ft-chan ex))]
|
|
[exn:break?
|
|
(lambda (_)
|
|
(async-channel-put ft-chan (make-error "transaction manager shutdown")))])
|
|
(let loop ([offs 0]
|
|
[last-hard-time (current-seconds-monotonic)]
|
|
[last-soft-time (current-seconds-monotonic)])
|
|
(define evt (thread-receive-evt))
|
|
(define now (current-seconds-monotonic))
|
|
(define hard-timeout (- (+ now *file-transfer-idle-timeout*) last-hard-time))
|
|
(define soft-timeout (- (+ now *file-transfer-soft-timeout*) last-soft-time))
|
|
(match (sync/timeout (min hard-timeout soft-timeout) evt)
|
|
[#f (cond
|
|
[(< hard-timeout soft-timeout)
|
|
(log-tm-warning "file transfer hard timeout ~a" trans-id)
|
|
(async-channel-put ft-chan (make-error "file transfer timeout"))
|
|
(kill-thread (current-thread))]
|
|
[else
|
|
(comms-dispatch-msg/retry comms to-id
|
|
(msg:file-request (node-id my-node) trans-id offs))
|
|
(loop offs last-hard-time (current-seconds-monotonic))])]
|
|
[(== evt)
|
|
(match (thread-receive)
|
|
[(msg:file _ _ (== offs) (? bytes? data))
|
|
(async-channel-put ft-chan data)
|
|
(define now (current-seconds-monotonic))
|
|
(define next-offs (+ offs (bytes-length data)))
|
|
(unless (= next-offs size)
|
|
(loop next-offs now now))]
|
|
[(msg:file _ _ _ _)
|
|
(comms-dispatch-msg/retry comms to-id
|
|
(msg:file-request (node-id my-node) trans-id offs))
|
|
(define now (current-seconds-monotonic))
|
|
(loop offs now now)]
|
|
[x (log-tm-warning "remote file transfer ~a send invalid msg ~a" trans-id x)])]))
|
|
(comms-dispatch-msg/retry comms to-id (msg:file-request (node-id my-node) trans-id #f))
|
|
(async-channel-put ft-chan eof)
|
|
(log-tm-info "remote file transfer ~a complete" trans-id)))
|
|
|
|
(define (recv-transaction from to-id trans-id rpc-id transaction)
|
|
(break-enabled #t)
|
|
(with-handlers ([exn:fail? (lambda (ex) (thread-send from ex #f))]
|
|
[exn:break? (lambda (_)
|
|
(thread-send
|
|
from (make-error "transaction manager shutdown") #f))])
|
|
(comms-dispatch-msg/retry comms to-id transaction)
|
|
(match (sync/timeout *transaction-timeout* (thread-receive-evt))
|
|
[#f
|
|
(log-tm-error "timeout sending transaction to ~a" to-id)
|
|
(thread-send from (make-error "transaction timeout") #f)]
|
|
[_
|
|
(match (thread-receive)
|
|
[(msg:transaction _ _ #f (== rpc-id) response)
|
|
(thread-send from (trans-data-deserialize response) #f)]
|
|
[(msg:file-token _ _ size) (handle-remote-ft from to-id trans-id size)]
|
|
[x (error "got invalid response data" x)])])))
|
|
|
|
(define (send-transaction from to-id rpc-id rpc-data)
|
|
(define trans-id (make-trans-id))
|
|
(define transaction (msg:transaction (node-id my-node) trans-id #t rpc-id
|
|
(trans-data-serialize rpc-data)))
|
|
(define response-thread
|
|
(thread (lambda () (recv-transaction from to-id trans-id rpc-id transaction))))
|
|
(dispatch-table-add! to-id trans-id response-thread))
|
|
|
|
(define (handle-local-ft from-id trans-id port progress)
|
|
(break-enabled #t)
|
|
(log-tm-info "starting file transfer ~a" trans-id)
|
|
;; TODO : on break, notify the remote endpoint that we're shutting down
|
|
;; it's not super important, remote will time out eventually
|
|
(with-handlers ([exn? (lambda (ex) (close-input-port port) (raise ex))])
|
|
;; only supported for file and string ports
|
|
;; but we do need to know the length beforehand, and the ability to seek
|
|
(file-position port eof)
|
|
(define port-len (file-position port))
|
|
(comms-dispatch-msg/retry comms from-id (msg:file-token (node-id my-node) trans-id port-len))
|
|
(define bstr (make-bytes *file-transfer-chunk-size*))
|
|
(let loop ([offs 0])
|
|
(progress offs port-len)
|
|
(define thread-evt (thread-receive-evt))
|
|
(define port-evt (if offs port never-evt))
|
|
(match (sync/timeout *file-transfer-idle-timeout* port-evt thread-evt)
|
|
[#f (log-tm-warning "file transfer ~a hit timeout" trans-id)]
|
|
[(== port)
|
|
(file-position port offs)
|
|
(match (read-bytes-avail! bstr port)
|
|
[(== eof)
|
|
(log-tm-info "file transfer ~a waiting for confirmation" trans-id)
|
|
(loop #f)]
|
|
[n (comms-dispatch-msg/retry
|
|
comms from-id (msg:file (node-id my-node) trans-id offs (subbytes bstr 0 n)))
|
|
(loop (+ offs n))])]
|
|
[(== thread-evt)
|
|
(match (thread-receive)
|
|
[(msg:file-request _ _ #f) (log-tm-info "file transfer ~a complete" trans-id)]
|
|
[(msg:file-request _ _ new-offs) (loop new-offs)]
|
|
[x (log-tm-warning "invalid data during file transfer ~a" x) (loop offs)])]))
|
|
(void)))
|
|
|
|
(define (handle-incoming-transaction func msg)
|
|
(match-define (msg:transaction from-id trans-id _ rpc-id rpc-data) msg)
|
|
|
|
(define (respond data)
|
|
(match data
|
|
[(file-transfer:local id port progress)
|
|
(handle-local-ft from-id trans-id port progress)]
|
|
[_ (define resp
|
|
(msg:transaction (node-id my-node) trans-id #f rpc-id (trans-data-serialize data)))
|
|
(with-handlers ([exn:fail?
|
|
(lambda (ex)
|
|
(logging-report-error ex "failed to send transaction response"))])
|
|
(comms-dispatch-msg/retry comms from-id resp))]))
|
|
|
|
(respond
|
|
(with-handlers ([exn:fail? identity])
|
|
(define arg-data (trans-data-deserialize rpc-data))
|
|
(define result
|
|
(parameterize ([current-from-node (comms-get-node-info comms from-id)]
|
|
[current-trans-id trans-id])
|
|
;; TODO : apply timeout on the handler function?
|
|
;; we don't want this thread to potentially hang forever if there's some sort of
|
|
;; deadlock
|
|
(apply func arg-data)))
|
|
result)))
|
|
|
|
(define (handle-thread-msg)
|
|
(match-define (cons from (cons type data)) (thread-receive))
|
|
(match type
|
|
['register-rpc (hash-set! rpc-table (car data) (cdr data))
|
|
(thread-send from (void) #f)]
|
|
['deregister-rpc (hash-remove! rpc-table data)
|
|
(thread-send from (void) #f)]
|
|
['transact
|
|
(match-define (cons to-id (cons rpc-id rpc-data)) data)
|
|
(send-transaction from to-id rpc-id rpc-data)]
|
|
['shutdown (set! run-tm #f) (cleanup) (thread-send from (void) #f)]
|
|
[_ (thread-send from (make-error "invalid transaction thread msg") #f)]))
|
|
|
|
(define (handle-incoming msg)
|
|
(match msg
|
|
[(msg:transaction from-id trans-id #t rpc-id rpc-data)
|
|
(match (hash-ref rpc-table rpc-id #f)
|
|
[#f (log-tm-warning "got unknown rpc req: ~a" msg)]
|
|
[func
|
|
(define thd (thread (lambda () (handle-incoming-transaction func msg))))
|
|
(dispatch-table-add! from-id trans-id thd)])]
|
|
[(msg:stream from-id trans-id)
|
|
(dispatch-table-dispatch from-id trans-id msg)]
|
|
[_ (log-tm-warning "got unknown msg: ~a" msg)]))
|
|
|
|
;; it's a thread cell and i'm too lazy to add a parameterize clause... it should work
|
|
(current-custodian tm-cust)
|
|
;; notify that startup is done
|
|
(thread-send startup-thd 'done #f)
|
|
(set! startup-thd #f)
|
|
|
|
(let loop ()
|
|
(define thd-evt (thread-receive-evt))
|
|
(match (sync thd-evt local-channel)
|
|
[(? (curry equal? thd-evt)) (handle-thread-msg)]
|
|
[x (handle-incoming x)])
|
|
(when run-tm (loop))))
|
|
|
|
(define (make-transaction-manager my-node comms)
|
|
(define this-thread (current-thread))
|
|
(define tm (thread (lambda () (transaction-manager my-node comms this-thread))))
|
|
;; wait for startup
|
|
(thread-receive)
|
|
tm)
|
|
|
|
(define (tm-register-rpc tm name func)
|
|
(thread-sendrecv tm 'register-rpc (cons name func)))
|
|
|
|
(define (tm-deregister-rpc tm name)
|
|
(thread-sendrecv tm 'deregister-rpc name))
|
|
|
|
(define (tm-transact tm to-id rpc-id rpc-data)
|
|
(thread-sendrecv tm 'transact (cons to-id (cons rpc-id rpc-data))))
|
|
|
|
(define (tm-shutdown tm)
|
|
(thread-sendrecv tm 'shutdown (void)))
|
|
|
|
(provide make-transaction-manager tm-register-rpc tm-deregister-rpc tm-transact tm-shutdown)
|
|
|
|
|
|
;; utility functions and macros for defining rpcs
|
|
|
|
;; parameters for comms, tm, and targeted node
|
|
;; TODO : make these default parameters for all the wrapper functions?
|
|
(define current-comms (make-parameter #f))
|
|
(define current-tm (make-parameter #f))
|
|
(define current-to-node (make-parameter #f))
|
|
(define current-from-node (make-parameter #f))
|
|
(define current-trans-id (make-parameter #f))
|
|
|
|
|
|
;; this is entirely a proc macro because idk how to do this in any fancier way
|
|
;; big weh
|
|
;; also macro expanding the results of macros is pretty wack because if racket/unit is not required
|
|
;; in this file, racket assumes "unit" refers to a runtime procedure instead of a macro and proceeds
|
|
;; to expand the "arguments" to it, so you end up with weird errors like "define not permitted in
|
|
;; expression context" and "illegal usage of <sig>^" which only make sense once you realize that's
|
|
;; what's going on
|
|
;; u__u
|
|
(define-for-syntax (rpc-wrapper-unit-helper sig-name)
|
|
(define-values [parent members vars stxs] (signature-members sig-name sig-name))
|
|
(define unit-out
|
|
#`(unit
|
|
(import)
|
|
(export #,sig-name)
|
|
#,@(for/list ([mem (in-list members)])
|
|
#`(define (#,mem . args)
|
|
;; breaks off (there's a hard timeout of 30s, so the break will be delivered
|
|
;; eventually)
|
|
(parameterize-break #f
|
|
(tm-transact (current-tm) (node-id (current-to-node)) (quote #,mem) args))))))
|
|
unit-out)
|
|
|
|
;; this creates a wrapper unit for the given signature that delegates to the transaction manager
|
|
;; (current-tm) using (current-to-node)
|
|
;; (define-signature mastodon^ [make-post florp eat-hot-chip lie])
|
|
;; (define wrapper@ (make-rpc-wrapper-unit mastodon^))
|
|
;; (define-values/invoke-unit wrapper@ (import) (export mastodon^))
|
|
(define-syntax make-rpc-wrapper-unit
|
|
(lambda (stx)
|
|
(rpc-wrapper-unit-helper (second (syntax-e stx)))))
|
|
|
|
;; same thing but for registering impls
|
|
(define-for-syntax (rpc-register-all-helper sig-name unit-def)
|
|
(define-values [parent members vars stxs] (signature-members sig-name sig-name))
|
|
(define code-out
|
|
#`((lambda ()
|
|
(define-values/invoke-unit #,unit-def (import) (export #,sig-name))
|
|
#,@(for/list ([mem (in-list members)])
|
|
#`(tm-register-rpc (current-tm) (quote #,mem) #,mem)))))
|
|
code-out)
|
|
|
|
;; register everything from a signature and unit
|
|
(define-syntax rpc-register-all
|
|
(lambda (stx)
|
|
(define parts (syntax-e stx))
|
|
(rpc-register-all-helper (second parts) (third parts))))
|
|
|
|
(provide current-comms current-tm current-to-node current-from-node
|
|
make-rpc-wrapper-unit rpc-register-all)
|