273 lines
8.7 KiB
EmacsLisp
Executable file
273 lines
8.7 KiB
EmacsLisp
Executable file
; Network state machine engine
|
|
|
|
(eval-when-compile (require 'cl))
|
|
|
|
(defcustom fsm-use-debug-buffer nil
|
|
"*Store fsm debug messages in a buffer."
|
|
:type 'boolean
|
|
:group 'distel)
|
|
|
|
(defvar fsm-buffer-p nil
|
|
"Set to t in buffers belonging to FSMs, for sanity-checking.")
|
|
(defvar fsm-state nil
|
|
"Current state.")
|
|
(defvar fsm-process nil
|
|
"Socket associated with this FSM.")
|
|
(defvar fsm-cont nil
|
|
"Continuation function called with the result of the FSM, if it
|
|
terminates successfully (with fsm-terminate).")
|
|
(defvar fsm-fail-cont nil
|
|
"Continuation function called with the result of the FSM, if it
|
|
terminates in failure.")
|
|
(defvar fsm-work-buffer nil
|
|
"Buffer used for creating messages, dynamically bound in
|
|
`fsm-build-message'")
|
|
(defvar fsm-put-data-in-buffer nil
|
|
"When set to `t', new data is appended to the FSM's buffer in
|
|
addition to being passed as an argument.")
|
|
(defvar fsm-cleanup-hook nil)
|
|
|
|
(make-variable-buffer-local 'fsm-buffer-p)
|
|
(make-variable-buffer-local 'fsm-state)
|
|
(make-variable-buffer-local 'fsm-process)
|
|
(make-variable-buffer-local 'fsm-cont)
|
|
(make-variable-buffer-local 'fsm-fail-cont)
|
|
(make-variable-buffer-local 'fsm-work-buffer)
|
|
(make-variable-buffer-local 'fsm-put-data-in-buffer)
|
|
|
|
(defmacro with-error-cleanup (cleanup &rest body)
|
|
"Execute BODY, and if it hits an error run CLEANUP."
|
|
(let ((success (make-symbol "success")))
|
|
`(let (,success)
|
|
(unwind-protect
|
|
(prog1 (progn ,@body)
|
|
(setq ,success t))
|
|
(unless ,success ,cleanup)))))
|
|
|
|
(put 'with-error-cleanup 'lisp-indent-function 1)
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; External API
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(defun fsm-open-socket (host port)
|
|
(let ((buf (generate-new-buffer " *net-fsm*")))
|
|
(with-error-cleanup (kill-buffer buf)
|
|
(let ((p (open-network-stream "netfsm" buf host port)))
|
|
(set-process-coding-system p 'no-conversion 'no-conversion)
|
|
(if (fboundp 'set-process-filter-multibyte)
|
|
(set-process-filter-multibyte p nil))
|
|
p))))
|
|
|
|
(defun fsm-connect (host port state0 &optional init-arg cont fail-cont buffer)
|
|
"Connect to HOST on PORT and initialize a state machine in
|
|
STATE0 to handle the socket.
|
|
|
|
INIT-ARG is passed to the state machine as the `init' event's
|
|
argument. CONT is a function which is called with the FSM's result if
|
|
it terminates successfully. FAIL-CONT is called with no arguments if
|
|
the FSM fails."
|
|
(with-error-cleanup (funcall fail-cont)
|
|
(let ((socket (fsm-open-socket host port)))
|
|
(fsm-attach socket state0 init-arg cont fail-cont buffer))))
|
|
|
|
(defun fsm-attach (socket state0 &optional init-arg cont fail-cont buffer)
|
|
"Attach a new FSM to SOCKET, starting in STATE0.
|
|
|
|
INIT-ARG is passed to the state machine as the `init' event's
|
|
argument. CONT is a function which is called with the FSM's result if
|
|
it terminates successfully. FAIL-CONT is called with no arguments if
|
|
the FSM fails."
|
|
(when buffer
|
|
(replace-process-buffer socket buffer))
|
|
(with-current-buffer (process-buffer socket)
|
|
(unless (featurep 'xemacs)
|
|
(set-buffer-multibyte nil))
|
|
(setq fsm-buffer-p t)
|
|
(setq fsm-state state0)
|
|
(setq fsm-process socket)
|
|
(setq fsm-cont cont)
|
|
(setq fsm-fail-cont fail-cont)
|
|
(set-process-sentinel socket #'fsm-sentinel)
|
|
(set-process-filter socket #'fsm-filter)
|
|
(init-fsm init-arg)))
|
|
|
|
(defmacro with-fsm (fsm &rest body)
|
|
"Execute BODY in the context (buffer) of FSM."
|
|
`(with-current-buffer (process-buffer ,fsm)
|
|
,@body))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; FSM API
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(defun fsm-change-state (next-state &optional run-now)
|
|
"Change to `next-state'."
|
|
(fsm-debug "STATE: %S -> %S\n" fsm-state next-state)
|
|
(setq fsm-state next-state)
|
|
(when run-now
|
|
(fsm-event 'data "")))
|
|
|
|
(defun fsm-event (event &optional arg)
|
|
"Process `event' in the current state."
|
|
(assert-fsm-invariants)
|
|
(fsm-debug "EVENT: %S - %S\n" event arg)
|
|
(with-error-cleanup
|
|
(fsm-fail (format "Error on event %S in state %S"
|
|
event fsm-state))
|
|
(funcall fsm-state event arg)))
|
|
|
|
(defun fsm-terminate (&optional result)
|
|
"Terminate an FSM with success. The continuation function, if
|
|
available, is called with RESULT."
|
|
(fsm-debug "TERM : %S\n" result)
|
|
(assert-fsm-invariants)
|
|
(let ((cont fsm-cont))
|
|
(fsm-shutdown)
|
|
(when cont
|
|
(funcall cont result))))
|
|
|
|
(defun fsm-fail (&optional why)
|
|
"Terminate an FSM with failure."
|
|
(if why
|
|
(fsm-debug "FAIL : %S (buffer: %S)\n" why (current-buffer))
|
|
(fsm-debug "FAIL : (buffer: %S)\n" (current-buffer)))
|
|
(let ((cont fsm-fail-cont))
|
|
(fsm-shutdown)
|
|
(when cont
|
|
(funcall cont))))
|
|
|
|
(defun fsm-send-string (string)
|
|
"Send a string to the FSM's socket."
|
|
(fsm-debug "SEND : %S\n" string)
|
|
(process-send-string fsm-process string))
|
|
|
|
(defun fsm-send-bytes (chars)
|
|
"Send a list of bytes to the FSM's socket."
|
|
(fsm-send-string (apply #'string chars)))
|
|
|
|
(defun fsm-debug (fmt &rest args)
|
|
"Print a debugging message to the *fsm-debug* buffer."
|
|
(if fsm-use-debug-buffer
|
|
(with-current-buffer (get-buffer-create "*fsm-debug*")
|
|
(unless (featurep 'xemacs)
|
|
(set-buffer-multibyte nil))
|
|
(goto-char (point-max))
|
|
(insert (apply #'format (cons fmt (mapcar #'summarise args)))))))
|
|
|
|
(defun check-event (event &rest allowed)
|
|
"Ensure that an event is allowed. If EVENT is not one of ALLOWED, an
|
|
error is signaled."
|
|
(unless (memq event allowed)
|
|
(error "Can't handle event %S in state %S" event fsm-state)))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Message building
|
|
;; ------------------------------------------------------------
|
|
|
|
(defmacro fsm-build-message (&rest body)
|
|
"Execute BODY, and return the message that it creates via calls to
|
|
fsm-{insert,encode}*."
|
|
`(let ((fsm-work-buffer (let ((default-enable-multibyte-characters nil))
|
|
(generate-new-buffer " *fsm-msg*"))))
|
|
(unwind-protect
|
|
(progn ,@body
|
|
(with-current-buffer fsm-work-buffer (buffer-string)))
|
|
(kill-buffer fsm-work-buffer))))
|
|
|
|
(defmacro fsm-with-message-buffer (&rest body)
|
|
"Execute BODY in the work buffer setup by fsm-build-message. When
|
|
called outside fsm-build-message, BODY is just executed in the current
|
|
buffer."
|
|
`(with-current-buffer (or fsm-work-buffer
|
|
(current-buffer)) ,@body))
|
|
|
|
(put 'fsm-build-message 'lisp-indent-function 'defun)
|
|
(put 'fsm-with-message-buffer 'lisp-indent-function 1)
|
|
|
|
(defun fsm-encode (n size)
|
|
"Encode N as a SIZE-byte integer."
|
|
(ecase size
|
|
((1) (fsm-encode1 n))
|
|
((2) (fsm-encode2 n))
|
|
((4) (fsm-encode4 n))))
|
|
(defun fsm-encode1 (n)
|
|
"Encode N as a 1-byte integer."
|
|
(fsm-with-message-buffer
|
|
(insert n)))
|
|
(defun fsm-encode2 (n)
|
|
"Encode N as a 2-byte big-endian integer."
|
|
(fsm-with-message-buffer
|
|
(insert (logand (ash n -8) 255)
|
|
(logand n 255))))
|
|
(defun fsm-encode4 (n)
|
|
"Encode N as a 4-byte big-endian integer."
|
|
(fsm-with-message-buffer
|
|
(insert (logand (ash n -24) 255)
|
|
(logand (ash n -16) 255)
|
|
(logand (ash n -8) 255)
|
|
(logand n 255))))
|
|
(defun fsm-insert (&rest args)
|
|
"Insert ARGS (characters or strings) into the encoding buffer."
|
|
(fsm-with-message-buffer
|
|
(apply #'insert args)))
|
|
|
|
;; ----------------------------------------------------------------------
|
|
;; Internals
|
|
;; ----------------------------------------------------------------------
|
|
|
|
(defun init-fsm (init-arg)
|
|
"Deliver initial events: INIT, and possibly DATA if some has arrived."
|
|
(let ((data (buffer-string)))
|
|
(erase-buffer)
|
|
(fsm-event 'init init-arg)
|
|
(unless (= 0 (length data))
|
|
(fsm-deliver-data data))))
|
|
|
|
(defun fsm-filter (socket string)
|
|
(with-current-buffer (process-buffer socket)
|
|
(when fsm-state (fsm-deliver-data string))))
|
|
|
|
(defun fsm-deliver-data (data)
|
|
(when fsm-put-data-in-buffer
|
|
;; incorporate the new data into the buffer
|
|
(goto-char (point-max))
|
|
(insert data))
|
|
(fsm-event 'data data))
|
|
|
|
(defun fsm-sentinel (socket event)
|
|
(with-current-buffer (process-buffer socket)
|
|
(fsm-event 'closed event)))
|
|
|
|
(defun fsm-shutdown ()
|
|
(setq fsm-state nil)
|
|
(when fsm-process
|
|
(set-process-sentinel fsm-process nil)
|
|
(kill-buffer (process-buffer fsm-process))))
|
|
|
|
(defun assert-fsm-invariants ()
|
|
(assert fsm-buffer-p)
|
|
(assert (not (null fsm-state))))
|
|
|
|
(defun summarise (x)
|
|
(if (stringp x)
|
|
(with-temp-buffer
|
|
(insert x)
|
|
(goto-char (point-min))
|
|
(while (search-forward "\n" nil t)
|
|
(replace-match "\\n" nil t))
|
|
(elide-string (buffer-string) 30))
|
|
x))
|
|
|
|
(defun elide-string (s len)
|
|
(if (> (length s) len)
|
|
(concat (substring s 0 (- len 3)) "...")
|
|
s))
|
|
|
|
(defun replace-process-buffer (process buffer)
|
|
(let ((oldbuffer (process-buffer process)))
|
|
(set-process-buffer process buffer)
|
|
(kill-buffer oldbuffer)))
|
|
|
|
(provide 'net-fsm)
|