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   ;; Directory of "special" objects.
 194   (special-dir #:init-thunk make-hash-table
 195                #:getter gm-special-dir)
 196
 197   ;; Room directory.  Room symbols to
 198   (room-dir #:init-thunk make-hash-table
 199             #:getter gm-room-dir)
 200
 201   ;; A mapping of client ids to in-game actors
 202   (client-to-actor #:init-thunk make-hash-table)
 203   ;; Network manager
 204   (network-manager #:accessor gm-network-manager
 205                    #:init-value #f)
 206
 207   (message-handler
 208    #:init-value
 209    (make-action-dispatch
 210     (init-world (wrap-apply gm-init-world))
 211     (client-input (wrap-apply gm-handle-client-input))
 212     (lookup-room (wrap-apply gm-lookup-room)))))
 213
 214
 215 ;;; .. begin world init stuff ..
 216
 217 (define (gm-init-world gm message)
 218   ;; Load database
 219   ;;  TODO
 220
 221   ;; Init basic rooms / structure
 222   (gm-init-rooms gm (message-ref message 'room-spec))
 223
 224   ;; Restore database-based actors
 225   ;;  TODO
 226
 227   ;; Set up the network
 228   (gm-setup-network gm))
 229
 230 (define (gm-init-rooms gm rooms-spec)
 231   "Initialize the prebuilt rooms"
 232   ;; @@: Would it be nicer to just allow passing in
 233   ;;     #:exits to the room spec itself?
 234   (define (exit-from-spec exit-spec)
 235     "Take room exits syntax from the spec, turn it into exits"
 236     (match exit-spec
 237       ((name to-symbol description)
 238        (make <exit>
 239          #:name name
 240          #:to-symbol to-symbol
 241          #:description description))))
 242
 243   (define rooms
 244     (map
 245      (match-lambda
 246        ((room-symbol room-class
 247                      room-args ...
 248                      (room-exits ...))
 249
 250         ;; initialize the room
 251         (apply create-actor* gm room-class "room"
 252                #:gm (actor-id gm)
 253                #:exits (map exit-from-spec room-exits)
 254                room-args)))
 255      rooms-spec))
 256
 257   ;; now wire up all the exits
 258   (for-each
 259    (lambda (room)
 260      (format #t "Wiring up ~s...\n" (address->string room))
 261      (<-wait gm room 'wire-exits!))
 262    rooms))
 263
 264
 265 (define (gm-setup-network gm)
 266   ;; Create a default network manager if none available
 267   (set! (gm-network-manager gm)
 268         (create-actor* gm <network-manager> "netman"
 269                        #:send-input-to (actor-id gm)))
 270
 271   ;; TODO: Add host and port options
 272   (<-wait gm (gm-network-manager gm) 'start-listening))
 273
 274 ;;; .. end world init stuff ...
 275
 276
 277 (define (gm-handle-client-input actor message)
 278   "Handle input from a client."
 279   (define client-id (message-ref message 'client))
 280   (define input (message-ref message 'data))
 281   (format #t "From ~s: ~s\n" client-id input)
 282   (<- actor (gm-network-manager actor) 'send-to-client
 283       #:client client-id
 284       #:data "Thanks, we got it!\n"))
 285
 286 (define-mhandler (gm-lookup-room actor message symbol)
 287   (define room-id
 288     (slot-ref (gm-room-dir actor) symbol))
 289   (<-reply actor message room-id))
 290
 291 (define-method (gm-setup-database (gm <game-master>))
 292   'TODO)
 293
 294 (define-method (gm-setup-rooms-etc (gm <game-master>))
 295   'TODO)
 296
 297
 298 \f
 299 ;;; Rooms
 300 ;;; =====
 301
 302 ;; @@: Maybe make this into a record type when this congeals a bit?
 303 ;;   I dunno?
 304
 305 (define-class <exit> ()
 306   ;; Used for wiring
 307   (to-symbol #:accessor exit-to-symbol
 308              #:init-keyword #:to-symbol)
 309   ;; The actual address we use
 310   (to-address #:accessor exit-to-address
 311               #:init-keyword #:address)
 312   ;; Name of the room (@@: Should this be names?)
 313   (name #:accessor exit-name
 314         #:init-keyword #:name)
 315   (description #:accessor exit-description
 316                #:init-keyword #:description)
 317
 318   ;; *Note*: These two methods have an extra layer of indirection, but
 319   ;;   it's for a good reason.
 320   (visible-check #:init-value (const #t)
 321                  #:init-keyword #:visible-check)
 322   ;; By default all exits can be traversed
 323   (traverse-check #:init-value (const #t)
 324                   #:init-keyword #:traverse-check))
 325
 326 (define* (exit-can-traverse? exit actor
 327                              #:optional (target-actor (actor-id actor)))
 328   ((slot-ref exit 'traverse-check) exit actor target-actor))
 329
 330 (define* (exit-is-visible? exit actor
 331                            #:optional (target-actor (actor-id actor)))
 332   ((slot-ref exit 'traverse-check) exit actor target-actor))
 333
 334
 335 ;; Kind of a useful utility, maybe?
 336 (define (simple-slot-getter slot)
 337   (lambda (actor message)
 338     (reply-message actor message
 339                    #:val (slot-ref actor slot))))
 340
 341
 342 (define-class <room> (<actor>)
 343   (name #:init-keyword #:name)
 344   (description #:init-value ""
 345                #:init-keyword #:description)
 346   ;; Uses a hash table like a set (values ignored)
 347   (occupants #:init-thunk make-hash-table)
 348   ;; A list of <exit>
 349   (exits #:init-value '()
 350          #:getter room-exits)
 351   ;; @@: Maybe eventually <room> will inherit from some more general
 352   ;;  game object class
 353   (gm #:init-keyword #:gm
 354       #:getter room-gm)
 355
 356   (message-handler
 357    #:allocation #:each-subclass
 358    #:init-value
 359    (make-action-dispatch
 360     (get-description
 361      (simple-slot-getter 'description))
 362     (get-name
 363      (simple-slot-getter 'name))
 364     ((register-occupant! actor message who)
 365      "Register an actor as being a occupant of this room"
 366      (hash-set! (slot-ref actor 'occupants) who #t))
 367     ((evict-occupant! actor message who)
 368      "De-register an occupant removed from the room"
 369      (hash-remove! (slot-ref actor 'occupants) who))
 370     (wire-exits! (wrap-apply room-wire-exits!)))))
 371
 372 (define (room-wire-exits! room message)
 373   (for-each
 374    (lambda (exit)
 375      (define new-exit
 376        (<-wait room (room-gm room) 'lookup-room
 377                #:symbol (exit-to-symbol exit)))
 378
 379      (set! (exit-to-address exit) new-exit))
 380
 381    (room-exits room)))
 382
 383
 384 \f
 385 ;;; Players
 386 ;;; =======
 387
 388
 389 ;; Debugging stuff
 390 (define %test-gm #f)
 391
 392 (define (run-demo db-path room-spec)
 393   (define hive (make-hive))
 394   (define gm
 395     (hive-create-actor-gimmie* hive <game-master> "gm"))
 396   (set! %test-gm gm)
 397   ;; @@: Boy, wouldn't it be nice if the agenda could do things
 398   ;;   on interrupt :P
 399   (ez-run-hive hive
 400                (list (bootstrap-message hive (actor-id gm) 'init-world
 401                                         #:room-spec room-spec))))