;;; Mudsync --- Live hackable MUD ;;; Copyright © 2016-2017 Christopher Allan Webber ;;; ;;; This file is part of Mudsync. ;;; ;;; Mudsync is free software; you can redistribute it and/or modify it ;;; under the terms of the GNU General Public License as published by ;;; the Free Software Foundation; either version 3 of the License, or ;;; (at your option) any later version. ;;; ;;; Mudsync is distributed in the hope that it will be useful, but ;;; WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; General Public License for more details. ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with Mudsync. If not, see . (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) ;; Formatting #:use-module (mudsync scrubl) ;; 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 nm-close-everything)) ;;; Networking ;;; ========== (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 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) (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)) ;;; 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, ; says the intarwebs (define (nm-install-socket nm server port) "Install socket on SERVER with PORT" (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-socket-client s client-connection) (loop))) (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-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-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) (<-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-socket)) (if (eof-object? line) (<- (actor-id nm) 'client-disconnected client-id) (begin (nm-handle-line nm client-id (string-trim-right line #\return)) (when (actor-alive? nm) (loop))))) (loop)) (define (nm-client-disconnected nm message client-id) "Handle a closed port" (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 (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* (nm-send-to-client-id nm message #:key client data) "Send DATA to TO-CLIENT id" (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)) ;;; Web server interface (define-class () (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 #: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 "") " 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 "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))