;;; card-games-net.el --- Networked multiplayer for card games  -*- lexical-binding: t; -*-

;; Copyright (C) 2026  Corwin Brust

;; Author: Corwin Brust <corwin@bru.st>
;; Maintainer: Corwin Brust <corwin@bru.st>
;; Keywords: games
;; URL: https://code.bru.st/corwin/card-game.el

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; Host-authoritative networking for the card games.  One Emacs is the
;; HOST: it owns the canonical game and listens for players.  Other
;; Emacsen CONNECT as clients, send move "intents", and receive the new
;; game state to redraw.  Because the games are turn-based there is
;; nothing to merge, so this is a simple authoritative server rather
;; than a CRDT; crdt.el is kept in reserve for any future free-form
;; shared state.
;;
;; Transport is line-delimited s-expressions over `make-network-process'
;; (plain TCP), so it works wherever Emacs has TCP -- including an
;; Android client joining a desktop host.  A message is a plist with a
;; `:type' key:
;;
;;   client -> host:  (:type hello :name NAME)
;;                    (:type move  :move MOVE)
;;   host -> client:  (:type welcome :seat N)
;;                    (:type state  :state SEXP)
;;
;; A game plugs in by defining methods on `card-games-net-apply-move' (host
;; side) and, if its state is not just the env plist, on
;; `card-games-net-game-state' / `card-games-net-set-game-state'.  Clients add a
;; redraw function to `card-games-net-state-functions'.

;;; Code:

(require 'card-games-core)

(defgroup card-games-net nil
  "Networked play for card games."
  :group 'card-games
  :prefix "card-games-net-")

(defcustom card-games-net-port 7500
  "Default TCP port used to host or join a game."
  :type 'integer :group 'card-games-net)

(defcustom card-games-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 'card-games-net)

(defcustom card-games-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 'card-games-net)

(defcustom card-games-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 'card-games-net)

(defvar card-games-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.")

(defvar card-games-net-connect-functions nil
  "Abnormal hook run on the host when a client connects.
Each function is called with (HOST SEAT): the `card-games-net-host' struct and
the seat number just assigned to the new connection.")

;;;; Game integration points

