diff --git a/cg-bid-net.el b/cg-bid-net.el index 4f8a145..3ad484c 100644 --- a/cg-bid-net.el +++ b/cg-bid-net.el @@ -143,17 +143,6 @@ 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 @@ -168,8 +157,7 @@ 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) - (cg-bid--net-holds-p (cg-bid--hand game seat) cards)) + (= (length cards) 5)) (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 ac054df..8019c5e 100644 --- a/cg-net.el +++ b/cg-net.el @@ -60,37 +60,6 @@ "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.") @@ -130,72 +99,9 @@ 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)))) - -(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) +(defun cg-net--filter (handler) "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." +HANDLER is called with (PROC MSG)." (lambda (proc string) (let ((buf (concat (or (process-get proc 'cg-net-buf) "") string)) (start 0) nl) @@ -204,20 +110,10 @@ strings inside MSG have their text properties stripped first, by (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"))) + (funcall handler proc (car (read-from-string line))) (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)))))) + (process-put proc 'cg-net-buf (substring buf start))))) ;;;; Host @@ -232,12 +128,11 @@ strings inside MSG have their text properties stripped first, by (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." + "Begin hosting GAME on PORT (default `cg-net-port'). Return the server process." (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 + :host "0.0.0.0" :family 'ipv4 :coding 'utf-8 :log #'cg-net--host-accept))) (setq cg-net--host (cg-net--host-make :server server :game game)) server)) @@ -251,39 +146,19 @@ 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." - (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)))) + "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))) (defun cg-net--host-handle (proc msg) "Handle one message MSG from a client PROC on the host." @@ -324,9 +199,7 @@ 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 - '(welcome state full))) + (set-process-filter proc (cg-net--filter #'cg-net--client-handle)) (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 216e25f..ccb113b 100644 --- a/test/card-games-tests.el +++ b/test/card-games-tests.el @@ -68,200 +68,6 @@ (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 () @@ -493,33 +299,6 @@ known :type built from plain data; anything else never reaches (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 _