;;; Mudsync --- Live hackable MUD
-;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
+;;; Copyright © 2016-2017 Christopher Allan Webber <cwebber@dustycloud.org>
;;;
;;; This file is part of Mudsync.
;;;
(define-module (mudsync networking)
#:use-module (8sync actors)
#:use-module (8sync agenda)
+ #:use-module (8sync systems websocket server)
#:use-module (ice-9 format)
#:use-module (ice-9 match)
#:use-module (ice-9 rdelim)
+ #:use-module (ice-9 receive)
#:use-module (oop goops)
+ ;; used by web server only
+ #:use-module (sxml simple)
+ #:use-module (web request)
+ #:use-module (web response)
+ #:use-module (web uri)
+ #:use-module (mudsync package-config)
+ #:use-module (mudsync contrib mime-types)
+ #:use-module (rnrs io ports)
+
#:export (;; Should we be exporting these?
%default-server
%default-port
(define %default-server #f)
(define %default-port 8889)
+(define %default-web-server-port 8888)
+
+(define-actor <network-manager> (<actor>)
+ ((start-listening
+ (lambda* (actor message
+ #:key (server %default-server)
+ (port %default-port)
+ (web-server-port %default-web-server-port))
+ (if web-server-port
+ (nm-install-web-server actor server web-server-port))
+ (nm-install-socket actor server port)))
+ (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)
-(define-class <network-manager> (<actor>)
(server-socket #:getter nm-server-socket)
;; mapping of client -> client-id
(clients #:getter nm-clients
#:init-thunk make-hash-table)
;; send input to this actor
(send-input-to #:getter nm-send-input-to
- #:init-keyword #:send-input-to)
-
- (actions
- #:allocation #:each-subclass
- #:init-value
- (build-actions
- (start-listening
- (lambda* (actor message
- #:key (server %default-server)
- (port %default-port))
- (nm-install-socket actor server port)))
- (send-to-client
- (lambda* (actor message #:key client data)
- (nm-send-to-client-id actor client data))))))
+ #:init-keyword #:send-input-to))
;;; TODO: We should provide something like this, but this isn't used currently,
;;; and uses old deprecated code (the 8sync-port-remove stuff).
(let loop ()
;; (yield) ;; @@: Do we need this?
(define client-connection (accept s))
- (8sync (nm-new-client nm s client-connection))
+ (<- (actor-id nm) 'new-socket-client
+ s client-connection)
(loop)))
-(define (nm-new-client nm 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)
- (<-* `(#:actor ,nm) (nm-send-input-to nm) 'new-client #:client client-id)
- (nm-client-receive-loop nm client client-id))
+ (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-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)
+ (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
+ '(div (@ (class "stream-entry"))
+ (p (b "<foo>") " Wow, it's so shiny!")))
+
+ (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!"))
+ ))
+ (div (@ (id "input-metabox"))
+ (input (@ (id "main-input"))))))
+
+ (define (main-tmpl)
+ `(html (@ (xmlns "http://www.w3.org/1999/xhtml"))
+ (head (title "Mudsync!")
+ (meta (@ (charset "UTF-8")))
+ (link (@ (rel "stylesheet")
+ (href "/static/css/main.css")))
+ (script (@ (type "text/javascript")
+ (src "/static/js/mudsync.js"))))
+ (body ,@body-tmpl)))
+ (define (write-template-to-string)
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (call-with-output-string
+ (lambda (p)
+ (sxml->xml (main-tmpl) p)))))
+ (values (build-response #:code 200
+ #:headers '((content-type . (application/xhtml+xml))))
+ (write-template-to-string)))
+
+(define (view:render-static request body static-path)
+ (values (build-response #:code 200
+ #:headers `((content-type . (,(mime-type static-path)))))
+ (call-with-input-file (web-static-filepath static-path) get-bytevector-all)))
+
+(define (view:standard-four-oh-four . args)
+ (values (build-response #:code 404
+ #:headers '((content-type . (text/plain))))
+ "Four-oh-four! Not found."))
+
+(define (route request)
+ (match (split-and-decode-uri-path (uri-path (request-uri request)))
+ (() (values view:main-display '()))
+
+ (("static" static-path ...)
+ ;; TODO: make this toggle'able
+ (values view:render-static
+ (list (string-append "/" (string-join
+ static-path "/")))))
+
+ ;; Not found!
+ (_ (values view:standard-four-oh-four '()))))
+
+(define (http-handler request body)
+ (receive (view args)
+ (route request)
+ (apply view request body args)))
+
+;; Respond to text messages by reversing the message. Respond to
+;; binary messages with "hello".
+(define (websocket-new-message websocket-server client-id data)
+ (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