(cl-defgeneric card-games-net-apply-move (game seat move)
  "Apply MOVE made by SEAT to GAME on the host.
Return non-nil when the move was accepted (and state should broadcast).")

(cl-defgeneric card-games-net-game-state (game &optional seat)
  "Return a `read'able representation of GAME's shared state for SEAT.
SEAT is the recipient's seat number, letting a game hide other players'
private information; nil requests the full host view.")

(cl-defmethod card-games-net-game-state ((game card-games-game) &optional _seat)
  "Default: return GAME's env plist (no per-seat filtering)."
  (oref game env))

(cl-defgeneric card-games-net-set-game-state (game state)
  "Replace GAME's shared state with STATE on a client.")

(cl-defmethod card-games-net-set-game-state ((game card-games-game) state)
  "Default: install STATE as GAME's env plist."
  (oset game env state))

;;;; Wire protocol

(defun card-games-net--send (proc msg)
  "Send MSG (a sexp) to PROC as one newline-terminated line."
  (when (process-live-p proc)
    (let ((print-length nil) (print-level nil))
      (process-send-string proc (concat (prin1-to-string msg) "\n")))))

(defun card-games-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 card-games-net-max-nodes 20000
  "Upper bound on the number of nodes accepted in one wire message.")

(defun card-games-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 `card-games-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) card-games-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 card-games-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
well-shaped message (`card-games-net--valid-p') whose type is in TYPES;
strings inside MSG have their text properties stripped first, by
`card-games-net--scrub'.  Anything else is dropped where it lands."
  (lambda (proc string)
    (let ((buf (concat (or (process-get proc 'card-games-net-buf) "") string))
          (start 0) nl)
      (while (setq nl (cl-search "\n" buf :start2 start))
        (let ((line (substring buf start nl)))
          (setq start (1+ nl))
          (unless (string-empty-p line)
            (condition-case err
                (let ((msg (car (read-from-string line))))
                  (if (card-games-net--valid-p msg types)
                      (funcall handler proc (card-games-net--scrub msg))
                    (message "card-games-net: dropped malformed message")))
              (error (message "card-games-net: bad message: %S" err))))))
      (let ((rest (substring buf start)))
        (if (> (length rest) card-games-net-max-line)
            (progn
              (process-put proc 'card-games-net-buf nil)
              (message "card-games-net: dropping %s (line over %d bytes)"
                       (process-name proc) card-games-net-max-line)
              (delete-process proc))
          (process-put proc 'card-games-net-buf rest))))))

;;;; Host

(cl-defstruct (card-games-net-host (:constructor card-games-net--host-make))
  server game (clients nil) (next-seat 0))

(defvar card-games-net--host nil
  "The running `card-games-net-host', or nil when not hosting.")

(defun card-games-net-hosting-p ()
  "Return non-nil when this Emacs is hosting a game."
  (and card-games-net--host (process-live-p (card-games-net-host-server card-games-net--host))))

(defun card-games-net-host-start (game &optional port)
  "Begin hosting GAME on PORT (default `card-games-net-port').
Return the server process.  The socket binds
`card-games-net-host-address' -- by default, this machine only."
  (let* ((port (or port card-games-net-port))
         (server (make-network-process
                  :name "card-games-host" :server t :service port
                  :host card-games-net-host-address :family 'ipv4 :coding 'utf-8
                  :log #'card-games-net--host-accept)))
    (setq card-games-net--host (card-games-net--host-make :server server :game game))
    server))

(defun card-games-net-host-stop ()
  "Stop hosting and close all client connections."
  (when card-games-net--host
    (dolist (c (card-games-net-host-clients card-games-net--host))
      (when (process-live-p c) (delete-process c)))
    (when (process-live-p (card-games-net-host-server card-games-net--host))
      (delete-process (card-games-net-host-server card-games-net--host)))
    (setq card-games-net--host nil)))

(defun card-games-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 card-games-net--host
      (setf (card-games-net-host-clients card-games-net--host)
            (delq proc (card-games-net-host-clients card-games-net--host))))))

(defun card-games-net--host-accept (_server connection _message)
  "Set up an accepted CONNECTION: assign a seat and send the current state.
A connection arriving past `card-games-net-max-connections' is closed instead."
  (if (>= (length (cl-remove-if-not #'process-live-p
                                    (card-games-net-host-clients card-games-net--host)))
          card-games-net-max-connections)
      (progn
        (message "card-games-net: refusing connection (table is at %d)"
                 card-games-net-max-connections)
        (delete-process connection))
    (let ((seat (card-games-net-host-next-seat card-games-net--host)))
      (setf (card-games-net-host-next-seat card-games-net--host) (1+ seat))
      (push connection (card-games-net-host-clients card-games-net--host))
      (process-put connection 'card-games-net-seat seat)
      (set-process-coding-system connection 'utf-8 'utf-8)
      (set-process-sentinel connection #'card-games-net--host-sentinel)
      (set-process-filter connection
                          (card-games-net--filter #'card-games-net--host-handle '(hello move)))
      (card-games-net--send connection (list :type 'welcome :seat seat))
      (card-games-net--send connection
                    (list :type 'state
                          :state (card-games-net-game-state (card-games-net-host-game card-games-net--host) seat)))
      (run-hook-with-args 'card-games-net-connect-functions card-games-net--host seat))))

(defun card-games-net--host-handle (proc msg)
  "Handle one message MSG from a client PROC on the host."
  (pcase (plist-get msg :type)
    ('hello (process-put proc 'card-games-net-name (plist-get msg :name)))
    ('move
     (let ((seat (process-get proc 'card-games-net-seat))
           (game (card-games-net-host-game card-games-net--host)))
       (when (card-games-net-apply-move game seat (plist-get msg :move))
         (card-games-net-host-broadcast))))))

(defun card-games-net-host-broadcast ()
  "Send each connected client the game state filtered for its seat."
  (when card-games-net--host
    (let ((game (card-games-net-host-game card-games-net--host)))
      (dolist (c (card-games-net-host-clients card-games-net--host))
        (card-games-net--send c (list :type 'state
                              :state (card-games-net-game-state
                                      game (process-get c 'card-games-net-seat))))))))

;;;; Client

(cl-defstruct (card-games-net-client (:constructor card-games-net--client-make))
  proc game (seat nil))

(defvar card-games-net--client nil
  "The active `card-games-net-client', or nil when not connected.")

(defun card-games-net-connected-p ()
  "Return non-nil when connected to a host as a client."
  (and card-games-net--client (process-live-p (card-games-net-client-proc card-games-net--client))))

(defun card-games-net-connect (host port name game)
  "Connect to HOST on PORT as NAME, syncing into the local GAME.
Return the new `card-games-net-client'."
  (let ((proc (make-network-process
               :name "card-games-client" :host host :service port
               :family 'ipv4 :coding 'utf-8)))
    (setq card-games-net--client (card-games-net--client-make :proc proc :game game))
    (set-process-coding-system proc 'utf-8 'utf-8)
    (set-process-filter proc
                        (card-games-net--filter #'card-games-net--client-handle
                                        '(welcome state full)))
    (card-games-net--send proc (list :type 'hello :name name))
    card-games-net--client))

(defun card-games-net-disconnect ()
  "Disconnect from the host."
  (when (and card-games-net--client (process-live-p (card-games-net-client-proc card-games-net--client)))
    (delete-process (card-games-net-client-proc card-games-net--client)))
  (setq card-games-net--client nil))

(defun card-games-net--client-handle (_proc msg)
  "Handle one message MSG from the host on a client."
  (pcase (plist-get msg :type)
    ('welcome (setf (card-games-net-client-seat card-games-net--client) (plist-get msg :seat)))
    ('state
     (let ((game (card-games-net-client-game card-games-net--client)))
       (card-games-net-set-game-state game (plist-get msg :state))
       (run-hook-with-args 'card-games-net-state-functions game)))))

(defun card-games-net-send-move (move)
  "Send MOVE to the host from this client."
  (card-games-net--send (card-games-net-client-proc card-games-net--client) (list :type 'move :move move)))

(provide 'card-games-net)
;;; card-games-net.el ends here
