Skip to content
Browse files

Add peer registry

  • Loading branch information
borodust committed Apr 18, 2017
1 parent bbf0592 commit 4b9fc4cc77426b9b604f1df6679324cfa2d4640d
Showing with 94 additions and 31 deletions.
  1. +4 −2 mortar-combat.asd
  2. +7 −0 proxy/arena.lisp
  3. +0 −5 proxy/context.lisp
  4. +53 −0 proxy/peer.lisp
  5. +24 −24 proxy/proxy.lisp
  6. +6 −0 proxy/utils.lisp
@@ -43,10 +43,12 @@
:mailto ""
:license "GPLv3"
:depends-on (log4cl cl-muth cl-conspack usocket flexi-streams
cl-bodge/engine cl-bodge/utils)
cl-bodge/engine cl-bodge/utils ironclad uuid)
:serial t
:pathname "proxy/"
:components ((:file "packages")
(:file "context")
(:file "utils")
(:file "arena")
(:file "peer")
(:file "proxy")
(:file "commands")))
@@ -0,0 +1,7 @@
(in-package :mortar-combat.proxy)

(defclass arena ()

This file was deleted.

@@ -0,0 +1,53 @@
(in-package :mortar-combat.proxy)

(defclass peer ()
((id :initarg :id :reader id-of)
(name :initarg :name :reader name-of)
(info-connection :initarg :info-connection :reader info-connection-of)
(proxy-connection :initform nil :reader proxy-connection-of)))

(defclass peer-registry ()
((peer-table :initform (make-hash-table :test #'equal))
(peer-by-id :initform (make-hash-table :test #'equal))))

(defun register-peer (registry connection name)
(with-slots (peer-table peer-by-id) registry
(with-hash-entries ((info connection)
(peer-by-name name))
(when info
(error "Peer was already registered for provided connection ~A" info))
(when peer-by-name
(error "Peer with name ~A exists" name))
(let* ((id (loop for id = (make-random-uuid)
while (gethash id peer-by-id)
finally (return id)))
(peer (make-instance 'peer
:id id
:name name
:info-connection connection)))
(setf info peer
name peer
(gethash id peer-by-id) peer)

(defun find-peer-by-property (registry value)
(with-slots (peer-table) registry
(gethash value peer-table)))

(defun find-peer-by-id (registry id)
(with-slots (peer-by-id) registry
(gethash id peer-by-id)))

(defun update-peer-proxy-connection (registry peer proxy-connection)
(with-slots (peer-table) registry
(with-slots ((peer-proxy proxy-connection)) peer
(remhash (proxy-connection-of peer) peer-table)
(setf peer-proxy proxy-connection
(gethash proxy-connection peer-table) peer))))
@@ -1,5 +1,6 @@
(in-package :mortar-combat.proxy)

(declaim (special *peer*))

(defvar *main-latch* (mt:make-latch))

@@ -17,61 +18,60 @@

(defclass mortar-combat-proxy (enableable generic-system)
((proxy-socket :initform nil)
(socket-table :initform (make-hash-table))
(peer-registry :initform (make-instance 'peer-registry) :reader peer-registry-of)
(arenas :initform (make-hash-table :test #'equal))
(routing-buffer :initform (make-array +routing-buffer-size+
:element-type '(unsigned-byte 8)))
(info-socket :initform nil)))

(defun process-request (this connection)
(defun process-request (connection)
;; fixme: record connection's last communication timestamp
;; to autoclose idle connections
(let ((stream (usocket:socket-stream connection)))
(when (listen stream)
;; fixme: make async
;; fixme: make async: read available chunk, don't wait for more
(let ((message (conspack:decode-stream stream)))
(when (listp message)
(let ((*system* this))
(conspack:encode (process-command (getf message :command) message)
:stream stream))
(conspack:encode (process-command (getf message :command) message)
:stream stream)
(force-output stream)

(defun route-stream (this connection)
(declare (ignore this connection))
(defun route-stream (connection)
(declare (ignore connection))

(defun process-input (this connection)
(with-slots (socket-table) this
(ecase (gethash connection socket-table)
(:info (process-request this connection))
(:proxy (route-stream this connection)))))
(defun process-input (connection)
(if (and *peer* (eq (proxy-connection-of *peer*) connection))
(route-stream connection)
(process-request connection)))

(defmethod initialize-system :after ((this mortar-combat-proxy))
(with-slots (proxy-socket info-socket socket-table) this
(with-slots (proxy-socket info-socket peer-registry) this
(setf proxy-socket (usocket:socket-listen #(127 0 0 1) 8222
:element-type '(unsigned-byte 8))
info-socket (usocket:socket-listen #(127 0 0 1) 8778
:element-type '(unsigned-byte 8)))
(in-new-thread "socket-listener"
(let ((sockets (list proxy-socket info-socket)))
(flet ((%accept (passive-socket type)
(let ((active-socket (usocket:socket-accept passive-socket)))
(setf (gethash active-socket socket-table) type)
(push active-socket (cddr sockets)))))
(let ((sockets (list proxy-socket info-socket))
(*system* this))
(flet ((%accept (passive-socket)
(push (usocket:socket-accept passive-socket) (cddr sockets))))
(loop while (enabledp this) do
(loop for rest-connections on (cdr (usocket:wait-for-input sockets))
for connection = (second rest-connections)
when (and connection (usocket:socket-state connection))
do (when (process-input this connection)
(pop (cdr rest-connections))))
do (let ((*peer* (find-peer-by-property (peer-registry-of this) connection)))
(when (process-input connection)
(pop (cdr rest-connections)))))
((usocket:socket-state info-socket) (%accept info-socket :info))
((usocket:socket-state proxy-socket) (%accept info-socket :proxy))))))))))
((usocket:socket-state info-socket) (%accept info-socket))
((usocket:socket-state proxy-socket) (%accept proxy-socket))))))))))

(defmethod make-system-context ((this mortar-combat-proxy))
@@ -0,0 +1,6 @@
(in-package :mortar-combat.proxy)

(defun make-random-uuid ()
(uuid:make-v5-uuid uuid:+namespace-x500+
(ironclad:byte-array-to-hex-string (ironclad:make-random-salt))))

0 comments on commit 4b9fc4c

Please sign in to comment.