corwin/card-game.el
1
0
Fork 0
Code Issues Pull requests Projects Releases 1 Packages Wiki Activity Actions

Compare commits

base: corwin:1a59003b13c8660bf6ae41c9197b2224e1ad192b
Branches Tags
corwin:master
corwin:1.0.91
..
compare: corwin:7918daf7ef6ab2ea4d4fc6391e49fde696cb5856
Branches Tags
corwin:master
corwin:1.0.91

No commits in common. "1a59003b13c8660bf6ae41c9197b2224e1ad192b" and "7918daf7ef6ab2ea4d4fc6391e49fde696cb5856" have entirely different histories.
1a59003b13 ... 7918daf7ef

3 changed files with 20 additions and 380 deletions
Download patch file Download diff file Expand all files Collapse all files

14
cg-bid-net.el
View file

@ -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)

147
cg-net.el
View file

@ -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))
"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-sentinel connection #'cg-net--host-sentinel)
(set-process-filter connection
(cg-net--filter #'cg-net--host-handle '(hello move)))
(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))))
(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))

221
test/card-games-tests.el
View file

@ -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 _