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/cg-net.el b/cg-net.el index 8019c5e..ac054df 100644 --- a/cg-net.el +++ b/cg-net.el @@ -60,6 +60,37 @@ "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.") @@ -99,9 +130,72 @@ 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--filter (handler) +(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)." +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) @@ -110,10 +204,20 @@ 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))) + (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))))) ) - (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 @@ -128,11 +232,12 @@ HANDLER is called with (PROC MSG)." (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)) @@ -146,19 +251,39 @@ HANDLER is called with (PROC MSG)." (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." - (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-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." @@ -199,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 ccb113b..216e25f 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -68,6 +68,200 @@ (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))))) + +(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)))) + +(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))))) + +(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))))) + +(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 () @@ -299,6 +493,33 @@ (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 _