mudsync.scm

   1 ;;; Mudsync --- Live hackable MUD
   2 ;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org>
   3 ;;;
   4 ;;; This file is part of Mudsync.
   5 ;;;
   6 ;;; Mudsync is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or
   9 ;;; (at your option) any later version.
  10 ;;;
  11 ;;; Mudsync is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;;; General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with Mudsync.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (use-modules (8sync systems actors)
  20              (8sync systems actors debug)
  21              (8sync agenda)
  22              (ice-9 format)
  23              (ice-9 match)
  24              (oop goops))
  25
  26
  27 \f
  28 ;;; Networking
  29 ;;; ==========
  30
  31 (define %default-server #f)
  32 (define %default-port 8889)
  33
  34 (define-class <network-manager> (<actor>)
  35   (server-socket #:accessor nm-server-socket)
  36   ;; mapping of client -> client-id
  37   (clients #:accessor nm-clients
  38            #:init-thunk make-hash-table)
  39   ;; send input to this actor
  40   (send-input-to #:getter nm-send-input-to
  41                  #:init-keyword #:send-input-to)
  42   (message-handler
  43    #:init-value
  44    (make-action-dispatch
  45     ((start-listening actor message)
  46      (nm-install-socket actor (message-ref message 'server %default-server)
  47                         (message-ref message 'port %default-port)))
  48     ((send-to-client actor message client data)
  49      (nm-send-to-client-id actor client data)))))
  50
  51 (define-method (nm-close-everything (nm <network-manager>) remove-from-agenda)
  52   "Shut it down!"
  53   ;; close all clients
  54   (hash-for-each
  55    (lambda (_ client)
  56      (close client)
  57      (if remove-from-agenda
  58          (8sync-port-remove client)))
  59    (nm-clients nm))
  60   ;; reset the clients list
  61   (set! (nm-clients) (make-hash-table))
  62   ;; close the server
  63   (close (nm-server-socket nm))
  64   (if remove-from-agenda
  65       (8sync-port-remove (nm-server-socket nm))))
  66
  67 ;; Maximum number of backlogged connections when we listen
  68 (define %maximum-backlog-conns 128)     ; same as SOMAXCONN on Linux 2.X,
  69                                         ; says the intarwebs
  70
  71 (define (nm-install-socket nm server port)
  72   "Install socket on SERVER with PORT"
  73   (let ((s (socket PF_INET  ; ipv4
  74                    SOCK_STREAM  ; two-way connection-based byte stream
  75                    0))
  76         (addr (if server
  77                   (inet-pton AF_INET server)
  78                   INADDR_LOOPBACK)))
  79     ;; Totally mimed from the Guile manual.  Not sure if we need this, but:
  80     ;; http://www.unixguide.net/network/socketfaq/4.5.shtml
  81     (setsockopt s SOL_SOCKET SO_REUSEADDR 1) ; reuse port even if port is busy
  82     ;; Connecting to a non-specific address:
  83     ;;   (bind s AF_INET INADDR_ANY port)
  84     ;; Should this be an option?  Guess I don't know why we'd need it
  85     ;; @@: If we wanted to support listening on a particular hostname,
  86     ;;   could see 8sync's irc.scm...
  87     (bind s AF_INET addr port)
  88     ;; Listen to connections
  89     (listen s %maximum-backlog-conns)
  90
  91     ;; Throw a system-error rather than block on an (accept)
  92     ;; that has nothing to do
  93     (fcntl s F_SETFL
  94            (logior O_NONBLOCK
  95                    (fcntl s F_GETFL)))
  96
  97     ;; @@: This is used in Guile's http server under the commit:
  98     ;;       * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
  99     ;;         server from dying in some circumstances.
 100     ;;   (sigaction SIGPIPE SIG_IGN)
 101     ;; Will this break other things that use pipes for us though?
 102
 103     (set! (nm-server-socket nm) s)
 104
 105     (format #t "Listening for clients in pid: ~s\n" (getpid))
 106     (8sync-port s #:read (lambda (s) (nm-new-client nm s)))
 107     ;; TODO: set up periodic close of idle connections?
 108     ))
 109
 110 (define (nm-new-client nm s)
 111   "Handle new client coming in to socket S"
 112   (let* ((client-connection (accept s))
 113          (client-details (cdr client-connection))
 114          (client (car client-connection)))
 115     (format #t "New client: ~s\n" client-details)
 116     (format #t "Client address: ~s\n"
 117             (gethostbyaddr
 118              (sockaddr:addr client-details)))
 119
 120     (let ((client-id (big-random-number)))
 121       (hash-set! (nm-clients nm) client-id client)
 122       (8sync-port client #:read (nm-make-client-receive nm client-id)))))
 123
 124 (define (nm-make-client-receive nm client-id)
 125   "Make a method to receive client data"
 126   (let ((buffer '()))
 127     (define (reset-buffer)
 128       (set! buffer '()))
 129     (define (should-read-char client)
 130       (and (not (port-closed? client))
 131            (char-ready? client)
 132            (not (eof-object? (peek-char client)))))
 133     (define (receive-handler client)
 134       (while (should-read-char client)
 135         (set! buffer (cons (read-char client) buffer))
 136         (match buffer
 137           (;; @@: Do we need the "char?"
 138            (#\newline #\return (? char? line-chars) ...)
 139            (let ((ready-line (list->string (reverse line-chars))))
 140              ;; reset buffer
 141              (set! buffer '())
 142              ;; run it
 143              (nm-handle-line nm client client-id ready-line)))
 144           (_ #f)))
 145       ;; Shut things down on closed port or EOF object
 146       (cond
 147        ((port-closed? client)
 148         (nm-handle-port-closed nm client client-id))
 149        ((and (char-ready? client)
 150              (eof-object? (peek-char client)))
 151         (nm-handle-port-eof nm client client-id))))
 152     receive-handler))
 153
 154 (define (nm-handle-port-closed nm client client-id)
 155   "Handle a closed port"
 156   (format #t "DEBUG: handled closed port ~x\n" client-id)
 157   (8sync-port-remove client)
 158   (hash-remove! (nm-clients nm) client-id))
 159
 160 (define-method (nm-handle-port-eof nm client client-id)
 161   "Handle seeing an EOF on port"
 162   (format #t "DEBUG: handled eof-object on port ~x\n" client-id)
 163   (close client)
 164   (8sync-port-remove client)
 165   (hash-remove! (nm-clients nm) client-id))
 166
 167 (define-method (nm-handle-line nm client client-id line)
 168   "Handle an incoming line of input from a client"
 169   (<- nm (nm-send-input-to nm) 'client-input
 170       #:data line
 171       #:client client-id))
 172
 173 (define-method (nm-send-to-client-id nm client-id data)
 174   "Send DATA to TO-CLIENT id"
 175   (display data
 176            (hash-ref (nm-clients nm) client-id)))
 177
 178 ; (ez-run-hive hive (list (bootstrap-message hive (actor-id nm) 'start-listening)))
 179
 180
 181 ;; (define-method (nm-close-port (nm <network-manager>)))
 182
 183
 184 \f
 185 ;;; The game master!  Runs the world.
 186 ;;; =================================
 187
 188 ;; @@: We could call this a "world builder" instead...
 189 ;;   I kinda like calling it a GM though.
 190
 191 (define-class <game-master> (<actor>)
 192   ;; The directory is a "namespaced" directory of all "special" content
 193   ;; in the game, identifiable by some special key.
 194   ;; (The namespace is simply a cons of (namespace . special-symbol))
 195   (directory #:init-thunk make-hash-table)
 196   ;; A mapping of client ids to in-game actors
 197   (client-to-actor #:init-thunk make-hash-table)
 198   ;; Network manager
 199   (network-manager #:accessor gm-network-manager
 200                    #:init-val #f)
 201
 202   (message-handler
 203    #:init-value
 204    (make-action-dispatch
 205     (init-world (wrap-apply gm-init-world))
 206     (client-input (wrap-apply gm-handle-client-input)))))
 207
 208
 209 (define (gm-init-world gm message)
 210   ;; Load database
 211   ;;  TODO
 212
 213   ;; Init basic rooms / structure
 214   ;;  TODO
 215
 216   ;; Restore database-based actors
 217   ;;  TODO
 218
 219   ;; Set up the network
 220   (gm-setup-network gm))
 221
 222 (define (gm-setup-network gm)
 223   ;; Create a default network manager if none available
 224   (set! (gm-network-manager gm)
 225         (create-actor* gm <network-manager> "netman"
 226                        #:send-input-to (actor-id gm)))
 227
 228   ;; TODO: Add host and port options
 229   (<-wait gm (gm-network-manager gm) 'start-listening))
 230
 231 (define (gm-handle-client-input actor message)
 232   "Handle input from a client."
 233   (define client-id (message-ref message 'client))
 234   (define input (message-ref message 'data))
 235   (format #t "From ~s: ~s\n" client-id input)
 236   (<- actor (gm-network-manager actor) 'send-to-client
 237       #:client client-id
 238       #:data "Thanks, we got it!\n"))
 239
 240 (define-method (gm-setup-database (gm <game-master>))
 241   'TODO)
 242
 243 (define-method (gm-setup-rooms-etc (gm <game-master>))
 244   'TODO)
 245
 246
 247 ;; Debugging stuff
 248 (define %test-gm #f)
 249
 250 (define (run-demo . args)
 251   (define hive (make-hive))
 252   (define gm
 253     (hive-create-actor-gimmie* hive <game-master> "gm"))
 254   (set! %test-gm gm)
 255   ;; @@: Boy, wouldn't it be nice if the agenda could do things
 256   ;;   on interrupt :P
 257   (ez-run-hive hive
 258                (list (bootstrap-message hive (actor-id gm) 'init-world))))