From 9d3ec08d3c882356c09ebda635d0b88eda28782b Mon Sep 17 00:00:00 2001 From: Claude Date: Mon, 3 Aug 2026 20:31:07 -0500 Subject: [PATCH 1/6] cg-net: strip text properties from everything arriving over the wire Finding 2 of the 2026-07-29 security review (CONFIRMED there): text properties survive the prin1/read round trip the protocol is built on, so a malicious host could send a client strings whose properties rebind keys or carry expressions evaluated during redisplay. New cg-net--scrub walks a decoded message and passes every string through substring-no-properties; conses and vectors are copied, shared and circular structure is tolerated. It is applied inside cg-net--filter -- the one decode point both the host and the client read through -- so both directions are covered at the boundary rather than at each use site. Test cgt-net-strips-properties (loopback, both directions) fails against the previous code with properties intact: value (keymap (keymap)). --- cg-net.el | 33 +++++++++++++++++++++++++++++++-- test/card-games-tests.el | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 2 deletions(-) diff --git a/cg-net.el b/cg-net.el index 8019c5e..fd7861d 100644 --- a/cg-net.el +++ b/cg-net.el @@ -99,9 +99,37 @@ private information; nil requests the full host view.") (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)))) + (defun cg-net--filter (handler) "Return a process filter dispatching each complete line to HANDLER. -HANDLER is called with (PROC MSG)." +HANDLER is called with (PROC MSG). Strings inside MSG have their text +properties stripped (`cg-net--scrub') before HANDLER sees them." (lambda (proc string) (let ((buf (concat (or (process-get proc 'cg-net-buf) "") string)) (start 0) nl) @@ -110,7 +138,8 @@ HANDLER is called with (PROC MSG)." (setq start (1+ nl)) (unless (string-empty-p line) (condition-case err - (funcall handler proc (car (read-from-string line))) + (funcall handler proc + (cg-net--scrub (car (read-from-string line)))) (error (message "cg-net: bad message: %S" err))))) ) (process-put proc 'cg-net-buf (substring buf start))))) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index ccb113b..0579310 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -68,6 +68,42 @@ (cg-net-disconnect) (cg-net-host-stop)))) +(ert-deftest cgt-net-strips-properties () + "Text properties on wire strings are stripped at the boundary, both ways. +Finding 2 of the 2026-07-29 review: a propertized hello :name from a +client must reach the host bare, and a propertized :message from the +host must reach the client bare." + (condition-case _ + (delete-process + (make-network-process :name "cgt-probe3" :server t :service 0 + :host "127.0.0.1" :family 'ipv4)) + (error (ert-skip "TCP not available"))) + (cl-flet ((pump () (dotimes (_ 12) (accept-process-output nil 0.05)))) + (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) + (srv (cg-net-host-start hgame 0)) + (port (process-contact srv :service)) + (cgame (make-instance 'cgt-net-game :env (list :counter 0)))) + (unwind-protect + (progn + (cg-net-connect "127.0.0.1" port + (propertize "Eve" 'keymap '(keymap)) cgame) + (pump) + ;; client -> host: the hello name arrives with no attachments + (let* ((conn (car (cg-net-host-clients cg-net--host))) + (name (process-get conn 'cg-net-name))) + (should (equal name "Eve")) + (should-not (text-properties-at 0 name))) + ;; host -> client: a state string arrives with no attachments + (cg-put hgame :message + (propertize "hi" 'keymap '(keymap) 'help-echo "boo")) + (cg-net-host-broadcast) + (pump) + (let ((m (cg-get cgame :message))) + (should (equal m "hi")) + (should-not (text-properties-at 0 m)))) + (cg-net-disconnect) + (cg-net-host-stop))))) + ;;;; Gaps (ert-deftest cgt-gaps-deal () From f8873fb8fa969f595d9090ab548d52eaec4bfc26 Mon Sep 17 00:00:00 2001 From: Claude Date: Mon, 3 Aug 2026 20:31:58 -0500 Subject: [PATCH 2/6] cg-net: listen on this machine only by default Finding 1 of the 2026-07-29 security review: hosting bound 0.0.0.0 -- every interface -- with no password and no encryption, so anyone who could reach the machine's port was handed a seat and the game state. New defcustom cg-net-host-address defaults to 127.0.0.1; the wide-open value remains available and its docstring says exactly what choosing it means. This converts "anyone who can reach you" into "someone you deliberately let in", and bounds Finding 4's unauthenticated memory-exhaustion route to local callers along the way. Test cgt-net-host-loopback-default checks both the default value and the actual bound address (process-contact :local). Against the previous code it fails with (void-variable cg-net-host-address); the old bind, captured before the patch: [0 0 0 0 PORT]. --- cg-net.el | 22 ++++++++++++++++++++-- test/card-games-tests.el | 19 +++++++++++++++++++ 2 files changed, 39 insertions(+), 2 deletions(-) diff --git a/cg-net.el b/cg-net.el index fd7861d..4fcf79d 100644 --- a/cg-net.el +++ b/cg-net.el @@ -60,6 +60,23 @@ "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) + (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.") @@ -157,11 +174,12 @@ properties stripped (`cg-net--scrub') before HANDLER sees them." (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." + "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 "0.0.0.0" :family 'ipv4 :coding 'utf-8 + :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)) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index 0579310..f77f312 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -104,6 +104,25 @@ host must reach the client bare." (cg-net-disconnect) (cg-net-host-stop))))) +(ert-deftest cgt-net-host-loopback-default () + "Hosting binds to this machine only unless deliberately widened. +Finding 1 of the 2026-07-29 review: the default of +`cg-net-host-address' is loopback, and the listening socket really +binds it -- wider exposure is a setting the user turns on, not a +silent default." + (should (equal "127.0.0.1" (default-value 'cg-net-host-address))) + (condition-case _ + (delete-process + (make-network-process :name "cgt-probe4" :server t :service 0 + :host "127.0.0.1" :family 'ipv4)) + (error (ert-skip "TCP not available"))) + (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) + (srv (cg-net-host-start hgame 0))) + (unwind-protect + (should (equal [127 0 0 1] + (substring (process-contact srv :local) 0 4))) + (cg-net-host-stop)))) + ;;;; Gaps (ert-deftest cgt-gaps-deal () From 3b55d780b0e5e60b40bbd9edd5d79d4447a6a1ae Mon Sep 17 00:00:00 2001 From: Claude Date: Mon, 3 Aug 2026 20:32:45 -0500 Subject: [PATCH 3/6] cg-bid-net: refuse a discard of cards the player does not hold Finding 3 of the 2026-07-29 security review: bids, passes and plays were validated properly, but a kitty discard only checked that five cards were named -- and cg-bid--discard removes cards with cl-set-difference, which silently ignores cards not in the hand. A client naming five cards it did not hold kept all fifteen and played on with more cards than the rules allow. New cg-bid--net-holds-p checks every named card against the seat's hand, respecting multiplicity (five copies of one held card do not pass). The check joins the phase/contractor/arity checks that already live in the discard branch of cg-net-apply-move. Test cgt-bid-net-discard-checked fails against the previous code: the foreign discard was accepted (returned t) and the game advanced to play with a 15-card hand. --- cg-bid-net.el | 14 +++++++++++++- test/card-games-tests.el | 27 +++++++++++++++++++++++++++ 2 files changed, 40 insertions(+), 1 deletion(-) diff --git a/cg-bid-net.el b/cg-bid-net.el index 3ad484c..4f8a145 100644 --- a/cg-bid-net.el +++ b/cg-bid-net.el @@ -143,6 +143,17 @@ and a hand exposed by an open misère is revealed to everyone." ;;;; Apply a move on the host +(defun cg-bid--net-holds-p (hand cards) + "Return non-nil when every card in CARDS is present in HAND. +Multiplicity counts: naming one held card five times is not holding +five cards. Cards are (SUIT . RANK) conses compared with `equal'." + (let ((left (copy-sequence hand))) + (catch 'missing + (dolist (c cards t) + (if (member c left) + (setq left (cl-remove c left :test #'equal :count 1)) + (throw 'missing nil)))))) + (cl-defmethod cg-net-apply-move ((game cg-bid-game) seat move) "Apply MOVE made by absolute SEAT to the host's 500 GAME. MOVE is (bid BID), (pass), (discard CARD...) or (play CARD). Return @@ -157,7 +168,8 @@ non-nil when the move was legal and applied, so the host broadcasts." (cg-bid--auction-act game seat nil) (setq ok t))) (`(discard . ,cards) (when (and (eq phase 'kitty) (eql (cg-get game :contractor) seat) - (= (length cards) 5)) + (= (length cards) 5) + (cg-bid--net-holds-p (cg-bid--hand game seat) cards)) (cg-bid--discard game seat cards) (setq ok t))) (`(play ,card) (when (and (eq phase 'play) (eql (cg-get game :turn) seat) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index f77f312..ccb298d 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -354,6 +354,33 @@ silent default." (should-not (cg-net-apply-move g 0 '(play (0 . 0)))) ; wrong phase )) +(ert-deftest cgt-bid-net-discard-checked () + "The host rejects a kitty discard of cards the seat does not hold. +Finding 3 of the 2026-07-29 review: the other move checks were real, +but a discard only counted its cards, and cl-set-difference silently +ignores cards that are not in the hand -- so five phantom discards +left a 15-card hand in play." + (let* ((cg-bid--human-seats '(0 1 2 3)) + (g (cg-bid--deal (make-instance 'cg-bid-game) 3))) + ;; put the game where a discard is legal: West won the auction + (cg-put g :phase 'kitty) + (cg-put g :contractor 1) + (cg-bid--set-hand g 1 (append (cg-get g :kitty) (cg-bid--hand g 1))) + (let* ((hand (copy-sequence (cg-bid--hand g 1))) + (foreign (cl-subseq (cg-bid--hand g 2) 0 5))) + ;; five cards West does not hold: refused, nothing moves + (should-not (cg-net-apply-move g 1 (cons 'discard foreign))) + (should (equal hand (cg-bid--hand g 1))) + (should (eq 'kitty (cg-get g :phase))) + ;; one held card named five times: also refused + (should-not (cg-net-apply-move g 1 + (cons 'discard (make-list 5 (car hand))))) + (should (eq 'kitty (cg-get g :phase))) + ;; an honest five from the hand is accepted and play begins + (should (cg-net-apply-move g 1 (cons 'discard (cl-subseq hand 0 5)))) + (should (eq 'play (cg-get g :phase))) + (should (= 10 (length (cg-bid--hand g 1))))))) + (ert-deftest cgt-bid-net-loopback () "A 500 move travels client -> host -> filtered broadcast over TCP." (condition-case _ From 640aaca1ae0450adef096ccf265d0e3178066861 Mon Sep 17 00:00:00 2001 From: Claude Date: Mon, 3 Aug 2026 20:34:19 -0500 Subject: [PATCH 4/6] cg-net: bound the line buffer and the connection count Finding 4 of the 2026-07-29 security review: incoming data was collected until a newline arrived with no limit on how much, so a connection sending forever without a newline grew the buffer until memory ran out; the client list could grow the same way. No login was needed (Finding 1). Two bounds, both defcustoms: cg-net-max-line (64 KiB -- generous for a card game) closes any connection whose pending newline-less data exceeds it, and cg-net-max-connections (8) closes connections arriving past the limit before they are seated. Finding 1's loopback default narrows who can reach the port; this bounds what anyone who does reach it can consume -- a mitigation that depends on another setting staying at its default is not a bound. Tests cgt-net-line-cap and cgt-net-connection-cap fail against the previous code: the 80 KiB flooder stayed connected, and a third connection stayed live past a cap of two (= 2 3). --- cg-net.el | 55 ++++++++++++++++++++++++++++--------- test/card-games-tests.el | 58 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 100 insertions(+), 13 deletions(-) diff --git a/cg-net.el b/cg-net.el index 4fcf79d..cb1666e 100644 --- a/cg-net.el +++ b/cg-net.el @@ -77,6 +77,20 @@ deliberately." (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.") @@ -159,7 +173,14 @@ properties stripped (`cg-net--scrub') before HANDLER sees them." (cg-net--scrub (car (read-from-string line)))) (error (message "cg-net: bad message: %S" err))))) ) - (process-put proc 'cg-net-buf (substring buf start))))) + (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 @@ -194,18 +215,26 @@ The socket binds `cg-net-host-address' -- by default, this machine only." (setq cg-net--host nil))) (defun cg-net--host-accept (_server connection _message) - "Set up an accepted CONNECTION: assign a seat and send the current state." - (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-filter connection (cg-net--filter #'cg-net--host-handle)) - (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))) + "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-filter connection (cg-net--filter #'cg-net--host-handle)) + (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." diff --git a/test/card-games-tests.el b/test/card-games-tests.el index ccb298d..cc0f046 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -123,6 +123,64 @@ silent default." (substring (process-contact srv :local) 0 4))) (cg-net-host-stop)))) +(ert-deftest cgt-net-line-cap () + "A connection sending endless bytes with no newline is dropped. +Finding 4 of the 2026-07-29 review: the partial-line buffer grew +without limit, so one connection could consume all available memory. +It is now bounded by `cg-net-max-line'." + (condition-case _ + (delete-process + (make-network-process :name "cgt-probe5" :server t :service 0 + :host "127.0.0.1" :family 'ipv4)) + (error (ert-skip "TCP not available"))) + (cl-flet ((pump () (dotimes (_ 8) (accept-process-output nil 0.05)))) + (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) + (srv (cg-net-host-start hgame 0)) + (port (process-contact srv :service)) + (raw (make-network-process :name "cgt-flood" :host "127.0.0.1" + :service port :family 'ipv4))) + (unwind-protect + (progn + (pump) + (let ((chunk (make-string 8192 ?a))) + (cl-loop repeat 10 while (process-live-p raw) + do (ignore-errors (process-send-string raw chunk)) + (pump))) + ;; 80 KiB with no newline: the host must have hung up on us + (should-not (process-live-p raw))) + (when (process-live-p raw) (delete-process raw)) + (cg-net-host-stop))))) + +(ert-deftest cgt-net-connection-cap () + "Connections beyond `cg-net-max-connections' are refused. +Finding 4's second bound: the client list cannot grow without limit." + (condition-case _ + (delete-process + (make-network-process :name "cgt-probe6" :server t :service 0 + :host "127.0.0.1" :family 'ipv4)) + (error (ert-skip "TCP not available"))) + (cl-flet ((pump () (dotimes (_ 8) (accept-process-output nil 0.05)))) + (let* ((cg-net-max-connections 2) + (hgame (make-instance 'cgt-net-game :env (list :counter 0))) + (srv (cg-net-host-start hgame 0)) + (port (process-contact srv :service)) + (procs nil)) + (unwind-protect + (progn + (dotimes (i 3) + (push (make-network-process :name (format "cgt-c%d" i) + :host "127.0.0.1" :service port + :family 'ipv4) + procs) + (pump)) + (should (= 2 (length (cl-remove-if-not + #'process-live-p + (cg-net-host-clients cg-net--host))))) + ;; the newest connection is the one turned away + (should-not (process-live-p (car procs)))) + (dolist (p procs) (when (process-live-p p) (delete-process p))) + (cg-net-host-stop))))) + ;;;; Gaps (ert-deftest cgt-gaps-deal () From ade2f38ee3be1cddcca9ab526553dbf53ff395cf Mon Sep 17 00:00:00 2001 From: Claude Date: Mon, 3 Aug 2026 20:35:27 -0500 Subject: [PATCH 5/6] cg-net: reap disconnected clients with a process sentinel Finding 5 of the 2026-07-29 security review: nothing watched for a connection ending, so players who left stayed on the client list forever and the host kept trying to send to them. cg-net--host-sentinel removes a closed connection from the list; it is installed on every accepted connection. This also tidies the drops made by the Finding 4 bounds, which delete-process over-limit peers. Seat numbers are still not reused after a departure -- deliberate, and recorded in the sentinel docstring: a stale seat must not be inherited by a stranger mid-game. Named in the handback as remaining behavior. Test cgt-net-reaps-disconnected fails against the previous code: after the client disconnected the list still held it (= 0 1). --- cg-net.el | 11 +++++++++++ test/card-games-tests.el | 26 ++++++++++++++++++++++++++ 2 files changed, 37 insertions(+) diff --git a/cg-net.el b/cg-net.el index cb1666e..42a5105 100644 --- a/cg-net.el +++ b/cg-net.el @@ -214,6 +214,16 @@ The socket binds `cg-net-host-address' -- by default, this machine only." (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." @@ -229,6 +239,7 @@ A connection arriving past `cg-net-max-connections' is closed instead." (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)) (cg-net--send connection (list :type 'welcome :seat seat)) (cg-net--send connection diff --git a/test/card-games-tests.el b/test/card-games-tests.el index cc0f046..c74f344 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -181,6 +181,32 @@ Finding 4's second bound: the client list cannot grow without limit." (dolist (p procs) (when (process-live-p p) (delete-process p))) (cg-net-host-stop))))) +(ert-deftest cgt-net-reaps-disconnected () + "A client that disconnects is removed from the host's client list. +Finding 5 of the 2026-07-29 review: nothing watched for a connection +ending, so departed players stayed listed forever and the host kept +sending to them. A process sentinel now reaps them." + (condition-case _ + (delete-process + (make-network-process :name "cgt-probe7" :server t :service 0 + :host "127.0.0.1" :family 'ipv4)) + (error (ert-skip "TCP not available"))) + (cl-flet ((pump () (dotimes (_ 12) (accept-process-output nil 0.05)))) + (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) + (srv (cg-net-host-start hgame 0)) + (port (process-contact srv :service)) + (cgame (make-instance 'cgt-net-game :env (list :counter 0)))) + (unwind-protect + (progn + (cg-net-connect "127.0.0.1" port "Test" cgame) + (pump) + (should (= 1 (length (cg-net-host-clients cg-net--host)))) + (cg-net-disconnect) + (pump) + (should (= 0 (length (cg-net-host-clients cg-net--host))))) + (cg-net-disconnect) + (cg-net-host-stop))))) + ;;;; Gaps (ert-deftest cgt-gaps-deal () From 1a59003b13c8660bf6ae41c9197b2224e1ad192b Mon Sep 17 00:00:00 2001 From: Claude Date: Mon, 3 Aug 2026 20:37:36 -0500 Subject: [PATCH 6/6] cg-net: check a message is well shaped before any code walks it 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). --- cg-net.el | 54 ++++++++++++++++++++++++++++++++++----- test/card-games-tests.el | 55 ++++++++++++++++++++++++++++++++++++++++ 2 files changed, 102 insertions(+), 7 deletions(-) diff --git a/cg-net.el b/cg-net.el index 42a5105..ac054df 100644 --- a/cg-net.el +++ b/cg-net.el @@ -157,10 +157,45 @@ redisplay, and there is never a reason to honour a remote peer's." (t v)))) (walk x)))) -(defun cg-net--filter (handler) +(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). Strings inside MSG have their text -properties stripped (`cg-net--scrub') before HANDLER sees them." +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) @@ -169,8 +204,10 @@ properties stripped (`cg-net--scrub') before HANDLER sees them." (setq start (1+ nl)) (unless (string-empty-p line) (condition-case err - (funcall handler proc - (cg-net--scrub (car (read-from-string line)))) + (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))) @@ -240,7 +277,8 @@ A connection arriving past `cg-net-max-connections' is closed instead." (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)) + (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 @@ -286,7 +324,9 @@ Return the new `cg-net-client'." :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)) + (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)) diff --git a/test/card-games-tests.el b/test/card-games-tests.el index c74f344..216e25f 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -207,6 +207,61 @@ sending to them. A process sentinel now reaps them." (cg-net-disconnect) (cg-net-host-stop))))) +(ert-deftest cgt-net-shape-gate () + "Malformed messages are dropped before any game code sees them. +Finding 6 of the 2026-07-29 review: parsing can produce structures +that hang or confuse code walking them -- self-references, objects +impersonating internal types. A message must be a proper plist of a +known :type built from plain data; anything else never reaches +`cg-net-apply-move'." + (condition-case _ + (delete-process + (make-network-process :name "cgt-probe8" :server t :service 0 + :host "127.0.0.1" :family 'ipv4)) + (error (ert-skip "TCP not available"))) + (cl-flet ((pump () (dotimes (_ 10) (accept-process-output nil 0.05)))) + (let* ((hgame (make-instance 'cgt-net-game :env (list :counter 0))) + (srv (cg-net-host-start hgame 0)) + (port (process-contact srv :service)) + (applied nil)) + (cl-letf (((symbol-function 'cg-net-apply-move) + (lambda (_game _seat move) (push move applied) nil))) + (let ((raw (make-network-process :name "cgt-shapes" :host "127.0.0.1" + :service port :family 'ipv4))) + (unwind-protect + (progn + (pump) + (dolist (line '("(:type move :move #s(hash-table size 1))" + "(:type move :move #1=(1 2 . #1#))" + "42" + "(:type welcome :seat 3)" + "(:type move :move 5)")) + (process-send-string raw (concat line "\n"))) + (pump) + ;; only the one well-shaped, host-legal move arrived + (should (equal applied (list 5)))) + (when (process-live-p raw) (delete-process raw)) + (cg-net-host-stop))))))) + +(ert-deftest cgt-net-valid-p () + "Unit contract of the wire-shape check itself." + (should (cg-net--valid-p '(:type move :move (bid (7 . 3))) '(hello move))) + (should (cg-net--valid-p '(:type hello :name "n") '(hello move))) + ;; wrong direction: a host does not accept host->client types + (should-not (cg-net--valid-p '(:type welcome :seat 1) '(hello move))) + ;; not a plist / unknown / impersonating / shared structure + (should-not (cg-net--valid-p 42 '(hello move))) + (should-not (cg-net--valid-p '(:type reboot) '(hello move))) + (should-not (cg-net--valid-p (list :type 'move :move (make-hash-table)) + '(hello move))) + (should-not (cg-net--valid-p (record 'cg-net-host nil nil nil 0) '(hello move))) + (let ((shared (list 1 2))) + (should-not (cg-net--valid-p (list :type 'move :move (list shared shared)) + '(hello move)))) + (let ((cyc (list 1 2))) + (setcdr (cdr cyc) cyc) + (should-not (cg-net--valid-p (list :type 'move :move cyc) '(hello move))))) + ;;;; Gaps (ert-deftest cgt-gaps-deal ()