X-Git-Url: https://jxself.org/git/?p=mudsync.git;a=blobdiff_plain;f=mudsync%2Fnetworking.scm;h=4417cfd27e898f4061992aad69bc65f820c58216;hp=f12a7e0c86578927bcfa53d18eef1afb6a532ffb;hb=0ea9e56921f887613da5472f12c1e2ae229cb829;hpb=d23f2cefbde148dedc61da5cf35391a12c6734bb diff --git a/mudsync/networking.scm b/mudsync/networking.scm index f12a7e0..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. ;;; @@ -19,11 +19,22 @@ (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 @@ -36,28 +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) - - (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). @@ -121,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)) @@ -135,7 +150,7 @@ (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) @@ -147,7 +162,7 @@ (begin (nm-handle-line nm client client-id (string-trim-right line #\return)) - (when (actor-am-i-alive? nm) + (when (actor-alive? nm) (loop))))) (loop)) @@ -155,18 +170,19 @@ "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)) @@ -179,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")))