;;; along with Mudsync. If not, see <http://www.gnu.org/licenses/>.
*/
-function displayMessage(data) {
+function displayMessage(data, self_sent) {
var new_entry = document.createElement("div");
var new_text = document.createTextNode(data);
var stream_metabox = document.getElementById("stream-metabox");
should_scroll = true;
}
document.getElementById("main-input").value = "";
- new_entry.setAttribute("class", "stream-entry");
+ if (self_sent) {
+ new_entry.setAttribute("class", "stream-entry self-sent");
+ } else {
+ new_entry.setAttribute("class", "stream-entry");
+ }
new_entry.appendChild(new_text);
document.getElementById("stream").appendChild(new_entry);
if (should_scroll) {
// TODO: Don't hardcode the websocket path; pull it from the DOM
var ws = new WebSocket("ws://127.0.0.1:8888");
ws.onmessage = function(evt) {
- displayMessage(evt.data);
+ displayMessage(evt.data, false);
};
ws.onopen = function() {
console.log("connected");
- ws.send("Hello, there!");
};
ws.onclose = function () {
console.log("closed websocket");
if (!e) e = window.event;
var keyCode = e.keyCode || e.which;
if (keyCode == '13') {
- sendMessageToServer(ws, input.value);
+ var input_val = input.value;
+ displayMessage("> ".concat(input_val), true);
+ sendMessageToServer(ws, input_val);
}
}
}
(if web-server-port
(nm-install-web-server actor server web-server-port))
(nm-install-socket actor server port)))
- (send-to-client
- (lambda* (actor message #:key client data)
- (nm-send-to-client-id actor client data)))
- (new-client nm-new-client))
+ (send-to-client nm-send-to-client-id)
+ (new-socket-client nm-new-socket-client)
+ (new-web-client nm-new-web-client)
+ (client-disconnected nm-client-disconnected)
+ (incoming-line nm-incoming-line-action))
(web-server #:accessor .web-server)
(let loop ()
;; (yield) ;; @@: Do we need this?
(define client-connection (accept s))
- (<- (actor-id nm) 'new-client
+ (<- (actor-id nm) 'new-socket-client
s client-connection)
(loop)))
-(define (nm-new-client nm message s client-connection)
+(define (nm-new-socket-client nm message s client-connection)
"Handle new client coming in to socket S"
(define client-details (cdr client-connection))
- (define client (car client-connection))
+ (define client-socket (car client-connection))
(define client-id (big-random-number))
(format #t "New client: ~s\n" client-details)
(format #t "Client address: ~s\n"
(gethostbyaddr
(sockaddr:addr client-details)))
- (fcntl client F_SETFL (logior O_NONBLOCK (fcntl client F_GETFL)))
- (hash-set! (nm-clients nm) client-id client)
+ (fcntl client-socket F_SETFL (logior O_NONBLOCK (fcntl client-socket F_GETFL)))
+ (hash-set! (nm-clients nm) client-id
+ (cons 'socket client-socket))
(<- (nm-send-input-to nm) 'new-client #:client client-id)
- (nm-client-receive-loop nm client client-id))
+ (nm-client-receive-loop nm client-socket client-id))
-(define (nm-client-receive-loop nm client client-id)
+(define (nm-new-web-client nm message ws-client-id)
+ ;; nm client id, as opposed to the websocket one
+ (define client-id (big-random-number))
+ (hash-set! (nm-clients nm) client-id
+ (cons 'websocket ws-client-id))
+ (<- (nm-send-input-to nm) 'new-client #:client client-id)
+ (<-reply message client-id))
+
+(define (nm-client-receive-loop nm client-socket client-id)
"Make a method to receive client data"
(define (loop)
- (define line (read-line client))
+ (define line (read-line client-socket))
(if (eof-object? line)
- (nm-handle-port-eof nm client client-id)
+ (<- (actor-id nm) 'client-disconnected client-id)
(begin
- (nm-handle-line nm client client-id
+ (nm-handle-line nm client-id
(string-trim-right line #\return))
(when (actor-alive? nm)
(loop)))))
(loop))
-(define (nm-handle-port-closed nm client client-id)
+(define (nm-client-disconnected nm message client-id)
"Handle a closed port"
- (format #t "DEBUG: handled closed port ~x\n" client-id)
+ (format #t "DEBUG: handled closed port ~a\n" client-id)
(hash-remove! (nm-clients nm) client-id)
(<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed #:client client-id))
-(define-method (nm-handle-port-eof nm client client-id)
- "Handle seeing an EOF on port"
- (format #t "DEBUG: handled eof-object on port ~x\n" client-id)
- (close client)
- (hash-remove! (nm-clients nm) client-id)
- (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed
- #:client client-id))
-
-(define-method (nm-handle-line nm client client-id line)
+(define (nm-handle-line nm client-id line)
"Handle an incoming line of input from a client"
(<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-input
#:data line
#:client client-id))
-(define-method (nm-send-to-client-id nm client-id data)
+(define* (nm-send-to-client-id nm message #:key client data)
"Send DATA to TO-CLIENT id"
- (define client-obj (hash-ref (nm-clients nm) client-id))
- (if (not client-obj)
- (throw 'no-such-client
- "Asked to send data to client but that client doesn't exist"
- #:client-id client-id
- #:data data))
- (display data client-obj))
+ (define client-obj (hash-ref (nm-clients nm) client))
+ (match client-obj
+ (#f (throw 'no-such-client
+ "Asked to send data to client but that client doesn't exist"
+ #:client-id client
+ #:data data))
+ (('socket . client-socket)
+ (display data client-socket))
+ (('websocket . ws-client-id)
+ (<- (.web-server nm) 'ws-send ws-client-id data))))
+
+(define (nm-incoming-line-action nm message client-id line)
+ "Handle LINE coming in, probably from an external message handler,
+like the web one"
+ (nm-handle-line nm client-id line))
\f
;;; Web server interface
+(define-class <mudsync-ws-server> (<websocket-server>)
+ (network-manager #:init-keyword #:network-manager
+ #:accessor .network-manager)
+ ;; This is a kludge... we really shouldn't have to double
+ ;; record these, should we?
+ (nm-client-ids #:init-thunk make-hash-table
+ #:accessor .nm-client-ids))
+
(define (nm-install-web-server nm server web-server-port)
"This installs the web server, which we see in use below...."
(set! (.web-server nm)
- (pk 'web-server (create-actor nm <websocket-server>
- #:port web-server-port
- #:http-handler (wrap-apply http-handler)
- #:on-ws-message (wrap-apply websocket-new-message)))))
+ (create-actor nm <mudsync-ws-server>
+ #:network-manager (actor-id nm)
+ #:port web-server-port
+ #:http-handler (wrap-apply http-handler)
+ #:on-ws-message (wrap-apply websocket-new-message)
+ #:on-ws-client-connect
+ (wrap-apply websocket-client-connect)
+ #:on-ws-client-disconnect
+ (wrap-apply websocket-client-disconnect))))
(define (view:main-display request body)
(define one-entry
(define body-tmpl
`((div (@ (id "stream-metabox"))
(div (@ (id "stream"))
- ,@(map (const one-entry) (iota 25))
- (div (@ (class "stream-entry"))
- (p (b "<bar>") " Last one!"))))
+ ;; ,@(map (const one-entry) (iota 25))
+ ;; (div (@ (class "stream-entry"))
+ ;; (p (b "<bar>") " Last one!"))
+ ))
(div (@ (id "input-metabox"))
(input (@ (id "main-input"))))))
;; Respond to text messages by reversing the message. Respond to
;; binary messages with "hello".
(define (websocket-new-message websocket-server client-id data)
- (<- (actor-id websocket-server) 'ws-send
- client-id
- (if (string? data)
- (string-reverse data)
- "hello")))
+ (cond
+ ((string? data)
+ (<- (.network-manager websocket-server) 'incoming-line
+ (hash-ref (.nm-client-ids websocket-server)
+ client-id)
+ data))
+ ;; binary data is ignored
+ (else #f)))
+
+(define (websocket-client-connect websocket-server client-id)
+ (let ((nm-client-id
+ (mbody-val (<-wait (.network-manager websocket-server)
+ 'new-web-client client-id))))
+ (hash-set! (.nm-client-ids websocket-server)
+ client-id nm-client-id)))
+
+(define (websocket-client-disconnect websocket-server client-id)
+ (<- (.network-manager websocket-server) 'client-disconnected
+ (hash-ref (.nm-client-ids websocket-server) client-id))
+ (hash-remove! (.nm-client-ids websocket-server) client-id))
projects / mudsync.git / commitdiff