Add peer registry

mortar-combat.asd

@@ -43,10 +43,12 @@
   :mailto "dev@borodust.org"
   :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")))

proxy/arena.lisp

@@ -0,0 +1,7 @@
+(in-package :mortar-combat.proxy)
+
+
+(defclass arena ()
+  ((name)
+   (serving-socket)
+   (client-sockets)))

proxy/peer.lisp

@@ -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))
+        peer-table
+      (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)
+        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))))

proxy/proxy.lisp

@@ -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)
-          t)))))
+          nil)))))
 
 
-(defun route-stream (this connection)
-  (declare (ignore this connection))
+(defun route-stream (connection)
+  (declare (ignore connection))
   nil)
 
 
-(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
                (log-errors
                  (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)))))
                  (cond
-                   ((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))

proxy/utils.lisp

@@ -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))))