527 lines
17 KiB
EmacsLisp
Executable file
527 lines
17 KiB
EmacsLisp
Executable file
;;; derl.el --- Distributed Erlang networking code.
|
|
|
|
;;; Commentary:
|
|
;;
|
|
;; This module implements a useful subset of the Erlang distribution
|
|
;; protocol, and provides a small API for sending messages to remote
|
|
;; nodes.
|
|
|
|
(require 'net-fsm)
|
|
(require 'epmd)
|
|
(require 'erlext)
|
|
(require 'md5)
|
|
(eval-when-compile
|
|
(require 'cl))
|
|
|
|
(defvar erl-nodeup-hook nil
|
|
"Called with two args, NODE and FSM. NODE is a string of the form
|
|
\"mynode@cockatoo\", FSM is the net-fsm process of the connection.")
|
|
|
|
(defvar erl-nodedown-hook nil
|
|
"Called with one arg, NODE, a string of the form \"mynode@cockatoo\"")
|
|
|
|
(defcustom derl-use-trace-buffer t
|
|
"*Store erlang message communication in a trace buffer."
|
|
:type 'boolean
|
|
:group 'distel)
|
|
|
|
(defvar derl-cookie nil
|
|
"*Cookie to use in distributed erlang connections, or NIL.
|
|
When NIL, we read ~/.erlang.cookie.")
|
|
|
|
;; Local variables
|
|
|
|
(make-variable-buffer-local
|
|
(defvar derl-connection-node nil
|
|
"Local variable recording the node name of the connection."))
|
|
|
|
(make-variable-buffer-local
|
|
(defvar derl-hdrlen 2
|
|
"Size in bytes of length headers of packets. Set to 2 during
|
|
handshake, 4 when connected."))
|
|
|
|
(make-variable-buffer-local
|
|
(defvar derl-alive nil
|
|
"Local variable set to t after handshaking."))
|
|
|
|
(make-variable-buffer-local
|
|
(defvar derl-shutting-down nil
|
|
"Set to T during shutdown, when no longer servicing requests."))
|
|
|
|
(make-variable-buffer-local
|
|
(defvar derl-request-queue nil
|
|
"Messages waiting to be sent to node."))
|
|
|
|
(make-variable-buffer-local
|
|
(defvar derl-remote-links '()
|
|
"List of (LOCAL-PID . REMOTE-PID) for all distributed links (per-node.)
|
|
Used for sending exit signals when the node goes down."))
|
|
|
|
;; Optional feature flags
|
|
(defconst derl-flag-published #x01)
|
|
(defconst derl-flag-atom-cache #x02)
|
|
(defconst derl-flag-extended-references #x04)
|
|
(defconst derl-flag-dist-monitor #x08)
|
|
(defconst derl-flag-fun-tags #x10)
|
|
(defconst derl-flag-dist-monitor-name #x20)
|
|
(defconst derl-flag-hidden-atom-cache #x40)
|
|
(defconst derl-flag-new-fun-tags #x80)
|
|
(defconst derl-flag-extended-pids-ports #x100)
|
|
|
|
;; ------------------------------------------------------------
|
|
;; External API
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun erl-connect (node)
|
|
"Asynchronously connect to NODE. If the connection succeeds,
|
|
`erl-nodeup-hook' is run. If the connection fails, or goes down
|
|
some time later, `erl-nodedown-hook' is run."
|
|
(when (eq node erl-node-name)
|
|
(error "Remote node has the same node name as Emacs: %S" node))
|
|
(let* ((name (derl-node-name node))
|
|
(host (derl-node-host node))
|
|
(buffer (get-buffer-create (derl-buffer-name node)))
|
|
;; faking a closure with backtick. fun eh?
|
|
;; NB: (funcall '(lambda () 1))
|
|
;; => 1
|
|
;; (let ((n 1)) `(lambda () ,n))
|
|
;; => (lambda () 1)
|
|
(fail-cont `(lambda ()
|
|
(kill-buffer ,buffer)
|
|
(derl-nodedown ',node))))
|
|
(epmd-port-please name host
|
|
;; success continuation
|
|
`(lambda (port)
|
|
(fsm-connect ,host port #'derl-state0 ',node
|
|
nil
|
|
,fail-cont
|
|
,buffer))
|
|
fail-cont)))
|
|
|
|
(defun erl-dist-send (pid msg)
|
|
"Send a message to a process on a remote node."
|
|
(derl-dist-request (erl-pid-node pid) #'derl-send pid msg))
|
|
|
|
(defun erl-dist-reg-send (node name msg)
|
|
"Send a message to a registered process on a remote node."
|
|
(derl-dist-request node #'derl-reg-send erl-self name msg))
|
|
|
|
(defun erl-dist-link (pid)
|
|
"Link the current process with the remote PID."
|
|
(derl-dist-request (erl-pid-node pid) #'derl-link erl-self pid))
|
|
|
|
(defun erl-dist-unlink (pid)
|
|
"Link the current process with the remote PID."
|
|
(derl-dist-request (erl-pid-node pid) #'derl-unlink erl-self pid))
|
|
|
|
(defun erl-dist-exit (from to reason)
|
|
"Send an exit signal to a remote process."
|
|
(derl-dist-request (erl-pid-node to) #'derl-exit from to reason))
|
|
|
|
(defun erl-dist-exit2 (from to reason)
|
|
"Send an `exit2' signal to a remote process.
|
|
Use the distribution protocol's EXIT2 message."
|
|
;; I don't know exactly how EXIT2 differs from EXIT. Browsing the
|
|
;; emulator code, it looks like EXIT is for propagating a process
|
|
;; crash, and EXIT2 is for the exit/2 BIF (where FROM isn't
|
|
;; necessarily linked with TO).
|
|
(derl-dist-request (erl-pid-node to) #'derl-exit2 from to reason))
|
|
|
|
;; -----------------------------------------------------------
|
|
;; Handshake protocol states. These follow the protocol diagram in
|
|
;; the distributed_handshake.txt file of lib/kernel/internal_doc/ in
|
|
;; Erlang/OTP.
|
|
;; -----------------------------------------------------------
|
|
|
|
(defun derl-state0 (event node-name)
|
|
"Start state: send-name and then transition."
|
|
(check-event event 'init)
|
|
(setq derl-connection-node node-name)
|
|
(setq fsm-put-data-in-buffer t)
|
|
;; Do nodedown when the buffer is killed in an unexpected way
|
|
;; (e.g. by user)
|
|
(add-hook 'kill-buffer-hook
|
|
(lambda () (when derl-alive (derl-nodedown derl-connection-node))))
|
|
(derl-send-name)
|
|
(fsm-change-state #'derl-recv-status))
|
|
|
|
(defun derl-recv-status (event data)
|
|
"Wait for status message."
|
|
(check-event event 'data)
|
|
(let ((msg (derl-take-msg)))
|
|
(when msg
|
|
(if (string= msg "sok")
|
|
(fsm-change-state #'derl-recv-challenge t)
|
|
(fsm-fail)))))
|
|
|
|
(defun derl-recv-challenge (event data)
|
|
"Receive challenge message, send response and our challenge."
|
|
(check-event event 'data)
|
|
(when (derl-have-msg)
|
|
(goto-char (point-min))
|
|
(erlext-read2) ; skip length
|
|
(let ((tag (erlext-read1)))
|
|
(unless (equal 110 tag) ; tag-check (n)
|
|
(fsm-fail (format nil "wrong-tag: %S" tag))))
|
|
(let ((version (erlext-read2))
|
|
(flags (erlext-read4))
|
|
(challenge (erlext-readn 4))
|
|
(rem-node (buffer-substring (point) (derl-msg-end))))
|
|
(derl-eat-msg)
|
|
(derl-send-challenge-reply challenge)
|
|
(fsm-change-state #'derl-recv-challenge-ack))))
|
|
|
|
(defun derl-string-make-unibyte (string)
|
|
(if (fboundp 'string-make-unibyte)
|
|
(string-make-unibyte string)
|
|
string))
|
|
|
|
(defun derl-recv-challenge-ack (event data)
|
|
"Receive and check challenge ack. If it's OK then the handshake is
|
|
complete and we become live."
|
|
(if (equal event 'closed)
|
|
(message "Distel thinks the cookie is %s. Erlang seems to disagree."
|
|
(erl-cookie)))
|
|
(check-event event 'data)
|
|
(when (derl-have-msg)
|
|
(goto-char (point-min))
|
|
(erlext-read2) ; skip length
|
|
(unless (equal 97 (erlext-read1)) ; tag-check (a)
|
|
(fsm-fail 'wrong-tag))
|
|
(let ((digest (buffer-substring (point) (+ (point) 16))))
|
|
(derl-eat-msg)
|
|
(if (equal (derl-string-make-unibyte (derl-gen-digest (string 0 0 0 42))) digest)
|
|
(derl-go-live)
|
|
(fsm-fail)))))
|
|
|
|
;; Handshake support code
|
|
|
|
(defun derl-send-name ()
|
|
(erase-buffer)
|
|
(derl-send-msg
|
|
(fsm-build-message
|
|
(fsm-encode1 110) ; tag (n)
|
|
(fsm-encode2 5) ; version
|
|
(fsm-encode4 (logior derl-flag-extended-references
|
|
derl-flag-extended-pids-ports))
|
|
(fsm-insert (symbol-name erl-node-name)))))
|
|
|
|
(defun derl-send-challenge-reply (challenge)
|
|
(derl-send-msg (fsm-build-message
|
|
(fsm-encode1 114) ; 114 = ?r
|
|
(fsm-encode4 42)
|
|
(fsm-insert (derl-gen-digest challenge)))))
|
|
|
|
(defun derl-gen-digest (challenge)
|
|
"Generate a message digest as required for the specification's
|
|
gen_digest() function:
|
|
(md5 (concat challenge-as-ascii-decimal cookie))"
|
|
(derl-hexstring-to-binstring
|
|
(md5 (concat (erl-cookie) (derl-int32-to-decimal challenge)))))
|
|
|
|
(defun erl-cookie ()
|
|
(or derl-cookie
|
|
(with-temp-buffer
|
|
(insert-file-contents (concat (getenv "HOME") "/.erlang.cookie"))
|
|
(while (search-forward "\n" nil t)
|
|
(replace-match ""))
|
|
(buffer-string))))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Alive/connected state
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun derl-go-live ()
|
|
(setq derl-alive t)
|
|
(setq derl-hdrlen 4)
|
|
(derl-nodeup derl-connection-node)
|
|
(mapc #'derl-do-request derl-request-queue)
|
|
(setq derl-request-queue nil)
|
|
(fsm-change-state #'derl-alive t))
|
|
|
|
(defun derl-alive (event data)
|
|
(check-event event 'data 'closed)
|
|
(if (eq event 'closed)
|
|
(progn (derl-nodedown derl-connection-node)
|
|
(setq derl-alive nil)
|
|
(fsm-fail))
|
|
(while (derl-handle-tick))
|
|
(when (derl-have-msg)
|
|
(let ((msg (derl-take-msg))
|
|
ctl
|
|
req)
|
|
;; Decode the control message, and the request if it's present
|
|
(let (default-enable-multibyte-characters)
|
|
(with-temp-buffer
|
|
(insert msg)
|
|
(goto-char (point-min))
|
|
(assert (= (erlext-read1) 112)) ; type = pass through..
|
|
(setq ctl (erlext-read-whole-obj))
|
|
(when (< (point) (point-max))
|
|
(setq req (erlext-read-whole-obj)))))
|
|
(ecase (tuple-elt ctl 1)
|
|
((1) ;; link: [1 FROM TO]
|
|
(let ((from (tuple-elt ctl 2))
|
|
(to (tuple-elt ctl 3)))
|
|
(derl-trace-input "LINK: %S %S" from to)
|
|
(add-to-list 'derl-remote-links (cons to from))
|
|
(erl-add-link to from)))
|
|
((2) ;; send: [2 COOKIE TO-PID]
|
|
(let ((to-pid (tuple-elt ctl 3)))
|
|
(derl-trace-input "SEND: %S %S" to-pid req)
|
|
(erl-send to-pid req)))
|
|
((3) ;; exit: [FROM TO REASON]
|
|
(let ((from (tuple-elt ctl 1))
|
|
(to (tuple-elt ctl 2))
|
|
(rsn (tuple-elt ctl 3)))
|
|
(derl-trace-input "EXIT: %S %S %S" from to rsn)
|
|
(erl-send-exit from to rsn)))
|
|
((4) ;; unlink: [4 FROM TO]
|
|
(let ((from (tuple-elt ctl 2))
|
|
(to (tuple-elt ctl 3)))
|
|
(derl-trace-input "UNLINK: %S %S %S" from to)
|
|
(erl-remove-link to from)))
|
|
((6) ;; reg_send: [6 FROM COOKIE NAME]
|
|
(let ((from (tuple-elt ctl 2))
|
|
(name (tuple-elt ctl 4)))
|
|
(derl-trace-input "REG_SEND: %S %S %S" from name req)
|
|
(condition-case data
|
|
(erl-send name req)
|
|
(erl-exit-signal
|
|
;; Ignore the error if the name isn't registered -
|
|
;; that's what the real nodes do. Seems reasonable,
|
|
;; since the send is async, and who knows what the
|
|
;; sender is up to now.
|
|
t))))))
|
|
;; Recursively handle other messages
|
|
(fsm-event 'data 'continue))))
|
|
|
|
(defun derl-handle-tick ()
|
|
(when (derl-have-tick)
|
|
(derl-eat-msg)
|
|
(derl-send-msg "")
|
|
t))
|
|
|
|
(defun derl-have-tick ()
|
|
(goto-char (point-min))
|
|
(and (>= (buffer-size) derl-hdrlen)
|
|
(= 0 (erlext-read4))))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Message buffer helpers
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun derl-send-msg (string)
|
|
"Send a message (with a length header)."
|
|
(fsm-send-string (fsm-build-message
|
|
(fsm-encode (length string) derl-hdrlen)
|
|
(fsm-insert string))))
|
|
|
|
(defun derl-take-msg ()
|
|
"Read and return a message, removing it from the input buffer. If no
|
|
complete message is available, nil is returned and the buffer isn't
|
|
modified."
|
|
(when (derl-have-msg)
|
|
(goto-char (point-min))
|
|
(let* ((length (erlext-read derl-hdrlen))
|
|
(start (point))
|
|
(end (+ start length)))
|
|
(prog1 (buffer-substring start end)
|
|
(derl-eat-msg)))))
|
|
|
|
(defun derl-have-msg ()
|
|
(goto-char (point-min))
|
|
(when (>= (buffer-size) derl-hdrlen)
|
|
(let ((len (erlext-read derl-hdrlen)))
|
|
(>= (buffer-size) (+ derl-hdrlen len)))))
|
|
|
|
(defun derl-msg-end ()
|
|
(goto-char (point-min))
|
|
(+ (point-min) derl-hdrlen (erlext-read derl-hdrlen)))
|
|
|
|
(defun derl-eat-msg ()
|
|
(delete-region (point-min) (derl-msg-end)))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Distributed erlang protocol requests
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun derl-dist-request (node &rest request)
|
|
"Make REQUEST to NODE. If the node isn't live, a connection is
|
|
initiated if necessary and the request is queued."
|
|
(let ((derl-bufname (derl-buffer-name node)))
|
|
(unless (get-buffer derl-bufname)
|
|
(erl-connect node))
|
|
(with-current-buffer derl-bufname
|
|
(cond (derl-shutting-down
|
|
nil)
|
|
(derl-alive
|
|
(derl-do-request request))
|
|
(t
|
|
(push request derl-request-queue))))))
|
|
|
|
(defun derl-do-request (req)
|
|
(apply (car req) (cdr req)))
|
|
|
|
(defun derl-send (pid msg)
|
|
(derl-trace-output "SEND: %S %S" pid msg)
|
|
(derl-send-request (tuple 2 empty-symbol pid) msg))
|
|
|
|
(defun derl-reg-send (from to term)
|
|
(derl-trace-output "REG_SEND: %S %S %S" from to term)
|
|
(derl-send-request (tuple 6 from empty-symbol to) term))
|
|
|
|
(defun derl-link (from to)
|
|
(derl-trace-output "LINK: %S %S" from to)
|
|
(add-to-list 'derl-remote-links (cons from to))
|
|
(derl-send-request (tuple 1 from to) nil t))
|
|
|
|
(defun derl-unlink (from to)
|
|
(derl-trace-output "UNLINK: %S %S" from to)
|
|
(derl-send-request (tuple 4 from to) nil t))
|
|
|
|
(defun derl-exit (from to reason)
|
|
(derl-trace-output "EXIT: %S %S %S" from to reason)
|
|
(derl-send-request (tuple 3 from to reason) nil t))
|
|
|
|
(defun derl-exit2 (from to reason)
|
|
(derl-trace-output "EXIT2: %S %S %S" from to reason)
|
|
(derl-send-request (tuple 8 from to reason) nil t))
|
|
|
|
(defun derl-send-request (control message &optional skip-message)
|
|
(let* ((ctl (erlext-term-to-binary control))
|
|
(msg (if skip-message "" (erlext-term-to-binary message)))
|
|
(len (+ 1 (length ctl) (length msg))))
|
|
(fsm-send-string
|
|
(fsm-build-message
|
|
(fsm-encode4 len)
|
|
(fsm-encode1 121) ; type = pass-through (whatever that means..)
|
|
(fsm-insert ctl)
|
|
(fsm-insert msg)))))
|
|
|
|
;; Tracing
|
|
|
|
(defface derl-trace-output-face
|
|
'((t (:inherit font-lock-string-face)))
|
|
"Face for outgoing messages in the distributed erlang trace
|
|
buffer.")
|
|
|
|
(defface derl-trace-input-face
|
|
'((t (:inherit font-lock-comment-face)))
|
|
"Face for incoming messages in the distributed erlang trace
|
|
buffer.")
|
|
|
|
(defun derl-trace-output (fmt &rest args)
|
|
(let ((msg (format ">> %s" (apply #'format (cons fmt args)))))
|
|
(put-text-property 0 (length msg) 'face 'derl-trace-output-face msg)
|
|
(derl-trace msg)))
|
|
|
|
(defun derl-trace-input (fmt &rest args)
|
|
(let ((msg (format "<< %s" (apply #'format (cons fmt args)))))
|
|
(put-text-property 0 (length msg) 'face 'derl-trace-input-face msg)
|
|
(derl-trace msg)))
|
|
|
|
(defun derl-trace (string)
|
|
(if derl-use-trace-buffer
|
|
(with-current-buffer (get-buffer-create
|
|
(format "*trace %S*" derl-connection-node))
|
|
(goto-char (point-max))
|
|
(insert string)
|
|
(insert "\n"))))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Utility
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun derl-nodedown (node)
|
|
(setq derl-shutting-down t)
|
|
(dolist (link derl-remote-links)
|
|
(let ((local (car link))
|
|
(remote (cdr link)))
|
|
(message "LOCAL: %S REMOTE %S" local remote)
|
|
(erl-send-exit remote local 'noconnection)))
|
|
(run-hook-with-args 'erl-nodedown-hook node))
|
|
|
|
(defun derl-nodeup (node)
|
|
;; NB: only callable from the state machine
|
|
(run-hook-with-args 'erl-nodeup-hook node fsm-process))
|
|
|
|
(eval-and-compile
|
|
(defun derl-int32-to-decimal (s)
|
|
"Converts a 32-bit number (represented as a 4-byte string) into its
|
|
decimal printed representation."
|
|
(format "%.0f" (+ (+ (aref s 3) (* 256 (aref s 2)))
|
|
(* (+ 0.0 (aref s 1) (* 256 (aref s 0)))
|
|
65536)))))
|
|
|
|
;; Try to establish whether we have enough precision in floating-point
|
|
;; The test is pretty lame, even if it succeeds we cannot be sure
|
|
;; it'll work for all int32's
|
|
;; alas, i'm too ignorant to write a good test
|
|
;; the previous version of the test was nicer, but FSFmacs-specific :<
|
|
|
|
(unless (string= "1819634533" (derl-int32-to-decimal "luke"))
|
|
(error "Can't use Emacs's floating-point for `derl-int32-to-decimal'."))
|
|
|
|
(defun derl-hexstring-to-binstring (s)
|
|
"Convert the hexidecimal string S into a binary number represented
|
|
as a string of octets."
|
|
(let ((halves (mapcar #'derl-hexchar-to-int (string-to-list s))))
|
|
(derl-merge-halves halves)))
|
|
|
|
(defun derl-merge-halves (halves &optional acc)
|
|
(if (null halves)
|
|
(apply #'string (reverse acc))
|
|
(derl-merge-halves (cddr halves)
|
|
(cons (+ (ash (car halves) 4)
|
|
(cadr halves))
|
|
acc))))
|
|
|
|
(defun derl-hexchar-to-int (c)
|
|
(cond ((and (<= ?0 c) (<= c ?9))
|
|
(- c ?0))
|
|
((and (<= ?a c) (<= c ?f))
|
|
(+ 10 (- c ?a)))
|
|
(t
|
|
(error "Not hexchar" c))))
|
|
|
|
(defun derl-node-p (node)
|
|
"Check if `node' is a node name, e.g. \"foo@bar\". The @ character
|
|
is not allowed in the node or host name."
|
|
(and (symbolp node)
|
|
(string-match "^[^@]+@[^@]+$" (symbol-name node))))
|
|
|
|
(defun derl-node-name (node)
|
|
"Take the atom node part of a node name, e.g.
|
|
(derl-node-name \"foo@bar\") => \"foo\""
|
|
(assert (derl-node-p node))
|
|
(let ((string (symbol-name node)))
|
|
(string-match "^[^@]+" string)
|
|
(match-string 0 string)))
|
|
|
|
(defun derl-node-host (node)
|
|
"Take the host part of a node name, e.g.
|
|
(derl-node-host \"foo@bar\") => \"bar\""
|
|
(assert (derl-node-p node))
|
|
(let ((string (symbol-name node)))
|
|
(string-match "[^@]+$" string)
|
|
(match-string 0 string)))
|
|
|
|
(defun derl-buffer-name (node)
|
|
(format "*derl %s*" node))
|
|
|
|
;; ------------------------------------------------------------
|
|
;; Testing and playing around
|
|
;; ------------------------------------------------------------
|
|
|
|
(defun derl-go (port)
|
|
(fsm-connect "localhost" port #'derl-state0
|
|
nil
|
|
(lambda (result)
|
|
(message "RESULT: %S" result))
|
|
(lambda ()
|
|
(message "FAIL"))))
|
|
|
|
(provide 'derl)
|
|
|