-
Notifications
You must be signed in to change notification settings - Fork 6
/
websock.lisp
126 lines (95 loc) · 3.7 KB
/
websock.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
(defpackage #:websock
(:use #:cl #:ps)
(:export #:install-websock
#:start-websocket-server
#:in-ws-repl))
(in-package #:websock)
#+sbcl (load "id-map.lisp")
#+sbcl (use-package :id-map)
#+ccl (import '(ccl::make-id-map ccl::assign-id-map-id ccl::id-map-free-object))
(defvar *client* nil)
(defvar *id-map* nil)
(defclass message-box ()
((result :initform nil :accessor result)
(errorp :initform nil :accessor errorp)
(semaphore :initarg :semaphore :reader semaphore)))
(defclass repl-resource (ws:ws-resource)
())
(defmethod ws:resource-client-connected ((res repl-resource) client)
(unless *client*
(setf *client* client)
(format t "~&got connection on repl~%"))
t)
(defmethod ws:resource-client-disconnected ((res repl-resource) client)
(format t "~&disconnected resouce ~a~%" client)
(setf *client* nil))
(defmethod ws:resource-received-text ((res repl-resource) client message)
(declare (ignore client))
(multiple-value-bind (identifiersi offset)
(read-from-string message)
(destructuring-bind (id numberp errorp)
identifiersi
(let ((result (subseq message offset))
(object (id-map-free-object *id-map* id)))
(when numberp (setf result (parse-number:parse-number result)))
(setf (errorp object) errorp)
(setf (result object) result)
(bt-sem:signal-semaphore (semaphore object))))))
(defpsmacro install-websock (port)
`(progn
(defvar socket (new (-web-socket (lisp (format nil "ws://127.0.0.1:~a/repl" ,port)))))
(setf (chain socket onopen)
(lambda () (chain console (log "openning connect to websocket"))))
(setf (chain socket onmessage)
(lambda (msg)
(chain console (log "receive message"))
(let* ((json (eval (@ msg data)))
(id (@ json id))
(result nil)
(numberp nil)
(errorp "NIL"))
(try (progn (setf result (eval (@ json task))
numberp (if (string= (typeof result) "number") "T" "NIL")))
(:catch (error)
(setf result error
numberp "NIL"
errorp "T"))
(:finally (chain socket (send (+ "(" id " " numberp " " errorp ")" result))))))))))
(defun start-websocket-server (port)
(setf *id-map* (make-id-map))
(bt:make-thread (lambda () (ws:run-server port)) :name "websocket server")
(ws:register-global-resource "/repl"
(make-instance 'repl-resource)
(ws:origin-prefix "http://127.0.0.1" "http://localhost"))
(bt:make-thread
(lambda ()
(ws:run-resource-listener (ws:find-global-resource "/repl")))
:name "resource listener for /repl"))
(define-condition websocket-repl-error (error)
((error-report :initarg :error-report :reader error-report))
(:report (lambda (condition stream)
(format stream "~a" (error-report condition)))))
(defun call-in-ws-repl (thunk)
(declare (optimize (debug 3) (safety 3)))
(let* ((object (make-instance 'message-box :semaphore (bt-sem:make-semaphore)))
(id (assign-id-map-id *id-map* object)))
(ws:write-to-client-text
*client*
(ps (setf x
(create :id (lisp id) :task (lisp thunk)))))
(bt-sem:wait-on-semaphore (semaphore object))
(if (errorp object)
(error 'websocket-repl-error :error-report (result object))
(result object))))
(defmacro in-ws-repl (&body body)
`(call-in-ws-repl (ps ,@body)))
(defmacro in-ws-repl-orig (&body body)
`(let* ((object (make-instance 'message-box :semaphore (bt-sem:make-semaphore)))
(id (assign-id-map-id *id-map* object)))
(ws:write-to-client-text
*client*
(ps (setf x
(create :id (lisp id) :task (lisp (ps ,@body))))))
(bt-sem:wait-on-semaphore (semaphore object))
(if (errorp object) (error 'websocket-repl-error :error-report (result object))
(result object))))