Clean up peer data on disconnect

client/src/connector.lisp

@@ -31,26 +31,32 @@
     (in-new-thread "connector-thread"
       (loop while enabled-p
          do (log-errors
-              (usocket:wait-for-input connection)
-              (let* ((stream (connection-stream-of this))
-                     (message (decode-message stream))
-                     (*connector* this))
-                (if-let ((reply-id (getf message :reply-for)))
-                  (with-instance-lock-held (this)
-                    (if-let ((handler (gethash reply-id message-table)))
-                      (progn
-                        (remhash reply-id message-table)
-                        (funcall handler message))
-                      (log:error "Handler not found for message with id ~A" reply-id)))
-                  (when-let ((reply (process-command (getf message :command) message)))
-                    (encode-message reply stream)
-                    (force-output stream)))))
+              (handler-case
+                  (progn
+                    (usocket:wait-for-input connection)
+                    (let* ((stream (connection-stream-of this))
+                           (message (decode-message stream))
+                           (*connector* this))
+                      (if-let ((reply-id (getf message :reply-for)))
+                        (with-instance-lock-held (this)
+                          (if-let ((handler (gethash reply-id message-table)))
+                            (progn
+                              (remhash reply-id message-table)
+                              (funcall handler message))
+                            (log:error "Handler not found for message with id ~A" reply-id)))
+                        (when-let ((reply (process-command (getf message :command) message)))
+                          (encode-message reply stream)
+                          (force-output stream)))))
+                (end-of-file ()
+                  (setf enabled-p nil)
+                  (log:debug "Disconnected from server"))))
          finally (usocket:socket-close connection)))))
 
 
 (defun disconnect-from-server (connector)
-  (with-slots (enabled-p) connector
-    (setf enabled-p nil)))
+  (with-slots (enabled-p connection) connector
+    (when enabled-p
+      (usocket:socket-close connection))))
 
 
 (defun check-response (message expected-command)
@@ -81,15 +87,19 @@
 
 (defmethod dispatch ((this connector) (task function) invariant &rest keys
                      &key &allow-other-keys)
-  (with-slots (message-table message-counter) this
+  (with-slots (enabled-p message-table message-counter) this
     (with-instance-lock-held (this)
-      (let ((next-id (incf message-counter)))
-        (flet ((response-callback (message)
-                 (let ((*message* message))
-                   (funcall task))))
-          (unless (getf keys :no-reply)
-            (setf (gethash next-id message-table) #'response-callback))
-          (apply #'send-command this :message-id next-id keys))))))
+      (flet ((response-callback (message)
+               (let ((*message* message))
+                 (funcall task))))
+        (if enabled-p
+            (let ((next-id (incf message-counter)))
+              (unless (getf keys :no-reply)
+                (setf (gethash next-id message-table) #'response-callback))
+              (apply #'send-command this :message-id next-id keys))
+            (response-callback (list :command :error
+                                     :type :disconnected
+                                     :text "Disconnected from server")))))))
 
 
 (defun server-version (connector)

client/src/main.lisp

@@ -181,6 +181,13 @@
                  (run looped-flow)))))))
 
 
+(defmethod discard-system ((this mortar-combat))
+  (with-slots (remote-server game-client game-server) this
+    (dolist (server (list remote-server game-client game-server))
+      (when server
+        (disconnect-from-server server)))))
+
+
 (defun start (configuration-path)
   (startup configuration-path (uiop:pathname-directory-pathname configuration-path)))
 

proxy/arena.lisp

@@ -2,7 +2,7 @@
 
 
 (defclass arena ()
-  ((name :initarg :name :reader :name-of)
+  ((name :initarg :name :reader name-of)
    (server :initarg :server :reader server-of)
    (clients :initform nil :reader clients-of)))
 
@@ -38,6 +38,16 @@
     (setf (gethash client arena-table) arena)))
 
 
+(defun remove-arena-by-server (registry server)
+  (with-slots (arena-table arena-by-name) registry
+    (when-let ((arena (find-arena-by-peer registry server)))
+      (when (eq (server-of arena) server)
+        (dolist (client (clients-of arena))
+          (remhash client arena-table))
+        (remhash (server-of arena) arena-table)
+        (remhash arena-by-name (name-of arena))))))
+
+
 (defun find-arena-by-peer (registry peer)
   (with-slots (arena-table) registry
     (gethash peer arena-table)))

proxy/peer.lisp

@@ -44,6 +44,14 @@
     (gethash id peer-by-id)))
 
 
+(defun remove-peer (registry peer)
+  (with-slots (peer-table peer-by-id) registry
+    (remhash (info-connection-of peer) peer-table)
+    (remhash (proxy-connection-of peer) peer-table)
+    (remhash (name-of peer) peer-table)
+    (remhash (id-of peer) peer-by-id)))
+
+
 (defun update-peer-proxy-connection (registry peer proxy-connection)
   (with-slots (peer-table) registry
     (remhash (proxy-connection-of peer) peer-table)

proxy/proxy.lisp

@@ -15,7 +15,6 @@
   ((proxy-server :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-server :initform nil)))
@@ -55,13 +54,30 @@
             (pour-stream stream (wrap-into-stream arena-server)))))))
 
 
+(defgeneric process-condition (condition)
+  (:method (condition)
+    (log:error "Unhandled event ~A: ~A" (type-of condition) condition)))
+
+
+(defun disconnect-peer (connection)
+  (let* ((proxy (engine-system 'mortar-combat-proxy))
+         (peer-reg (peer-registry-of proxy))
+         (arena-reg (arena-registry-of proxy)))
+    (when-let ((peer (find-peer-by-property peer-reg connection)))
+      (remove-arena-by-server arena-reg peer)
+      (remove-peer peer-reg peer)
+      (log:debug "Peer \"~A\" disconnected" (name-of peer)))))
+
+
+(defmethod process-condition ((condi as:socket-eof))
+  (disconnect-peer (as:socket condi)))
+
+
 (defmethod initialize-system :after ((this mortar-combat-proxy))
   (with-slots (proxy-server info-server peer-registry) this
-    (labels ((process-condition (e)
-               (log:error "Server event: ~A" e))
-             (on-accept (socket)
-               (declare (ignorable socket))
-               #++ (as:set-socket-timeouts socket +client-socket-timeout+ nil))
+    (labels ((on-accept (socket)
+               (when-let ((connection-timeout (property :connection-timeout)))
+                 (as:set-socket-timeouts socket connection-timeout nil)))
              (process-input (socket stream)
                (let* ((*system* this)
                       (*connection* socket)
@@ -91,13 +107,9 @@
     (as:close-tcp-server info-server)))
 
 
-(define-system-function find-arena mortar-combat-proxy (name)
-  (with-slots (arenas) *system*
-    (gethash name arenas)))
-
-
 (defun start ()
-  (startup '(:engine (:systems (mortar-combat-proxy)))))
+  (startup '(:engine (:systems (mortar-combat-proxy)
+                      :log-level :debug))))
 
 
 (defun stop ()