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