← Back to branch summary

~dustin-spy/twisted/dustin

« back to all changes in this revision

Viewing changes to emacs/pb.el

  • Committer: jml
  • Date: 2006-04-10 12:52:37 UTC
  • Revision ID: vcs-imports@canonical.com-20060410125237-d7c0c08e21af5433
Add TwistedEmacs to Twisted (with improved docs)

Author: jml
Reviewer: radix
Fixes #1628

Show diffs side-by-side

added added

removed removed

Lines of Context:
emacs/pb.el
 
1
;;;; pb.el - a perspective broker implementation for emacs
 
2
;;;; by Allen Short <washort@twistedmatrix.com>
 
3
;;;; this file is in the public domain.
 
4
 
 
5
"'We will never run out of things to program as long as there is a
 
6
  single program around.' -- Alan Perlis, Programming Epigram #100"
 
7
 
 
8
(require 'banana)
 
9
(require 'jelly)
 
10
(provide 'pb)
 
11
 
 
12
(defconst pb-version 6)
 
13
(defconst pb-port 8787)
 
14
(defstruct pb-broker
 
15
  (perspectives ())
 
16
  socket
 
17
  (waiting-for-answers (make-hash-table))
 
18
  (request-id 0)
 
19
  (disconnected nil)
 
20
  requested-identity
 
21
  (local-objects (make-hash-table)))
 
22
 
 
23
(defsubst hexchar-to-int (hex)
 
24
  (cond
 
25
   ((and (<= ?0 hex) (<= hex ?9)) (- hex ?0))
 
26
   ((and (<= ?A hex) (<= hex ?F)) (+ (- hex ?A) 10))
 
27
   ((and (<= ?a hex) (<= hex ?f)) (+ (- hex ?a) 10))))
 
28
 
 
29
(defun md5-raw (str)
 
30
  (let* ((md5str (md5 str))
 
31
         (len (length md5str))
 
32
         (md5raw (make-string (/ len 2) 0))
 
33
         (i 0) (j 0))
 
34
    (while (< i len)
 
35
      (aset md5raw j (+ (* (hexchar-to-int (aref md5str i)) 16)
 
36
                        (hexchar-to-int (aref md5str (1+ i)))))
 
37
      (setq i (+ i 2))
 
38
      (setq j (1+ j)))
 
39
    md5raw))
 
40
 
 
41
(defun pb-passport-respond (challenge password)
 
42
  (md5-raw (concat (md5-raw password) challenge)))
 
43
 
 
44
(defun netjelly-unserialize (broker jelly)
 
45
  (let ((refs (make-hash-table)))
 
46
    (jelly-fixup-refs (netjelly-unserialize-internal broker jelly))))
 
47
 
 
48
 
 
49
 
 
50
(defun netjelly-unserialize-internal (broker jelly)
 
51
  ;; some days i think glyph does these things on purpose, to annoy me
 
52
  (if (or (integerp jelly) (stringp jelly) (floatp jelly) (null jelly))
 
53
      jelly
 
54
    (ecase (intern (car jelly))
 
55
      ((list tuple)
 
56
       (mapcar (lambda (i) (netjelly-unserialize-internal broker i)) (cdr jelly)))
 
57
      (dictionary
 
58
       (let ((ht (make-hash-table)))
 
59
         (mapc
 
60
          (lambda (pair)
 
61
            (let ((k (car pair)) (v (second pair)))
 
62
              (setf (gethash k ht) (netjelly-unserialize-internal broker v))))
 
63
          (cdr jelly))
 
64
         ht))
 
65
      ((integer string float)
 
66
       (lambda () (cdr jelly)))
 
67
      (reference
 
68
       (let ((val  (netjelly-unserialize-internal broker (third jelly))))
 
69
         (setf (gethash (second jelly) refs) val)
 
70
         val))
 
71
      (dereference
 
72
       (lexical-let ((-ref-num- (cadr jelly)))
 
73
         (lambda () (gethash -ref-num- refs))))
 
74
      (remote
 
75
       (make-remote-reference nil broker (cadr jelly)))
 
76
      (local
 
77
       (gethash (cadr jelly) (pb-broker-local-objects broker))))))
 
78
 
 
79
 
 
80
 
 
81
(defun make-remote-reference (perspective broker luid)
 
82
  (lexical-let ((-perspective- perspective) (-broker- broker) (-luid- luid))
 
83
    (lambda (message args kwargs &optional callback errback)
 
84
      ;; remote-serialize(broker val)
 
85
      (if (equal message 'remote-serialize)
 
86
          (progn
 
87
            (unless (eq -broker- (car args))
 
88
              (error "Can't send references to brokers other than their own."))
 
89
            (list 'local -luid-))
 
90
        (pb-send-message -broker- -perspective- -luid- message args kwargs callback errback)))))
 
91
 
 
92
(defun pb-traceback (tb)
 
93
  (let ((b (get-buffer-create "*PB Traceback*")))
 
94
    (pop-to-buffer b)
 
95
    (print tb b)))
 
96
 
 
97
 
 
98
(defsubst pb-send-call (broker &rest args)
 
99
  (banana-send-encoded (pb-broker-socket broker) args))
 
100
 
 
101
(defun pb-send-message (broker perspective obj-id message args kwargs callback errback)
 
102
  (if (pb-broker-disconnected broker) (error "calling stale broker"))
 
103
  (let ((net-args (jelly-serialize args (make-jelly)))
 
104
        (net-kw (jelly-serialize-alist kwargs (make-jelly)))
 
105
        (request-id (incf (pb-broker-request-id broker)))
 
106
        (answer-required (if (or callback errback) 1 0)))
 
107
    (puthash request-id (cons callback errback) (pb-broker-waiting-for-answers broker))
 
108
    (pb-send-call broker "message" request-id obj-id message answer-required net-args net-kw)))
 
109
 
 
110
(defun pb-connect-internal (host port callback)
 
111
  (let ((broker (make-pb-broker))
 
112
        (sock (open-network-stream "pb" nil host (or port pb-port))))
 
113
    (setf (pb-broker-socket broker) sock)
 
114
    (set-process-filter
 
115
     sock
 
116
     (lexical-let ((-broker- broker)
 
117
                   (-callback- callback))
 
118
       (make-banana-decoder
 
119
        (lambda (expr) (pb-socket-filter -broker- expr))
 
120
        (lambda () (funcall -callback- -broker-)))))
 
121
    broker))
 
122
 
 
123
(defun pb-get-object-at (host port callback  &optional errback timeout)
 
124
;;   (let ((b (pb-connect-internal host port)))
 
125
;;     (funcall callback (make-remote-reference nil b "root")))
 
126
  (lexical-let ((-callback- callback))
 
127
    (pb-connect-internal
 
128
     host port 
 
129
     (lambda (b) (funcall -callback- (make-remote-reference nil b "root"))))))
 
130
 
 
131
(defun pb-connect (callback errback host port username password service &optional perspective client timeout)
 
132
  ;; the proper indentation of this code is left as an exercise for the reader
 
133
  (lexical-let ((-callback- callback)
 
134
                (-errback- errback)
 
135
                (-username- username)
 
136
                (-password- password)
 
137
                (-service- service)
 
138
                (-perspective- perspective)
 
139
                (-client- client))
 
140
    (pb-get-object-at
 
141
     host port
 
142
     (lambda (authserv)
 
143
       (funcall authserv "username"
 
144
                (list -username-) nil
 
145
                (lambda (chal)
 
146
                  (funcall (second chal) "respond"
 
147
                           (list (pb-passport-respond (first chal) -password-)) nil
 
148
                           (lambda (identity)
 
149
                             (if identity
 
150
                                 (funcall identity "attach"
 
151
                                          (list -service- (or -perspective- -username-) -client-) nil
 
152
                                          -callback-
 
153
                                          -errback-)
 
154
                               (funcall -errback- "invalid username or password")))
 
155
                           -errback-))
 
156
                -errback-))
 
157
     (lambda (error) (funcall -errback- error))
 
158
     timeout)))
 
159
 
 
160
(defun pb-socket-filter (broker sexp)
 
161
  (if (listp (car sexp))
 
162
      (mapcar (lambda (s) (pb-dispatch broker s)) sexp)
 
163
    (pb-dispatch broker sexp)))
 
164
 
 
165
(defun pb-dispatch (broker expr)
 
166
  (let ((fun (symbol-function 
 
167
              (intern (concat "pb-proto-" (car expr))))))
 
168
  (apply fun (cons broker (cdr expr)))))
 
169
 
 
170
(defun pb-proto-version (broker vnum)
 
171
  (unless (eq vnum pb-version) (error "Incompatible protocol versions")))
 
172
 
 
173
(defun pb-proto-answer (broker request-id net-result)
 
174
  (let ((funs (gethash request-id (pb-broker-waiting-for-answers broker))))
 
175
    (remhash request-id (pb-broker-waiting-for-answers broker))
 
176
    (funcall (car funs) (netjelly-unserialize broker net-result))))
 
177
 
 
178
(defun pb-shutdown (broker)
 
179
  (let ((h (pb-broker-waiting-for-answers broker)))
 
180
    (maphash (lambda (k v)
 
181
               (remhash k h)
 
182
               (funcall (cdr v) "Connection lost"))
 
183
             h))
 
184
  ;;(mapcar #'funcall (pb-broker-disconnects broker))
 
185
  (delete-process (pb-broker-socket broker))
 
186
  (setf (pb-broker-disconnected broker) t))