mudsync/mudsync/networking.scm

;;; Mudsync --- Live hackable MUD
;;; Copyright © 2016-2017 Christine Lemmer-Webber <cwebber@dustycloud.org>
;;;
;;; 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 <http://www.gnu.org/licenses/>.

(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

            <network-manager>
            nm-close-everything))

;;; Networking
;;; ==========

(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)

  (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 <network-manager>) 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 <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")))
           " "
           (span (@ (id "connection-status")
                    (class "disconnected"))
                 "[disconnected]"))))

  (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))