jungle-server/board-game-server.lisp

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