X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fnetworking.scm;h=f69f47a92cc13dc3a3d305954e321c76793ad857;hp=9f98a9ad112680be65d5a936b5323b8f3b2c3337;hb=d97fa236de7c359ac318819062131137e3064082;hpb=f1a3d508745069bceecb02cb475c0104020dce16 diff --git a/mudsync/networking.scm b/mudsync/networking.scm index 9f98a9a..f69f47a 100644 --- a/mudsync/networking.scm +++ b/mudsync/networking.scm @@ -1,5 +1,5 @@ ;;; Mudsync --- Live hackable MUD -;;; Copyright © 2016 Christopher Allan Webber +;;; Copyright © 2016-2017 Christopher Allan Webber ;;; ;;; This file is part of Mudsync. ;;; @@ -17,12 +17,23 @@ ;;; along with Mudsync. If not, see . (define-module (mudsync networking) - #:use-module (8sync systems actors) + #: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 (rnrs io ports) + #:export (;; Should we be exporting these? %default-server %default-port @@ -35,39 +46,49 @@ (define %default-server #f) (define %default-port 8889) +(define %default-web-server-port 8888) + +(define-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 + (lambda* (actor message #:key client data) + (nm-send-to-client-id actor client data))) + (new-client nm-new-client)) + + (web-server #:accessor .web-server) -(define-class () (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) - (message-handler - #:init-value - (make-action-dispatch - ((start-listening actor message) - (nm-install-socket actor (message-ref message 'server %default-server) - (message-ref message 'port %default-port))) - ((send-to-client actor message client data) - (nm-send-to-client-id actor client data))))) - -(define-method (nm-close-everything (nm ) remove-from-agenda) - "Shut it down!" - ;; close all clients - (hash-for-each - (lambda (_ client) - (close client) - (if remove-from-agenda - (8sync-port-remove client))) - (nm-clients nm)) - ;; reset the clients list - (set! (nm-clients) (make-hash-table)) - ;; close the server - (close (nm-server-socket nm)) - (if remove-from-agenda - (8sync-port-remove (nm-server-socket nm)))) + #: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). +;; (define-method (nm-close-everything (nm ) remove-from-agenda) +;; "Shut it down!" +;; ;; close all clients +;; (hash-for-each +;; (lambda (_ client) +;; (close client) +;; (if remove-from-agenda +;; (8sync-port-remove client))) +;; (nm-clients nm)) +;; ;; reset the clients list +;; (set! (nm-clients) (make-hash-table)) +;; ;; close the server +;; (close (nm-server-socket nm)) +;; (if remove-from-agenda +;; (8sync-port-remove (nm-server-socket nm)))) ;; Maximum number of backlogged connections when we listen (define %maximum-backlog-conns 128) ; same as SOMAXCONN on Linux 2.X, @@ -75,108 +96,92 @@ (define (nm-install-socket nm server port) "Install socket on SERVER with PORT" - (let ((s (socket PF_INET ; ipv4 - SOCK_STREAM ; two-way connection-based byte stream - 0)) - (addr (if server - (inet-pton AF_INET server) - INADDR_LOOPBACK))) - ;; Totally mimed from the Guile manual. Not sure if we need this, but: - ;; http://www.unixguide.net/network/socketfaq/4.5.shtml - (setsockopt s SOL_SOCKET SO_REUSEADDR 1) ; reuse port even if port is busy - ;; Connecting to a non-specific address: - ;; (bind s AF_INET INADDR_ANY port) - ;; Should this be an option? Guess I don't know why we'd need it - ;; @@: If we wanted to support listening on a particular hostname, - ;; could see 8sync's irc.scm... - (bind s AF_INET addr port) - ;; Listen to connections - (listen s %maximum-backlog-conns) - - ;; Throw a system-error rather than block on an (accept) - ;; that has nothing to do - (fcntl s F_SETFL - (logior O_NONBLOCK - (fcntl s F_GETFL))) - - ;; @@: This is used in Guile's http server under the commit: - ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the - ;; server from dying in some circumstances. - ;; (sigaction SIGPIPE SIG_IGN) - ;; Will this break other things that use pipes for us though? - - (slot-set! nm 'server-socket s) - - (format #t "Listening for clients in pid: ~s\n" (getpid)) - (8sync-port s #:read (lambda (s) (nm-new-client nm s))) - ;; TODO: set up periodic close of idle connections? - )) - -(define (nm-new-client nm s) + (define s + (socket PF_INET ; ipv4 + SOCK_STREAM ; two-way connection-based byte stream + 0)) + (define addr + (if server + (inet-pton AF_INET server) + INADDR_LOOPBACK)) + + ;; Totally mimed from the Guile manual. Not sure if we need this, but: + ;; http://www.unixguide.net/network/socketfaq/4.5.shtml + (setsockopt s SOL_SOCKET SO_REUSEADDR 1) ; reuse port even if port is busy + ;; Connecting to a non-specific address: + ;; (bind s AF_INET INADDR_ANY port) + ;; Should this be an option? Guess I don't know why we'd need it + ;; @@: If we wanted to support listening on a particular hostname, + ;; could see 8sync's irc.scm... + (bind s AF_INET addr port) + ;; Listen to connections + (listen s %maximum-backlog-conns) + + ;; Make port non-blocking + (fcntl s F_SETFL (logior O_NONBLOCK (fcntl s F_GETFL))) + + ;; @@: This is used in Guile's http server under the commit: + ;; * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the + ;; server from dying in some circumstances. + ;; (sigaction SIGPIPE SIG_IGN) + ;; Will this break other things that use pipes for us though? + + (slot-set! nm 'server-socket s) + + (format #t "Listening for clients in pid: ~s\n" (getpid)) + + ;; TODO: set up periodic close of idle connections? + (let loop () + ;; (yield) ;; @@: Do we need this? + (define client-connection (accept s)) + (<- (actor-id nm) 'new-client + s client-connection) + (loop))) + +(define (nm-new-client nm message s client-connection) "Handle new client coming in to socket S" - (let* ((client-connection (accept s)) - (client-details (cdr client-connection)) - (client (car client-connection))) - (format #t "New client: ~s\n" client-details) - (format #t "Client address: ~s\n" - (gethostbyaddr - (sockaddr:addr client-details))) - - (let ((client-id (big-random-number))) - (hash-set! (nm-clients nm) client-id client) - ;; @@: Do we need an 8sync-port-wait here? - ;; Is such a thing even possible? :\ - (8sync-port client #:read (nm-make-client-receive nm client-id)) - (<- nm (nm-send-input-to nm) 'new-client #:client client-id)))) - -(define (nm-make-client-receive nm client-id) + (define client-details (cdr client-connection)) + (define client (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) + (<- (nm-send-input-to nm) 'new-client #:client client-id) + (nm-client-receive-loop nm client client-id)) + +(define (nm-client-receive-loop nm client client-id) "Make a method to receive client data" - (let ((buffer '())) - (define (reset-buffer) - (set! buffer '())) - (define (should-read-char client) - (and (not (port-closed? client)) - (char-ready? client) - (not (eof-object? (peek-char client))))) - (define (receive-handler client) - (while (should-read-char client) - (set! buffer (cons (read-char client) buffer)) - (match buffer - (;; @@: Do we need the "char?" - (#\newline #\return (? char? line-chars) ...) - (let ((ready-line (list->string (reverse line-chars)))) - ;; reset buffer - (set! buffer '()) - ;; run it - (nm-handle-line nm client client-id ready-line))) - (_ #f))) - ;; Shut things down on closed port or EOF object - (cond - ((port-closed? client) - (nm-handle-port-closed nm client client-id)) - ((and (char-ready? client) - (eof-object? (peek-char client))) - (nm-handle-port-eof nm client client-id)))) - receive-handler)) + (define (loop) + (define line (read-line client)) + (if (eof-object? line) + (nm-handle-port-eof nm client client-id) + (begin + (nm-handle-line nm client client-id + (string-trim-right line #\return)) + (when (actor-alive? nm) + (loop))))) + (loop)) (define (nm-handle-port-closed nm client client-id) "Handle a closed port" (format #t "DEBUG: handled closed port ~x\n" client-id) - (8sync-port-remove client) (hash-remove! (nm-clients nm) client-id) - (<- nm (nm-send-input-to nm) 'client-closed #:client 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) - (8sync-port-remove client) + (close client) (hash-remove! (nm-clients nm) client-id) - (<- nm (nm-send-input-to nm) 'client-closed #:client client-id)) + (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-closed + #:client client-id)) (define-method (nm-handle-line nm client client-id line) "Handle an incoming line of input from a client" - (<- nm (nm-send-input-to nm) 'client-input + (<-* `(#:actor ,nm) (nm-send-input-to nm) 'client-input #:data line #:client client-id)) @@ -189,3 +194,75 @@ #:client-id client-id #:data data)) (display data client-obj)) + + + +;;; Web server interface + +(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 + #:port web-server-port + #:http-handler (wrap-apply http-handler) + #:websocket-handler (wrap-apply websocket-handler))))) + +(define (view:main-display request body) + (define body-tmpl + '((div (@ (id "stream-output")) + (p "nope")) + (div (@ (id "input-box")) + (p "test test") + (input (@ (id "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")))) + (body ,@body-tmpl))) + (define (write-template-to-string) + (with-fluids ((%default-port-encoding "UTF-8")) + (with-output-to-string + (lambda () + (sxml->xml (main-tmpl)))))) + (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 + ;; #: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-handler data) + (if (string? data) + (string-reverse data) + "hello"))