Skip to content
Browse files
Arena commands
  • Loading branch information
borodust committed Apr 18, 2017
1 parent c66234e commit 248ae835d4636bf39b28e85581a85e65e1e68de8
Showing with 156 additions and 39 deletions.
  1. +17 −1 client/src/connector.lisp
  2. +44 −3 proxy/arena.lisp
  3. +50 −14 proxy/commands.lisp
  4. +12 −13 proxy/peer.lisp
  5. +33 −8 proxy/proxy.lisp
@@ -26,7 +26,7 @@
(with-slots (connection message-table enabled-p) this
(in-new-thread "connector-thread"
(loop while enabled-p
do (progn
do (log-errors
(usocket:wait-for-input connection)
(let* ((message (conspack:decode-stream (connection-stream-of this)))
(message-id (getf message :reply-for)))
@@ -95,3 +95,19 @@
(-> (connector :command :identify :name name) ()
(with-response :identified (id name) *message*
(make-server-identity id name))))

(defun create-arena (connector name)
(-> (connector :command :create-arena :name name) ()
(with-response :ok () *message*)))

(defun join-arena (connector name)
(-> (connector :command :join-arena :name name) ()
(with-response :ok () *message*)))

(defun get-arena-list (connector)
(-> (connector :command :get-arena-list) ()
(with-response :arena-list (list) *message*
@@ -2,6 +2,47 @@

(defclass arena ()
((name :initarg :name :reader :name-of)
(server :initarg :server :reader server-of)
(clients :initform nil :reader clients-of)))

(defclass arena-registry ()
((arena-table :initform (make-hash-table :test 'equal))
(arena-by-name :initform (make-hash-table :test 'equal))))

(defun register-arena (registry name server)
(with-slots (arena-table arena-by-name) registry
(with-hash-entries ((by-name name)) arena-by-name
(with-hash-entries ((by-server server)) arena-table
(when by-server
(error "Provided server already assigned to different arena"))
(unless by-name
(let ((arena (make-instance 'arena :name name :server server)))
(setf by-name arena
by-server arena)

(defun list-arena-names (registry)
(with-slots (arena-by-name) registry
(loop for key being the hash-key of arena-by-name
collect key)))

(defun add-arena-client (registry arena client)
(with-slots (clients) arena
(push client clients))
(with-slots (arena-table) registry
(setf (gethash client arena-table) arena)))

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

(defun find-arena-by-name (registry name)
(with-slots (arena-by-name) registry
(gethash name arena-by-name)))
@@ -1,23 +1,59 @@
(in-package :mortar-combat.proxy)

(defmethod process-command ((command (eql :version)) message)
(list :command :version
:version +server-version+))

(defmethod process-command ((command (eql :identify)) message)
(let* ((reg (peer-registry-of *system*))
(peer (or *peer* (register-peer reg *connection* (format nil "~A" (getf message :name))))))
(list :command :identified
:name (name-of peer)
:id (id-of peer))))
(define-constant +ok-reply+ (list :command :ok)
:test #'equal)

(defmethod process-command ((command (eql :get-arena-list)) message))
(defmacro when-peer-identified (&body body)
`(if *peer*
(progn ,@body)
(list :command :error
:type :unidentified-peer
:text "Unauthorized access. Identify first.")))

(defmethod process-command ((command (eql :create-arena)) message))
(defmethod process-command ((command (eql :version)) message)
(list :command :version
:version +server-version+))

(defmethod process-command ((command (eql :join-arena)) message))
(defmethod process-command ((command (eql :identify)) message)
(let* ((name (getf message :name))
(reg (peer-registry-of *system*))
(peer (or *peer* (register-peer reg *connection* (format nil "~A" name)))))
(if peer
(list :command :identified
:name (name-of peer)
:id (id-of peer))
(list :command :error
:type :name-unavailable
:text (format nil "Name '~A' taken" name)))))

(defmethod process-command ((command (eql :get-arena-list)) message)
(list :command :arena-list
:list (list-arena-names (arena-registry-of *system*))))

(defmethod process-command ((command (eql :create-arena)) message)
(destructuring-bind (&key name &allow-other-keys) message
(if-let ((arena (register-arena (arena-registry-of *system*) (format nil "~A" name) *peer*)))
(list :command :error
:type :arena-exist
:text (format nil "Arena with name '~A' exists" name))))))

(defmethod process-command ((command (eql :join-arena)) message)
(destructuring-bind (&key name &allow-other-keys) message
(let ((reg (arena-registry-of *system*)))
(if-let ((arena (find-arena-by-name reg name)))
;; fixme: add client limit
(prog1 +ok-reply+
(add-arena-client reg arena *peer*))
(list :command :error
:type :arena-not-found
:text (format nil "Arena with name '~A' not found" name)))))))
@@ -20,19 +20,18 @@
(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)
(unless peer-by-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)
@@ -18,25 +18,27 @@

(defmethod process-command :around (command message)
(append (list :reply-for (getf message :message-id)) (call-next-method)))
(append (list :reply-for (getf message :message-id))
(serious-condition ()
'(:command :error
:type :unhandled-error
:text "Error during command execution")))))

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

(defun reply-to (message)
(process-command (getf message :command) message)
(serious-condition ()
'(:command :error
:type :unhandled-error
:text "Error during command execution"))))
(process-command (getf message :command) message))

(defun process-request ()
@@ -51,7 +53,25 @@
(force-output stream))))))

(defun route-stream ())
(defun pour-stream (source-peer destination-peer)
(with-slots (routing-buffer) *system*
(when-let ((src-conn (proxy-connection-of source-peer))
(dst-conn (proxy-connection-of destination-peer)))
(let ((source-stream (usocket:socket-stream src-conn))
(destination-stream (usocket:socket-stream dst-conn)))
(when (listen source-stream)
;; no need to do full copy, hence no loop: let server do other work in between
(let ((bytes-read (read-sequence routing-buffer source-stream)))
(write-sequence routing-buffer destination-stream :end bytes-read)))))))

(defun route-stream ()
(let* ((arena (find-arena-by-peer (arena-registry-of *system*) *peer*))
(arena-server (server-of arena)))
(if (eq arena-server *peer*)
(loop for client in (clients-of arena)
do (pour-stream arena-server client))
(pour-stream *peer* arena-server))))

(defun process-input ()
@@ -94,6 +114,11 @@
(usocket:socket-close info-socket)))

(define-system-function find-arena mortar-combat-proxy (name)
(with-slots (arenas) *system*
(gethash name arenas)))

(defun start ()
(startup '(:engine (:systems (mortar-combat-proxy)))))

0 comments on commit 248ae83

Please sign in to comment.