X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fnetworking.scm;h=4417cfd27e898f4061992aad69bc65f820c58216;hp=525997546ad024f05298bcacfc19e9b0af19fef0;hb=0ea9e56921f887613da5472f12c1e2ae229cb829;hpb=095dde9158621c8bb3d690feaa0d525a76342eb9 diff --git a/mudsync/networking.scm b/mudsync/networking.scm index 5259975..4417cfd 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,13 +17,24 @@ ;;; 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 (mudsync contrib mime-types) + #:use-module (rnrs io ports) + #:export (;; Should we be exporting these? %default-server %default-port @@ -36,23 +47,31 @@ (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))))) + #: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). @@ -116,10 +135,11 @@ (let loop () ;; (yield) ;; @@: Do we need this? (define client-connection (accept s)) - (8sync (nm-new-client nm s client-connection)) + (<- (actor-id nm) 'new-client + s client-connection) (loop))) -(define (nm-new-client nm s client-connection) +(define (nm-new-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)) @@ -130,42 +150,39 @@ (sockaddr:addr client-details))) (fcntl client F_SETFL (logior O_NONBLOCK (fcntl client F_GETFL))) (hash-set! (nm-clients nm) client-id client) - (<- nm (nm-send-input-to nm) 'new-client #:client client-id) + (<- (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" (define (loop) - (define line (string-trim-right (read-line client) #\return)) - (nm-handle-line nm client client-id line) - (cond - ;; The port's been closed for some reason, so stop looping - ((port-closed? client) - (nm-handle-port-closed nm client client-id)) - ;; We've reached the EOF object, which means we should close - ;; the port ourselves and stop looping - ((eof-object? (peek-char client)) - (nm-handle-port-eof nm client client-id)) - ;; Otherwise, let's read till the next line! - (else (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) (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) (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)) @@ -178,3 +195,84 @@ #: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) + #:on-ws-message (wrap-apply websocket-new-message))))) + +(define (view:main-display request body) + (define one-entry + '(div (@ (class "stream-entry")) + (p (b "") " 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 "") " Last one!")))) + (div (@ (id "input-metabox")) + (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"))) + (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) + (<- (actor-id websocket-server) 'ws-send + client-id + (if (string? data) + (string-reverse data) + "hello")))