123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127 |
- (in-package :server)
- (defvar *board-game-connections* (make-hash-table))
- (defvar *board-game-partial-messages* (make-hash-table))
- (defvar *board-game-connections-by-denizen-id* (make-hash-table))
- (defvar *board-game-states* (data:all-board-game-states))
- (defun handle-new-board-game-connection (con env)
- (let ((id (current-id env)))
- (setf (gethash con *board-game-connections*) id
- (gethash id *board-game-connections-by-denizen-id*) con)))
- (defun broadcast-board-game-message (message)
- (loop for con being the hash-key of *board-game-connections* do
- (websocket-driver:send con message)))
- (defun handle-board-game-message (con message)
- (cond ((not (equalp message "finished"))
- (setf message (concatenate 'string (gethash con *board-game-partial-messages*) message))
- (setf (gethash con *board-game-partial-messages*) message))
-
- (t
- (let* ((parsed-message (yason:parse (gethash con *board-game-partial-messages*)))
- (delete (gethash "delete" parsed-message))
- (refresh (gethash "refresh" parsed-message))
- (ping (gethash "ping" parsed-message))
- (chat (gethash "chat" parsed-message))
- (board (gethash "board" parsed-message)))
- (remhash con *board-game-partial-messages*)
-
- (unless ping
-
- (cond
-
- (delete
-
- (when (data:data-with-id delete)
- (let ((deleted-state (data:data-with-id delete)))
- (setf *board-game-states* (remove deleted-state *board-game-states*))
- (bknr.datastore:delete-object deleted-state))
-
- (broadcast-board-game-message
- (data:json
- (mapcar #'(lambda (state)
- (data:board-game-state-vector state))
- *board-game-states*)))))
-
- (refresh
-
- (let ((states-json (data:json
- (mapcar #'(lambda (state)
- (data:board-game-state-vector state))
- *board-game-states*))))
- (websocket-driver:send con states-json)))
-
- (chat
- (let ((message (make-hash-table)))
-
- (setf (gethash "chat" message)
- chat
-
- (gethash "sender" message)
- (gethash "label"
- (data:parsed-json
- (data:data-with-id
- (gethash con *board-game-connections*)))))
- (when board (setf (gethash "board" message) board))
- (broadcast-board-game-message (data:json message))))
-
- ((and board (not (data:data-with-id (gethash "stateId" board))))
-
- (let* ((game (data:data-with-id (gethash "gameId" board)))
- (game-state (data:make-board-game-state game board)))
- (push game-state *board-game-states*)
- (setf (gethash "stateId" board) (data:id game-state))
- (broadcast-board-game-message
- (data:json
- (mapcar #'(lambda (state)
- (data:board-game-state-vector state))
- *board-game-states*)))))
-
- (board
- (let ((game-state (data:data-with-id (gethash "stateId" board))))
- (vector-push-extend board
- (data:board-game-state-vector game-state))
- (data:with-transaction ()
- (setf (data:board-game-state-vector game-state)
- (data:board-game-state-vector game-state)))
-
- (broadcast-board-game-message (data:json board))))))))))
- (defun handle-board-game-close-connection (con)
- (let ((id (gethash con *board-game-connections*)))
- (remhash con *board-game-connections*)
- (remhash id *board-game-connections-by-denizen-id*)
- (remhash con *board-game-partial-messages*)))
- (defun board-game-server (env)
- (let ((ws (websocket-driver:make-server env)))
- (websocket-driver:on :open ws
- (lambda () (handle-new-board-game-connection ws env)))
- (websocket-driver:on :message ws
- (lambda (msg) (handle-board-game-message ws msg)))
- (websocket-driver:on :close ws
- (lambda (&key code reason)
- (declare (ignore code reason))
- (handle-board-game-close-connection ws)))
- (lambda (responder)
- (declare (ignore responder))
- (websocket-driver:start-connection ws))))
|