1a59003b13
Finding 6 of the 2026-07-29 security review: messages became data structures before anyone checked them. read never executes code, but it can be made to yield self-referential structure (which hangs ordinary list walks, plist-get included), objects that impersonate internal record types (#s syntax yields real hash tables and records), and any number of fresh symbols. cg-net--valid-p accepts what is recognised: a proper, even-length plist whose :type is in the per-peer whitelist -- the host accepts (hello move), a client accepts (welcome state full) -- built only from conses, vectors, strings, numbers and symbols, with no shared or circular structure, at most cg-net-max-nodes nodes. The check runs in cg-net--filter before the Finding 2 scrub, so nothing cyclic or opaque reaches scrub, handlers, or game code. The cycle-tolerance of the scrub walker remains as a second belt. Named leftovers (in PATCHES.md): symbols are interned by read before validation can see them, bounded only by Finding 4 line cap; and shape is not semantics -- a hostile host can still send absurd but well-shaped state, which is the reserved trust-model question. Test cgt-net-shape-gate fails against the previous code with the receipt (equal (5 (1 2 1 2 . #2) #s(hash-table)) (5)) -- the cycle and the hash table both reached cg-net-apply-move. cgt-net-valid-p pins the unit contract (void-function before the patch).
353 lines
15 KiB
EmacsLisp
353 lines
15 KiB
EmacsLisp
;;; cg-net.el --- Networked multiplayer for card games -*- lexical-binding: t; -*-
|
|
|
|
;; Copyright (C) 2026 Corwin Brust
|
|
|
|
;; Author: Corwin Brust <corwin@bru.st>
|
|
;; Maintainer: Corwin Brust <corwin@bru.st>
|
|
;; Version: 1.0.91
|
|
;; Package-Requires: ((emacs "26.1"))
|
|
;; Keywords: games
|
|
;; URL: https://code.bru.st/corwin/card-game.el
|
|
|
|
;; This program is free software; you can redistribute it and/or modify
|
|
;; it under the terms of the GNU General Public License as published by
|
|
;; the Free Software Foundation, either version 3 of the License, or
|
|
;; (at your option) any later version.
|
|
|
|
;; This program is distributed in the hope that it will be useful,
|
|
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;; GNU General Public License for more details.
|
|
|
|
;; You should have received a copy of the GNU General Public License
|
|
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
|
|
|
|
;;; Commentary:
|
|
|
|
;; Host-authoritative networking for the card games. One Emacs is the
|
|
;; HOST: it owns the canonical game and listens for players. Other
|
|
;; Emacsen CONNECT as clients, send move "intents", and receive the new
|
|
;; game state to redraw. Because the games are turn-based there is
|
|
;; nothing to merge, so this is a simple authoritative server rather
|
|
;; than a CRDT; crdt.el is kept in reserve for any future free-form
|
|
;; shared state.
|
|
;;
|
|
;; Transport is line-delimited s-expressions over `make-network-process'
|
|
;; (plain TCP), so it works wherever Emacs has TCP -- including an
|
|
;; Android client joining a desktop host. A message is a plist with a
|
|
;; `:type' key:
|
|
;;
|
|
;; client -> host: (:type hello :name NAME)
|
|
;; (:type move :move MOVE)
|
|
;; host -> client: (:type welcome :seat N)
|
|
;; (:type state :state SEXP)
|
|
;;
|
|
;; A game plugs in by defining methods on `cg-net-apply-move' (host
|
|
;; side) and, if its state is not just the env plist, on
|
|
;; `cg-net-game-state' / `cg-net-set-game-state'. Clients add a
|
|
;; redraw function to `cg-net-state-functions'.
|
|
|
|
;;; Code:
|
|
|
|
(require 'cg-core)
|
|
|
|
(defgroup cg-net nil
|
|
"Networked play for card games."
|
|
:group 'card-games
|
|
:prefix "cg-net-")
|
|
|
|
(defcustom cg-net-port 7500
|
|
"Default TCP port used to host or join a game."
|
|
:type 'integer :group 'cg-net)
|
|
|
|
(defcustom cg-net-host-address "127.0.0.1"
|
|
"Address the host's listening socket binds when hosting a game.
|
|
The default, \"127.0.0.1\", accepts connections only from this
|
|
machine; remote players reach it through a tunnel they were
|
|
deliberately given (for example ssh port forwarding), which also
|
|
encrypts the traffic in transit.
|
|
|
|
Setting this to \"0.0.0.0\" listens on every network interface, which
|
|
means anyone able to reach this machine's port can take a seat: there
|
|
is no password and no encryption on the wire. That can be a
|
|
reasonable choice on a trusted LAN, but it is a choice -- make it
|
|
deliberately."
|
|
:type '(choice (const :tag "This machine only (recommended)" "127.0.0.1")
|
|
(const :tag "Every interface (anyone who can reach you)" "0.0.0.0")
|
|
(string :tag "A specific interface address"))
|
|
:group 'cg-net)
|
|
|
|
(defcustom cg-net-max-line 65536
|
|
"Longest unterminated line accepted from a connection, in bytes.
|
|
Messages in this protocol are short; 64 KiB is generous. A connection
|
|
whose pending (newline-less) data exceeds this is closed, so one peer
|
|
cannot grow the line buffer until memory runs out."
|
|
:type 'integer :group 'cg-net)
|
|
|
|
(defcustom cg-net-max-connections 8
|
|
"Most simultaneous client connections a host will accept.
|
|
A table seats four, so the default leaves headroom without letting the
|
|
client list grow unboundedly. Connections beyond the limit are closed
|
|
as they arrive."
|
|
:type 'integer :group 'cg-net)
|
|
|
|
(defvar cg-net-state-functions nil
|
|
"Abnormal hook run on a client after the game state is updated.
|
|
Each function is called with the client's game object.")
|
|
|
|
(defvar cg-net-connect-functions nil
|
|
"Abnormal hook run on the host when a client connects.
|
|
Each function is called with (HOST SEAT): the `cg-net-host' struct and
|
|
the seat number just assigned to the new connection.")
|
|
|
|
;;;; Game integration points
|
|
|
|
(cl-defgeneric cg-net-apply-move (game seat move)
|
|
"Apply MOVE made by SEAT to GAME on the host.
|
|
Return non-nil when the move was accepted (and state should broadcast).")
|
|
|
|
(cl-defgeneric cg-net-game-state (game &optional seat)
|
|
"Return a `read'able representation of GAME's shared state for SEAT.
|
|
SEAT is the recipient's seat number, letting a game hide other players'
|
|
private information; nil requests the full host view.")
|
|
|
|
(cl-defmethod cg-net-game-state ((game cg-game) &optional _seat)
|
|
"Default: return GAME's env plist (no per-seat filtering)."
|
|
(oref game env))
|
|
|
|
(cl-defgeneric cg-net-set-game-state (game state)
|
|
"Replace GAME's shared state with STATE on a client.")
|
|
|
|
(cl-defmethod cg-net-set-game-state ((game cg-game) state)
|
|
"Default: install STATE as GAME's env plist."
|
|
(oset game env state))
|
|
|
|
;;;; Wire protocol
|
|
|
|
(defun cg-net--send (proc msg)
|
|
"Send MSG (a sexp) to PROC as one newline-terminated line."
|
|
(when (process-live-p proc)
|
|
(let ((print-length nil) (print-level nil))
|
|
(process-send-string proc (concat (prin1-to-string msg) "\n")))))
|
|
|
|
(defun cg-net--scrub (x)
|
|
"Return X with text properties removed from every string inside it.
|
|
Walks conses and vectors, tolerating shared and circular structure.
|
|
Everything arriving over the network passes through this: text
|
|
properties can rebind keys or carry expressions evaluated during
|
|
redisplay, and there is never a reason to honour a remote peer's."
|
|
(let ((seen (make-hash-table :test 'eq)))
|
|
(cl-labels ((walk (v)
|
|
(cond
|
|
((stringp v) (substring-no-properties v))
|
|
((consp v)
|
|
(or (gethash v seen)
|
|
(let ((cell (cons nil nil)))
|
|
(puthash v cell seen)
|
|
(setcar cell (walk (car v)))
|
|
(setcdr cell (walk (cdr v)))
|
|
cell)))
|
|
((vectorp v)
|
|
(or (gethash v seen)
|
|
(let ((copy (make-vector (length v) nil)))
|
|
(puthash v copy seen)
|
|
(dotimes (i (length v))
|
|
(aset copy i (walk (aref v i))))
|
|
copy)))
|
|
(t v))))
|
|
(walk x))))
|
|
|
|
(defconst cg-net-max-nodes 20000
|
|
"Upper bound on the number of nodes accepted in one wire message.")
|
|
|
|
(defun cg-net--valid-p (msg types)
|
|
"Return non-nil when MSG is a well-shaped protocol message.
|
|
TYPES is the list of message-type symbols accepted from this peer.
|
|
MSG must be a proper plist whose `:type' is in TYPES, built only from
|
|
conses, vectors, strings, numbers and symbols, with no shared or
|
|
circular structure and at most `cg-net-max-nodes' nodes. Accept what
|
|
is recognised rather than trying to spot what is bad: parsed text can
|
|
carry self-references that hang code walking them, and objects that
|
|
impersonate internal record types."
|
|
(let ((seen (make-hash-table :test 'eq))
|
|
(nodes 0))
|
|
(cl-labels ((clean-p (v)
|
|
(cond
|
|
((> (cl-incf nodes) cg-net-max-nodes) nil)
|
|
((consp v)
|
|
(and (not (gethash v seen))
|
|
(progn (puthash v t seen)
|
|
(and (clean-p (car v)) (clean-p (cdr v))))))
|
|
((vectorp v)
|
|
(and (not (gethash v seen))
|
|
(progn (puthash v t seen)
|
|
(cl-every #'clean-p v))))
|
|
((or (stringp v) (numberp v) (symbolp v)) t)
|
|
(t nil))))
|
|
(and (consp msg)
|
|
(clean-p msg) ; safe before plist-get: no cycles past here
|
|
(null (cdr (last msg))) ; a proper list
|
|
(cl-evenp (length msg)) ; of key/value pairs
|
|
(memq (plist-get msg :type) types)))))
|
|
|
|
(defun cg-net--filter (handler types)
|
|
"Return a process filter dispatching each complete line to HANDLER.
|
|
HANDLER is called with (PROC MSG) for each line that parses into a
|
|
well-shaped message (`cg-net--valid-p') whose type is in TYPES;
|
|
strings inside MSG have their text properties stripped first, by
|
|
`cg-net--scrub'. Anything else is dropped where it lands."
|
|
(lambda (proc string)
|
|
(let ((buf (concat (or (process-get proc 'cg-net-buf) "") string))
|
|
(start 0) nl)
|
|
(while (setq nl (string-search "\n" buf start))
|
|
(let ((line (substring buf start nl)))
|
|
(setq start (1+ nl))
|
|
(unless (string-empty-p line)
|
|
(condition-case err
|
|
(let ((msg (car (read-from-string line))))
|
|
(if (cg-net--valid-p msg types)
|
|
(funcall handler proc (cg-net--scrub msg))
|
|
(message "cg-net: dropped malformed message")))
|
|
(error (message "cg-net: bad message: %S" err)))))
|
|
)
|
|
(let ((rest (substring buf start)))
|
|
(if (> (length rest) cg-net-max-line)
|
|
(progn
|
|
(process-put proc 'cg-net-buf nil)
|
|
(message "cg-net: dropping %s (line over %d bytes)"
|
|
(process-name proc) cg-net-max-line)
|
|
(delete-process proc))
|
|
(process-put proc 'cg-net-buf rest))))))
|
|
|
|
;;;; Host
|
|
|
|
(cl-defstruct (cg-net-host (:constructor cg-net--host-make))
|
|
server game (clients nil) (next-seat 0))
|
|
|
|
(defvar cg-net--host nil
|
|
"The running `cg-net-host', or nil when not hosting.")
|
|
|
|
(defun cg-net-hosting-p ()
|
|
"Return non-nil when this Emacs is hosting a game."
|
|
(and cg-net--host (process-live-p (cg-net-host-server cg-net--host))))
|
|
|
|
(defun cg-net-host-start (game &optional port)
|
|
"Begin hosting GAME on PORT (default `cg-net-port'). Return the server process.
|
|
The socket binds `cg-net-host-address' -- by default, this machine only."
|
|
(let* ((port (or port cg-net-port))
|
|
(server (make-network-process
|
|
:name "cg-host" :server t :service port
|
|
:host cg-net-host-address :family 'ipv4 :coding 'utf-8
|
|
:log #'cg-net--host-accept)))
|
|
(setq cg-net--host (cg-net--host-make :server server :game game))
|
|
server))
|
|
|
|
(defun cg-net-host-stop ()
|
|
"Stop hosting and close all client connections."
|
|
(when cg-net--host
|
|
(dolist (c (cg-net-host-clients cg-net--host))
|
|
(when (process-live-p c) (delete-process c)))
|
|
(when (process-live-p (cg-net-host-server cg-net--host))
|
|
(delete-process (cg-net-host-server cg-net--host)))
|
|
(setq cg-net--host nil)))
|
|
|
|
(defun cg-net--host-sentinel (proc _event)
|
|
"Reap PROC from the client list when its connection has ended.
|
|
Without this, departed players stay listed forever and the host keeps
|
|
sending to them. Seat numbers are deliberately not reused: a stale
|
|
seat must not be inherited by a stranger mid-game."
|
|
(unless (process-live-p proc)
|
|
(when cg-net--host
|
|
(setf (cg-net-host-clients cg-net--host)
|
|
(delq proc (cg-net-host-clients cg-net--host))))))
|
|
|
|
(defun cg-net--host-accept (_server connection _message)
|
|
"Set up an accepted CONNECTION: assign a seat and send the current state.
|
|
A connection arriving past `cg-net-max-connections' is closed instead."
|
|
(if (>= (length (cl-remove-if-not #'process-live-p
|
|
(cg-net-host-clients cg-net--host)))
|
|
cg-net-max-connections)
|
|
(progn
|
|
(message "cg-net: refusing connection (table is at %d)"
|
|
cg-net-max-connections)
|
|
(delete-process connection))
|
|
(let ((seat (cg-net-host-next-seat cg-net--host)))
|
|
(setf (cg-net-host-next-seat cg-net--host) (1+ seat))
|
|
(push connection (cg-net-host-clients cg-net--host))
|
|
(process-put connection 'cg-net-seat seat)
|
|
(set-process-coding-system connection 'utf-8 'utf-8)
|
|
(set-process-sentinel connection #'cg-net--host-sentinel)
|
|
(set-process-filter connection
|
|
(cg-net--filter #'cg-net--host-handle '(hello move)))
|
|
(cg-net--send connection (list :type 'welcome :seat seat))
|
|
(cg-net--send connection
|
|
(list :type 'state
|
|
:state (cg-net-game-state (cg-net-host-game cg-net--host) seat)))
|
|
(run-hook-with-args 'cg-net-connect-functions cg-net--host seat))))
|
|
|
|
(defun cg-net--host-handle (proc msg)
|
|
"Handle one message MSG from a client PROC on the host."
|
|
(pcase (plist-get msg :type)
|
|
('hello (process-put proc 'cg-net-name (plist-get msg :name)))
|
|
('move
|
|
(let ((seat (process-get proc 'cg-net-seat))
|
|
(game (cg-net-host-game cg-net--host)))
|
|
(when (cg-net-apply-move game seat (plist-get msg :move))
|
|
(cg-net-host-broadcast))))))
|
|
|
|
(defun cg-net-host-broadcast ()
|
|
"Send each connected client the game state filtered for its seat."
|
|
(when cg-net--host
|
|
(let ((game (cg-net-host-game cg-net--host)))
|
|
(dolist (c (cg-net-host-clients cg-net--host))
|
|
(cg-net--send c (list :type 'state
|
|
:state (cg-net-game-state
|
|
game (process-get c 'cg-net-seat))))))))
|
|
|
|
;;;; Client
|
|
|
|
(cl-defstruct (cg-net-client (:constructor cg-net--client-make))
|
|
proc game (seat nil))
|
|
|
|
(defvar cg-net--client nil
|
|
"The active `cg-net-client', or nil when not connected.")
|
|
|
|
(defun cg-net-connected-p ()
|
|
"Return non-nil when connected to a host as a client."
|
|
(and cg-net--client (process-live-p (cg-net-client-proc cg-net--client))))
|
|
|
|
(defun cg-net-connect (host port name game)
|
|
"Connect to HOST on PORT as NAME, syncing into the local GAME.
|
|
Return the new `cg-net-client'."
|
|
(let ((proc (make-network-process
|
|
:name "cg-client" :host host :service port
|
|
:family 'ipv4 :coding 'utf-8)))
|
|
(setq cg-net--client (cg-net--client-make :proc proc :game game))
|
|
(set-process-coding-system proc 'utf-8 'utf-8)
|
|
(set-process-filter proc
|
|
(cg-net--filter #'cg-net--client-handle
|
|
'(welcome state full)))
|
|
(cg-net--send proc (list :type 'hello :name name))
|
|
cg-net--client))
|
|
|
|
(defun cg-net-disconnect ()
|
|
"Disconnect from the host."
|
|
(when (and cg-net--client (process-live-p (cg-net-client-proc cg-net--client)))
|
|
(delete-process (cg-net-client-proc cg-net--client)))
|
|
(setq cg-net--client nil))
|
|
|
|
(defun cg-net--client-handle (_proc msg)
|
|
"Handle one message MSG from the host on a client."
|
|
(pcase (plist-get msg :type)
|
|
('welcome (setf (cg-net-client-seat cg-net--client) (plist-get msg :seat)))
|
|
('state
|
|
(let ((game (cg-net-client-game cg-net--client)))
|
|
(cg-net-set-game-state game (plist-get msg :state))
|
|
(run-hook-with-args 'cg-net-state-functions game)))))
|
|
|
|
(defun cg-net-send-move (move)
|
|
"Send MOVE to the host from this client."
|
|
(cg-net--send (cg-net-client-proc cg-net--client) (list :type 'move :move move)))
|
|
|
|
(provide 'cg-net)
|
|
;;; cg-net.el ends here
|