lib/distel/elisp/derl.el

   1 ;;; derl.el --- Distributed Erlang networking code.
   2
   3 ;;; Commentary:
   4 ;;
   5 ;; This module implements a useful subset of the Erlang distribution
   6 ;; protocol, and provides a small API for sending messages to remote
   7 ;; nodes.
   8
   9 (require 'net-fsm)
  10 (require 'epmd)
  11 (require 'erlext)
  12 (require 'md5)
  13 (eval-when-compile
  14   (require 'cl))
  15
  16 (defvar erl-nodeup-hook nil
  17   "Called with two args, NODE and FSM. NODE is a string of the form
  18 \"mynode@cockatoo\", FSM is the net-fsm process of the connection.")
  19
  20 (defvar erl-nodedown-hook nil
  21   "Called with one arg, NODE, a string of the form \"mynode@cockatoo\"")
  22
  23 (defcustom derl-use-trace-buffer t
  24   "*Store erlang message communication in a trace buffer."
  25   :type 'boolean
  26   :group 'distel)
  27
  28 (defvar derl-cookie nil
  29   "*Cookie to use in distributed erlang connections, or NIL.
  30 When NIL, we read ~/.erlang.cookie.")
  31
  32 ;; Local variables
  33
  34 (make-variable-buffer-local
  35  (defvar derl-connection-node nil
  36    "Local variable recording the node name of the connection."))
  37
  38 (make-variable-buffer-local
  39  (defvar derl-hdrlen 2
  40    "Size in bytes of length headers of packets. Set to 2 during
  41 handshake, 4 when connected."))
  42
  43 (make-variable-buffer-local
  44  (defvar derl-alive nil
  45   "Local variable set to t after handshaking."))
  46
  47 (make-variable-buffer-local
  48  (defvar derl-shutting-down nil
  49    "Set to T during shutdown, when no longer servicing requests."))
  50
  51 (make-variable-buffer-local
  52  (defvar derl-request-queue nil
  53   "Messages waiting to be sent to node."))
  54
  55 (make-variable-buffer-local
  56  (defvar derl-remote-links '()
  57   "List of (LOCAL-PID . REMOTE-PID) for all distributed links (per-node.)
  58 Used for sending exit signals when the node goes down."))
  59
  60 ;; Optional feature flags
  61 (defconst derl-flag-published           #x01)
  62 (defconst derl-flag-atom-cache          #x02)
  63 (defconst derl-flag-extended-references #x04)
  64 (defconst derl-flag-dist-monitor        #x08)
  65 (defconst derl-flag-fun-tags            #x10)
  66 (defconst derl-flag-dist-monitor-name   #x20)
  67 (defconst derl-flag-hidden-atom-cache   #x40)
  68 (defconst derl-flag-new-fun-tags        #x80)
  69 (defconst derl-flag-extended-pids-ports #x100)
  70
  71 ;; ------------------------------------------------------------
  72 ;; External API
  73 ;; ------------------------------------------------------------
  74
  75 (defun erl-connect (node)
  76   "Asynchronously connect to NODE. If the connection succeeds,
  77 `erl-nodeup-hook' is run. If the connection fails, or goes down
  78 some time later, `erl-nodedown-hook' is run."
  79   (when (eq node erl-node-name)
  80     (error "Remote node has the same node name as Emacs: %S" node))
  81   (let* ((name (derl-node-name node))
  82          (host (derl-node-host node))
  83          (buffer (get-buffer-create (derl-buffer-name node)))
  84          ;; faking a closure with backtick. fun eh?
  85          ;; NB: (funcall '(lambda () 1))
  86          ;;       => 1
  87          ;;     (let ((n 1)) `(lambda () ,n))
  88          ;;       => (lambda () 1)
  89          (fail-cont `(lambda ()
  90                        (kill-buffer ,buffer)
  91                        (derl-nodedown ',node))))
  92     (epmd-port-please name host
  93                       ;; success continuation
  94                       `(lambda (port)
  95                          (fsm-connect ,host port #'derl-state0 ',node
  96                                       nil
  97                                       ,fail-cont
  98                                       ,buffer))
  99                       fail-cont)))
 100
 101 (defun erl-dist-send (pid msg)
 102   "Send a message to a process on a remote node."
 103   (derl-dist-request (erl-pid-node pid) #'derl-send pid msg))
 104
 105 (defun erl-dist-reg-send (node name msg)
 106   "Send a message to a registered process on a remote node."
 107   (derl-dist-request node #'derl-reg-send erl-self name msg))
 108
 109 (defun erl-dist-link (pid)
 110   "Link the current process with the remote PID."
 111   (derl-dist-request (erl-pid-node pid) #'derl-link erl-self pid))
 112
 113 (defun erl-dist-unlink (pid)
 114   "Link the current process with the remote PID."
 115   (derl-dist-request (erl-pid-node pid) #'derl-unlink erl-self pid))
 116
 117 (defun erl-dist-exit (from to reason)
 118   "Send an exit signal to a remote process."
 119   (derl-dist-request (erl-pid-node to) #'derl-exit from to reason))
 120
 121 (defun erl-dist-exit2 (from to reason)
 122   "Send an `exit2' signal to a remote process.
 123 Use the distribution protocol's EXIT2 message."
 124   ;; I don't know exactly how EXIT2 differs from EXIT. Browsing the
 125   ;; emulator code, it looks like EXIT is for propagating a process
 126   ;; crash, and EXIT2 is for the exit/2 BIF (where FROM isn't
 127   ;; necessarily linked with TO).
 128   (derl-dist-request (erl-pid-node to) #'derl-exit2 from to reason))
 129
 130 ;; -----------------------------------------------------------
 131 ;; Handshake protocol states. These follow the protocol diagram in
 132 ;; the distributed_handshake.txt file of lib/kernel/internal_doc/ in
 133 ;; Erlang/OTP.
 134 ;; -----------------------------------------------------------
 135
 136 (defun derl-state0 (event node-name)
 137   "Start state: send-name and then transition."
 138   (check-event event 'init)
 139   (setq derl-connection-node node-name)
 140   (setq fsm-put-data-in-buffer t)
 141   ;; Do nodedown when the buffer is killed in an unexpected way
 142   ;; (e.g. by user)
 143   (add-hook 'kill-buffer-hook
 144             (lambda () (when derl-alive (derl-nodedown derl-connection-node))))
 145   (derl-send-name)
 146   (fsm-change-state #'derl-recv-status))
 147
 148 (defun derl-recv-status (event data)
 149   "Wait for status message."
 150   (check-event event 'data)
 151   (let ((msg (derl-take-msg)))
 152     (when msg
 153       (if (string= msg "sok")
 154           (fsm-change-state #'derl-recv-challenge t)
 155         (fsm-fail)))))
 156
 157 (defun derl-recv-challenge (event data)
 158   "Receive challenge message, send response and our challenge."
 159   (check-event event 'data)
 160   (when (derl-have-msg)
 161     (goto-char (point-min))
 162     (erlext-read2)                      ; skip length
 163     (let ((tag (erlext-read1)))
 164       (unless (equal 110 tag)   ; tag-check (n)
 165         (fsm-fail (format nil "wrong-tag: %S" tag))))
 166     (let ((version (erlext-read2))
 167           (flags   (erlext-read4))
 168           (challenge (erlext-readn 4))
 169           (rem-node (buffer-substring (point) (derl-msg-end))))
 170       (derl-eat-msg)
 171       (derl-send-challenge-reply challenge)
 172       (fsm-change-state #'derl-recv-challenge-ack))))
 173
 174 (defun derl-recv-challenge-ack (event data)
 175   "Receive and check challenge ack. If it's OK then the handshake is
 176 complete and we become live."
 177   (check-event event 'data)
 178   (when (derl-have-msg)
 179     (goto-char (point-min))
 180     (erlext-read2)                      ; skip length
 181     (unless (equal 97 (erlext-read1))   ; tag-check (a)
 182       (fsm-fail 'wrong-tag))
 183     (let ((digest (buffer-substring (point) (+ (point) 16))))
 184       (derl-eat-msg)
 185       (if (equal (derl-gen-digest (string 0 0 0 42)) digest)
 186           (derl-go-live)
 187         (fsm-fail)))))
 188
 189 ;; Handshake support code
 190
 191 (defun derl-send-name ()
 192   (erase-buffer)
 193   (derl-send-msg
 194    (fsm-build-message
 195      (fsm-encode1 110)                  ; tag (n)
 196      (fsm-encode2 5)                    ; version
 197      (fsm-encode4 (logior derl-flag-extended-references
 198                           derl-flag-extended-pids-ports))
 199      (fsm-insert (symbol-name erl-node-name)))))
 200
 201 (defun derl-send-challenge-reply (challenge)
 202   (derl-send-msg (fsm-build-message
 203                    (fsm-encode1 114)    ; 114 = ?r
 204                    (fsm-encode4 42)
 205                    (fsm-insert (derl-gen-digest challenge)))))
 206
 207 (defun derl-gen-digest (challenge)
 208   "Generate a message digest as required for the specification's
 209 gen_digest() function:
 210   (md5 (concat challenge-as-ascii-decimal cookie))"
 211   (derl-hexstring-to-binstring
 212    (md5 (concat (erl-cookie) (derl-int32-to-decimal challenge)))))
 213
 214 (defun erl-cookie ()
 215   (or derl-cookie
 216       (with-temp-buffer
 217         (insert-file-contents (concat (getenv "HOME") "/.erlang.cookie"))
 218         (while (search-forward "\n" nil t)
 219           (replace-match ""))
 220         (buffer-string))))
 221
 222 ;; ------------------------------------------------------------
 223 ;; Alive/connected state
 224 ;; ------------------------------------------------------------
 225
 226 (defun derl-go-live ()
 227   (setq derl-alive t)
 228   (setq derl-hdrlen 4)
 229   (derl-nodeup derl-connection-node)
 230   (mapc #'derl-do-request derl-request-queue)
 231   (setq derl-request-queue nil)
 232   (fsm-change-state #'derl-alive t))
 233
 234 (defun derl-alive (event data)
 235   (check-event event 'data 'closed)
 236   (if (eq event 'closed)
 237       (progn (derl-nodedown derl-connection-node)
 238              (setq derl-alive nil)
 239              (fsm-fail))
 240     (while (derl-handle-tick))
 241     (when (derl-have-msg)
 242       (let ((msg (derl-take-msg))
 243             ctl
 244             req)
 245         ;; Decode the control message, and the request if it's present
 246         (let (default-enable-multibyte-characters)
 247           (with-temp-buffer
 248             (insert msg)
 249             (goto-char (point-min))
 250             (assert (= (erlext-read1) 112)) ; type = pass through..
 251             (setq ctl (erlext-read-whole-obj))
 252             (when (< (point) (point-max))
 253               (setq req (erlext-read-whole-obj)))))
 254         (ecase (tuple-elt ctl 1)
 255           ((1) ;; link: [1 FROM TO]
 256            (let ((from (tuple-elt ctl 2))
 257                  (to   (tuple-elt ctl 3)))
 258              (derl-trace-input "LINK: %S %S" from to)
 259              (add-to-list 'derl-remote-links (cons to from))
 260              (erl-add-link to from)))
 261           ((2) ;; send: [2 COOKIE TO-PID]
 262            (let ((to-pid (tuple-elt ctl 3)))
 263              (derl-trace-input "SEND: %S %S" to-pid req)
 264              (erl-send to-pid req)))
 265           ((3) ;; exit: [FROM TO REASON]
 266            (let ((from (tuple-elt ctl 1))
 267                  (to   (tuple-elt ctl 2))
 268                  (rsn  (tuple-elt ctl 3)))
 269              (derl-trace-input "EXIT: %S %S %S" from to rsn)
 270              (erl-send-exit from to rsn)))
 271           ((4) ;; unlink: [4 FROM TO]
 272            (let ((from (tuple-elt ctl 2))
 273                  (to   (tuple-elt ctl 3)))
 274              (derl-trace-input "UNLINK: %S %S %S" from to)
 275              (erl-remove-link to from)))
 276           ((6) ;; reg_send: [6 FROM COOKIE NAME]
 277            (let ((from (tuple-elt ctl 2))
 278                  (name (tuple-elt ctl 4)))
 279              (derl-trace-input "REG_SEND: %S %S %S" from name req)
 280              (condition-case data
 281                  (erl-send name req)
 282                (erl-exit-signal
 283                 ;; Ignore the error if the name isn't registered -
 284                 ;; that's what the real nodes do. Seems reasonable,
 285                 ;; since the send is async, and who knows what the
 286                 ;; sender is up to now.
 287                 t))))))
 288       ;; Recursively handle other messages
 289       (fsm-event 'data 'continue))))
 290
 291 (defun derl-handle-tick ()
 292   (when (derl-have-tick)
 293     (derl-eat-msg)
 294     (derl-send-msg "")
 295     t))
 296
 297 (defun derl-have-tick ()
 298   (goto-char (point-min))
 299   (and (>= (buffer-size) derl-hdrlen)
 300        (= 0 (erlext-read4))))
 301
 302 ;; ------------------------------------------------------------
 303 ;; Message buffer helpers
 304 ;; ------------------------------------------------------------
 305
 306 (defun derl-send-msg (string)
 307   "Send a message (with a length header)."
 308   (fsm-send-string (fsm-build-message
 309                      (fsm-encode (length string) derl-hdrlen)
 310                      (fsm-insert string))))
 311
 312 (defun derl-take-msg ()
 313   "Read and return a message, removing it from the input buffer. If no
 314 complete message is available, nil is returned and the buffer isn't
 315 modified."
 316   (when (derl-have-msg)
 317     (goto-char (point-min))
 318     (let* ((length (erlext-read derl-hdrlen))
 319            (start  (point))
 320            (end    (+ start length)))
 321       (prog1 (buffer-substring start end)
 322         (derl-eat-msg)))))
 323
 324 (defun derl-have-msg ()
 325   (goto-char (point-min))
 326   (when (>= (buffer-size) derl-hdrlen)
 327     (let ((len (erlext-read derl-hdrlen)))
 328       (>= (buffer-size) (+ derl-hdrlen len)))))
 329
 330 (defun derl-msg-end ()
 331   (goto-char (point-min))
 332   (+ (point-min) derl-hdrlen (erlext-read derl-hdrlen)))
 333
 334 (defun derl-eat-msg ()
 335   (delete-region (point-min) (derl-msg-end)))
 336
 337 ;; ------------------------------------------------------------
 338 ;; Distributed erlang protocol requests
 339 ;; ------------------------------------------------------------
 340
 341 (defun derl-dist-request (node &rest request)
 342   "Make REQUEST to NODE. If the node isn't live, a connection is
 343 initiated if necessary and the request is queued."
 344   (let ((derl-bufname (derl-buffer-name node)))
 345     (unless (get-buffer derl-bufname)
 346       (erl-connect node))
 347     (with-current-buffer derl-bufname
 348       (cond (derl-shutting-down
 349              nil)
 350             (derl-alive
 351              (derl-do-request request))
 352             (t
 353              (push request derl-request-queue))))))
 354
 355 (defun derl-do-request (req)
 356   (apply (car req) (cdr req)))
 357
 358 (defun derl-send (pid msg)
 359   (derl-trace-output "SEND: %S %S" pid msg)
 360   (derl-send-request (tuple 2 empty-symbol pid) msg))
 361
 362 (defun derl-reg-send (from to term)
 363   (derl-trace-output "REG_SEND: %S %S %S" from to term)
 364   (derl-send-request (tuple 6 from empty-symbol to) term))
 365
 366 (defun derl-link (from to)
 367   (derl-trace-output "LINK: %S %S" from to)
 368   (add-to-list 'derl-remote-links (cons from to))
 369   (derl-send-request (tuple 1 from to) nil t))
 370
 371 (defun derl-unlink (from to)
 372   (derl-trace-output "UNLINK: %S %S" from to)
 373   (derl-send-request (tuple 4 from to) nil t))
 374
 375 (defun derl-exit (from to reason)
 376   (derl-trace-output "EXIT: %S %S %S" from to reason)
 377   (derl-send-request (tuple 3 from to reason) nil t))
 378
 379 (defun derl-exit2 (from to reason)
 380   (derl-trace-output "EXIT2: %S %S %S" from to reason)
 381   (derl-send-request (tuple 8 from to reason) nil t))
 382
 383 (defun derl-send-request (control message &optional skip-message)
 384   (let* ((ctl (erlext-term-to-binary control))
 385          (msg (if skip-message "" (erlext-term-to-binary message)))
 386          (len (+ 1 (length ctl) (length msg))))
 387     (fsm-send-string
 388      (fsm-build-message
 389        (fsm-encode4 len)
 390        (fsm-encode1 121) ; type = pass-through (whatever that means..)
 391        (fsm-insert ctl)
 392        (fsm-insert msg)))))
 393
 394 ;; Tracing
 395
 396 (defface derl-trace-output-face
 397   '((t (:inherit font-lock-string-face)))
 398   "Face for outgoing messages in the distributed erlang trace
 399 buffer.")
 400
 401 (defface derl-trace-input-face
 402   '((t (:inherit font-lock-comment-face)))
 403   "Face for incoming messages in the distributed erlang trace
 404 buffer.")
 405
 406 (defun derl-trace-output (fmt &rest args)
 407   (let ((msg (format ">> %s" (apply #'format (cons fmt args)))))
 408     (put-text-property 0 (length msg) 'face 'derl-trace-output-face msg)
 409     (derl-trace msg)))
 410
 411 (defun derl-trace-input (fmt &rest args)
 412   (let ((msg (format "<< %s" (apply #'format (cons fmt args)))))
 413     (put-text-property 0 (length msg) 'face 'derl-trace-input-face msg)
 414     (derl-trace msg)))
 415
 416 (defun derl-trace (string)
 417   (if derl-use-trace-buffer
 418       (with-current-buffer (get-buffer-create
 419                             (format "*trace %S*" derl-connection-node))
 420         (goto-char (point-max))
 421         (insert string)
 422         (insert "\n"))))
 423
 424 ;; ------------------------------------------------------------
 425 ;; Utility
 426 ;; ------------------------------------------------------------
 427
 428 (defun derl-nodedown (node)
 429   (setq derl-shutting-down t)
 430   (dolist (link derl-remote-links)
 431     (let ((local  (car link))
 432           (remote (cdr link)))
 433       (message "LOCAL: %S REMOTE %S" local remote)
 434       (erl-send-exit remote local 'noconnection)))
 435   (run-hook-with-args 'erl-nodedown-hook node))
 436
 437 (defun derl-nodeup (node)
 438   ;; NB: only callable from the state machine
 439   (run-hook-with-args 'erl-nodeup-hook node fsm-process))
 440
 441 (eval-and-compile
 442   (defun derl-int32-to-decimal (s)
 443     "Converts a 32-bit number (represented as a 4-byte string) into its
 444 decimal printed representation."
 445     (format "%.0f" (+ (+ (aref s 3) (* 256 (aref s 2)))
 446                       (* (+ 0.0 (aref s 1) (* 256 (aref s 0)))
 447                          65536)))))
 448
 449 ;; Try to establish whether we have enough precision in floating-point
 450 ;; The test is pretty lame, even if it succeeds we cannot be sure
 451 ;; it'll work for all int32's
 452 ;; alas, i'm too ignorant to write a good test
 453 ;; the previous version of the test was nicer, but FSFmacs-specific :<
 454
 455 (unless (string= "1819634533" (derl-int32-to-decimal "luke"))
 456   (error "Can't use Emacs's floating-point for `derl-int32-to-decimal'."))
 457
 458 (defun derl-hexstring-to-binstring (s)
 459   "Convert the hexidecimal string S into a binary number represented
 460 as a string of octets."
 461   (let ((halves (mapcar #'derl-hexchar-to-int (string-to-list s))))
 462     (derl-merge-halves halves)))
 463
 464 (defun derl-merge-halves (halves &optional acc)
 465   (if (null halves)
 466       (apply #'string (reverse acc))
 467     (derl-merge-halves (cddr halves)
 468                        (cons (+ (ash (car halves) 4)
 469                                 (cadr halves))
 470                              acc))))
 471
 472 (defun derl-hexchar-to-int (c)
 473   (cond ((and (<= ?0 c) (<= c ?9))
 474          (- c ?0))
 475         ((and (<= ?a c) (<= c ?f))
 476          (+ 10 (- c ?a)))
 477         (t
 478          (error "Not hexchar" c))))
 479
 480 (defun derl-node-p (node)
 481   "Check if `node' is a node name, e.g. \"foo@bar\". The @ character
 482 is not allowed in the node or host name."
 483   (and (symbolp node)
 484        (string-match "^[^@]+@[^@]+$" (symbol-name node))))
 485
 486 (defun derl-node-name (node)
 487   "Take the atom node part of a node name, e.g.
 488   (derl-node-name \"foo@bar\") => \"foo\""
 489   (assert (derl-node-p node))
 490   (let ((string (symbol-name node)))
 491     (string-match "^[^@]+" string)
 492     (match-string 0 string)))
 493
 494 (defun derl-node-host (node)
 495   "Take the host part of a node name, e.g.
 496   (derl-node-host \"foo@bar\") => \"bar\""
 497   (assert (derl-node-p node))
 498   (let ((string (symbol-name node)))
 499     (string-match "[^@]+$" string)
 500     (match-string 0 string)))
 501
 502 (defun derl-buffer-name (node)
 503   (format "*derl %s*" node))
 504
 505 ;; ------------------------------------------------------------
 506 ;; Testing and playing around
 507 ;; ------------------------------------------------------------
 508
 509 (defun derl-go (port)
 510   (fsm-connect "localhost" port #'derl-state0
 511                nil
 512                (lambda (result)
 513                  (message "RESULT: %S" result))
 514                (lambda ()
 515                  (message "FAIL"))))
 516
 517 (provide 'derl)
 518