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

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)
+(defun cg-net--filter (handler)
-  "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
+HANDLER is called with (PROC MSG)."
-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)
@@ -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))))
+                (funcall handler proc (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)))
+      (process-put proc 'cg-net-buf (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
 
@@ -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.
+  "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
+                  :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.
+  "Set up an accepted CONNECTION: assign a seat and send the current state."
-A connection arriving past `cg-net-max-connections' is closed instead."
+  (let ((seat (cg-net-host-next-seat cg-net--host)))
-  (if (>= (length (cl-remove-if-not #'process-live-p
+    (setf (cg-net-host-next-seat cg-net--host) (1+ seat))
-                                    (cg-net-host-clients cg-net--host)))
+    (push connection (cg-net-host-clients cg-net--host))
-          cg-net-max-connections)
+    (process-put connection 'cg-net-seat seat)
-      (progn
+    (set-process-coding-system connection 'utf-8 'utf-8)
-        (message "cg-net: refusing connection (table is at %d)"
+    (set-process-filter connection (cg-net--filter #'cg-net--host-handle))
-                 cg-net-max-connections)
+    (cg-net--send connection (list :type 'welcome :seat seat))
-        (delete-process connection))
+    (cg-net--send connection
-    (let ((seat (cg-net-host-next-seat cg-net--host)))
+                  (list :type 'state
-      (setf (cg-net-host-next-seat cg-net--host) (1+ seat))
+                        :state (cg-net-game-state (cg-net-host-game cg-net--host) seat)))
-      (push connection (cg-net-host-clients cg-net--host))
+    (run-hook-with-args 'cg-net-connect-functions cg-net--host seat)))
-      (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."
@@ -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
+    (set-process-filter proc (cg-net--filter #'cg-net--client-handle))
-                        (cg-net--filter #'cg-net--client-handle
-                                        '(welcome state full)))
     (cg-net--send proc (list :type 'hello :name name))
     cg-net--client))
 

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 _