#:use-module (ice-9 receive)
#:use-module (oop goops)
+ ;; Formatting
+ #:use-module (mudsync scrubl)
+
;; used by web server only
#:use-module (sxml simple)
#:use-module (web request)
(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-socket 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)
- (nm-client-receive-loop nm client client-id))
+ (<-reply message client-id))
-(define (nm-client-receive-loop nm client 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 formatted-data
+ (scrubl-write scrubl-sxml data))
+ (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 formatted-data))
+ (('socket . client-socket)
+ (display formatted-data client-socket))
+ (('websocket . ws-client-id)
+ (<- (.web-server nm) 'ws-send ws-client-id formatted-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 "input"))))))
+ (input (@ (id "main-input"))))))
(define (main-tmpl)
`(html (@ (xmlns "http://www.w3.org/1999/xhtml"))
;; 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 / blobdiff