Add arena leaving

client/mortar-combat-devel.conf.lisp

@@ -1,5 +1,5 @@
 '(:engine
   (:systems (mortar-combat::mortar-combat)
    :log-level :debug)
-  :server-address "borodust.org"
+  :server-address "127.0.0.1"
   :assets "assets/")

client/src/connector.lisp

@@ -34,19 +34,20 @@
               (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)))))
+                    (when enabled-p
+                      (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"))))
@@ -56,7 +57,8 @@
 (defun disconnect-from-server (connector)
   (with-slots (enabled-p connection) connector
     (when enabled-p
-      (usocket:socket-close connection))))
+      (usocket:socket-close connection)
+      (setf enabled-p nil))))
 
 
 (defun check-response (message expected-command)
@@ -119,6 +121,11 @@
     (with-response () :ok)))
 
 
+(defun leave-arena (connector)
+  (-> (connector :command :exit-arena) ()
+    (with-response () :ok)))
+
+
 (defun get-arena-list (connector)
   (-> (connector :command :get-arena-list) ()
     (with-response (list) :arena-list

client/src/main.lisp

@@ -15,7 +15,8 @@
    (identity :initform nil)
 
    (keymap :initform nil)
-   (arena :initform nil :reader arena-of))
+   (arena :initform nil :reader arena-of)
+   (arena-leave-handler :initform nil))
   (:default-initargs :depends-on '(event-system
                                    graphics-system
                                    physics-system
@@ -43,6 +44,27 @@
     (setf (player-of cam) (player-of arena))))
 
 
+(defun register-arena-leave-handler (this)
+  (with-slots (arena-leave-handler scene remote-server arena
+                                   game-server game-client)
+      this
+    (flet ((node (name)
+             (find-node (root-of scene) name)))
+      (setf arena-leave-handler
+            (subscribe-body-to (arena-leave-requested ()) (events)
+              (run (>> (leave-arena remote-server)
+                       (-> this ()
+                         (disable-node (node :camera))
+                         (abandon-all (node :dude-group))
+                         (abandon-all (node :ball-group))
+                         (let ((conn (or game-server game-client)))
+                           (disconnect-from-server conn)
+                           (dispose conn))
+                         (setf arena nil
+                               game-server nil
+                               game-client nil)))))))))
+
+
 (defun create-combat-arena (name)
   (with-slots (remote-server identity game-server arena scene) (mortar-combat)
     (let* ((new-arena (make-instance 'arena :player-name (server-identity-name identity)))
@@ -203,6 +225,8 @@
 
     (enable-keymap keymap)
 
+    (register-arena-leave-handler this)
+
     (run (>> (-> ((host)) ()
                (setf (viewport-title) "Mortar Combat")
                (setf (viewport-size) (vec2 800 600)))
@@ -244,10 +268,14 @@
 
 
 (defmethod discard-system :before ((this mortar-combat))
-  (with-slots (scene remote-server game-client game-server arena) this
+  (with-slots (scene remote-server game-client game-server arena
+                     arena-leave-handler)
+      this
     (dolist (server (list remote-server game-client game-server))
       (when server
         (disconnect-from-server server)))
+    (when arena-leave-handler
+      (unsubscribe-from 'arena-leave-requested arena-leave-handler (events)))
     ;; fixme: dispose scene after all
     #++(dispose scene)
     (setf remote-server nil

client/src/ui.lisp

@@ -113,6 +113,7 @@
                                   (hide-window arena-creation-dialog)
                                   (subscribe-to 'keyboard-event #'toggle-game-menu (events)))
                    (:leave (unsubscribe-from 'keyboard-event #'toggle-game-menu (events))
+                           (hide-window game-menu) (show-window main-menu)
                            (post (make-arena-leave-requested) (events)))
                    (:quit (post (make-exit-requested) (events))))))))
       (subscribe-body-to (item-selected (source item)) (events)

proxy/Makefile

@@ -18,10 +18,11 @@ manifest: prepare
 	     --eval "(ql:write-asdf-manifest-file \"$(MANIFEST_FILE)\" :if-exists :supersede)"
 
 executable: prepare manifest
-	buildapp --output $(BUILD_DIR)/server/server.bin	\
-		 --entry "mortar-combat.proxy::main"		\
-		 --manifest-file $(MANIFEST_FILE)		\
-		 --load-system "mortar-combat/proxy"		\
+	buildapp --output $(BUILD_DIR)/server/server.bin		\
+		 --entry "mortar-combat.proxy::main"			\
+		 --manifest-file $(MANIFEST_FILE)			\
+		 --eval "(push :bodge-production-mode *features*)"	\
+		 --load-system "mortar-combat/proxy"			\
 		 --compress-core
 
 image: executable

proxy/commands.lisp

@@ -72,7 +72,8 @@
 
 (defmethod process-command ((command (eql :exit-arena)) message)
   (when-peer-identified
-    (remove-peer-from-arena (arena-registry-of *system*) *peer*)))
+   (remove-peer-from-arena (arena-registry-of *system*) *peer*)
+   +ok-reply+))
 
 
 (defmethod process-command ((command (eql :register-game-stream)) message)

proxy/proxy.lisp

@@ -64,17 +64,15 @@
          (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)))))
+      (when (eq connection (info-connection-of peer))
+        (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 process-condition ((condi as:socket-reset))
-  (log:warn "Peer disconnected unexpectedly"))
+(defmethod process-condition ((condi as:socket-error))
+  (log-errors
+    (disconnect-peer (as:socket condi))))
 
 
 (defmethod initialize-system :after ((this mortar-combat-proxy))