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              (gdbm)
  25              (oop goops))
  26
  27
  28 \f
  29 ;;; Networking
  30 ;;; ==========
  31
  32 (define %default-server #f)
  33 (define %default-port 8889)
  34
  35 (define-class <network-manager> (<actor>)
  36   (server-socket #:accessor nm-server-socket)
  37   ;; mapping of client -> client-id
  38   (clients #:accessor nm-clients
  39            #:init-thunk make-hash-table)
  40   ;; send input to this actor
  41   (send-input-to #:getter nm-send-input-to
  42                  #:init-keyword #:send-input-to)
  43   (message-handler
  44    #:init-value
  45    (make-action-dispatch
  46     ((start-listening actor message)
  47      (nm-install-socket actor (message-ref message 'server %default-server)
  48                         (message-ref message 'port %default-port)))
  49     ((send-to-client actor message client data)
  50      (nm-send-to-client-id actor client data)))))
  51
  52 (define-method (nm-close-everything (nm <network-manager>) remove-from-agenda)
  53   "Shut it down!"
  54   ;; close all clients
  55   (hash-for-each
  56    (lambda (_ client)
  57      (close client)
  58      (if remove-from-agenda
  59          (8sync-port-remove client)))
  60    (nm-clients nm))
  61   ;; reset the clients list
  62   (set! (nm-clients) (make-hash-table))
  63   ;; close the server
  64   (close (nm-server-socket nm))
  65   (if remove-from-agenda
  66       (8sync-port-remove (nm-server-socket nm))))
  67
  68 ;; Maximum number of backlogged connections when we listen
  69 (define %maximum-backlog-conns 128)     ; same as SOMAXCONN on Linux 2.X,
  70                                         ; says the intarwebs
  71
  72 (define (nm-install-socket nm server port)
  73   "Install socket on SERVER with PORT"
  74   (let ((s (socket PF_INET  ; ipv4
  75                    SOCK_STREAM  ; two-way connection-based byte stream
  76                    0))
  77         (addr (if server
  78                   (inet-pton AF_INET server)
  79                   INADDR_LOOPBACK)))
  80     ;; Totally mimed from the Guile manual.  Not sure if we need this, but:
  81     ;; http://www.unixguide.net/network/socketfaq/4.5.shtml
  82     (setsockopt s SOL_SOCKET SO_REUSEADDR 1) ; reuse port even if port is busy
  83     ;; Connecting to a non-specific address:
  84     ;;   (bind s AF_INET INADDR_ANY port)
  85     ;; Should this be an option?  Guess I don't know why we'd need it
  86     ;; @@: If we wanted to support listening on a particular hostname,
  87     ;;   could see 8sync's irc.scm...
  88     (bind s AF_INET addr port)
  89     ;; Listen to connections
  90     (listen s %maximum-backlog-conns)
  91
  92     ;; Throw a system-error rather than block on an (accept)
  93     ;; that has nothing to do
  94     (fcntl s F_SETFL
  95            (logior O_NONBLOCK
  96                    (fcntl s F_GETFL)))
  97
  98     ;; @@: This is used in Guile's http server under the commit:
  99     ;;       * module/web/server/http.scm (http-open): Ignore SIGPIPE. Keeps the
 100     ;;         server from dying in some circumstances.
 101     ;;   (sigaction SIGPIPE SIG_IGN)
 102     ;; Will this break other things that use pipes for us though?
 103
 104     (set! (nm-server-socket nm) s)
 105
 106     (format #t "Listening for clients in pid: ~s\n" (getpid))
 107     (8sync-port s #:read (lambda (s) (nm-new-client nm s)))
 108     ;; TODO: set up periodic close of idle connections?
 109     ))
 110
 111 (define (nm-new-client nm s)
 112   "Handle new client coming in to socket S"
 113   (let* ((client-connection (accept s))
 114          (client-details (cdr client-connection))
 115          (client (car client-connection)))
 116     (format #t "New client: ~s\n" client-details)
 117     (format #t "Client address: ~s\n"
 118             (gethostbyaddr
 119              (sockaddr:addr client-details)))
 120
 121     (let ((client-id (big-random-number)))
 122       (hash-set! (nm-clients nm) client-id client)
 123       (8sync-port client #:read (nm-make-client-receive nm client-id)))))
 124
 125 (define (nm-make-client-receive nm client-id)
 126   "Make a method to receive client data"
 127   (let ((buffer '()))
 128     (define (reset-buffer)
 129       (set! buffer '()))
 130     (define (should-read-char client)
 131       (and (not (port-closed? client))
 132            (char-ready? client)
 133            (not (eof-object? (peek-char client)))))
 134     (define (receive-handler client)
 135       (while (should-read-char client)
 136         (set! buffer (cons (read-char client) buffer))
 137         (match buffer
 138           (;; @@: Do we need the "char?"
 139            (#\newline #\return (? char? line-chars) ...)
 140            (let ((ready-line (list->string (reverse line-chars))))
 141              ;; reset buffer
 142              (set! buffer '())
 143              ;; run it
 144              (nm-handle-line nm client client-id ready-line)))
 145           (_ #f)))
 146       ;; Shut things down on closed port or EOF object
 147       (cond
 148        ((port-closed? client)
 149         (nm-handle-port-closed nm client client-id))
 150        ((and (char-ready? client)
 151              (eof-object? (peek-char client)))
 152         (nm-handle-port-eof nm client client-id))))
 153     receive-handler))
 154
 155 (define (nm-handle-port-closed nm client client-id)
 156   "Handle a closed port"
 157   (format #t "DEBUG: handled closed port ~x\n" client-id)
 158   (8sync-port-remove client)
 159   (hash-remove! (nm-clients nm) client-id))
 160
 161 (define-method (nm-handle-port-eof nm client client-id)
 162   "Handle seeing an EOF on port"
 163   (format #t "DEBUG: handled eof-object on port ~x\n" client-id)
 164   (close client)
 165   (8sync-port-remove client)
 166   (hash-remove! (nm-clients nm) client-id))
 167
 168 (define-method (nm-handle-line nm client client-id line)
 169   "Handle an incoming line of input from a client"
 170   (<- nm (nm-send-input-to nm) 'client-input
 171       #:data line
 172       #:client client-id))
 173
 174 (define-method (nm-send-to-client-id nm client-id data)
 175   "Send DATA to TO-CLIENT id"
 176   (display data
 177            (hash-ref (nm-clients nm) client-id)))
 178
 179 ; (ez-run-hive hive (list (bootstrap-message hive (actor-id nm) 'start-listening)))
 180
 181
 182 ;; (define-method (nm-close-port (nm <network-manager>)))
 183
 184
 185 \f
 186 ;;; The game master!  Runs the world.
 187 ;;; =================================
 188
 189 ;; @@: We could call this a "world builder" instead...
 190 ;;   I kinda like calling it a GM though.
 191
 192 (define-class <game-master> (<actor>)
 193   ;; The directory is a "namespaced" directory of all "special" content
 194   ;; in the game, identifiable by some special key.
 195   ;; (The namespace is simply a cons of (namespace . special-symbol))
 196   (directory #:init-thunk make-hash-table)
 197   ;; A mapping of client ids to in-game actors
 198   (client-to-actor #:init-thunk make-hash-table)
 199   ;; Network manager
 200   (network-manager #:accessor gm-network-manager
 201                    #:init-value #f)
 202
 203   (message-handler
 204    #:init-value
 205    (make-action-dispatch
 206     (init-world (wrap-apply gm-init-world))
 207     (client-input (wrap-apply gm-handle-client-input)))))
 208
 209
 210 (define (gm-init-world gm message)
 211   ;; Load database
 212   ;;  TODO
 213
 214   ;; Init basic rooms / structure
 215   ;;  TODO
 216
 217   ;; Restore database-based actors
 218   ;;  TODO
 219
 220   ;; Set up the network
 221   (gm-setup-network gm))
 222
 223 (define (gm-setup-network gm)
 224   ;; Create a default network manager if none available
 225   (set! (gm-network-manager gm)
 226         (create-actor* gm <network-manager> "netman"
 227                        #:send-input-to (actor-id gm)))
 228
 229   ;; TODO: Add host and port options
 230   (<-wait gm (gm-network-manager gm) 'start-listening))
 231
 232 (define (gm-handle-client-input actor message)
 233   "Handle input from a client."
 234   (define client-id (message-ref message 'client))
 235   (define input (message-ref message 'data))
 236   (format #t "From ~s: ~s\n" client-id input)
 237   (<- actor (gm-network-manager actor) 'send-to-client
 238       #:client client-id
 239       #:data "Thanks, we got it!\n"))
 240
 241 (define-method (gm-setup-database (gm <game-master>))
 242   'TODO)
 243
 244 (define-method (gm-setup-rooms-etc (gm <game-master>))
 245   'TODO)
 246
 247 \f
 248 ;;; Rooms
 249 ;;; =====
 250
 251 ;; @@: Maybe make this into a record type when this congeals a bit?
 252 ;;   I dunno?
 253
 254 (define-class <exit> ()
 255   ;; Used for wiring
 256   (to-symbol #:accessor exit-to-symbol
 257              #:init-keyword #:to-symbol)
 258   ;; The actual address we use
 259   (to-address #:accessor exit-to-address
 260               #:init-keyword #:address)
 261   ;; Name of the room (@@: Should this be names?)
 262   (name #:accessor exit-name
 263         #:init-keyword #:name)
 264   (description #:accessor exit-description
 265                #:init-keyword #:address)
 266
 267   ;; *Note*: These two methods have an extra layer of indirection, but
 268   ;;   it's for a good reason.
 269   (visible-check #:init-keyword (const #t))
 270   ;; By default all exits can be traversed
 271   (traverse-check #:init-keyword (const #t)))
 272
 273 (define* (exit-can-traverse? exit actor
 274                              #:optional (target-actor (actor-id actor)))
 275   ((slot-ref exit 'traverse-check) exit actor target-actor))
 276
 277 (define* (exit-is-visible? exit actor
 278                            #:optional (target-actor (actor-id actor)))
 279   ((slot-ref exit 'traverse-check) exit actor target-actor))
 280
 281
 282 ;; Kind of a useful utility, maybe?
 283 (define (simple-slot-getter slot)
 284   (lambda (actor message)
 285     (reply-message actor message
 286                    #:val (slot-ref actor slot))))
 287
 288
 289 (define-class <room> (<actor>)
 290   (name #:init-keyword #:name)
 291   (description #:init-value ""
 292                #:init-keyword #:description)
 293   ;; Uses a hash table like a set (values ignored)
 294   (occupants #:init-thunk make-hash-table)
 295   ;; A list of <exit>
 296   (exits #:init-value '()
 297          #:getter room-exits)
 298   ;; @@: Maybe eventually <room> will inherit from some more general
 299   ;;  game object class
 300   (gm #:init-keyword #:gm
 301       #:getter room-gm)
 302
 303   (message-handler
 304    #:allocation #:each-subclass
 305    #:init-value
 306    (make-action-dispatch
 307     (get-description
 308      (simple-slot-getter 'description))
 309     (get-name
 310      (simple-slot-getter 'name))
 311     ((register-occupant! actor message who)
 312      "Register an actor as being a occupant of this room"
 313      (hash-set! (slot-ref actor 'occupants) who #t))
 314     ((evict-occupant! actor message who)
 315      "De-register an occupant removed from the room"
 316      (hash-remove! (slot-ref actor 'occupants) who))
 317     ((wire-exits! actor message)
 318      (wrap-apply room-wire-exits!)))))
 319
 320 (define (room-wire-exits! room message)
 321   (for-each
 322    (lambda (exit)
 323      (define new-exit
 324        (<-wait room (room-gm room) 'lookup-room
 325                #:symbol (exit-to-symbol exit)))
 326
 327      (set! (exit-to-address exit) new-exit))
 328
 329    (room-exits room)))
 330
 331
 332 \f
 333 ;;; Players
 334 ;;; =======
 335
 336
 337 ;; Debugging stuff
 338 (define %test-gm #f)
 339
 340 (define (run-demo . args)
 341   (define hive (make-hive))
 342   (define gm
 343     (hive-create-actor-gimmie* hive <game-master> "gm"))
 344   (set! %test-gm gm)
 345   ;; @@: Boy, wouldn't it be nice if the agenda could do things
 346   ;;   on interrupt :P
 347   (ez-run-hive hive
 348                (list (bootstrap-message hive (actor-id gm) 'init-world))))