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       ;; @@: Do we need an 8sync-port-wait here?
 124       ;;   Is such a thing even possible? :\
 125       (8sync-port client #:read (nm-make-client-receive nm client-id))
 126       (<- nm (nm-send-input-to nm) 'new-client #:client client-id))))
 127
 128 (define (nm-make-client-receive nm client-id)
 129   "Make a method to receive client data"
 130   (let ((buffer '()))
 131     (define (reset-buffer)
 132       (set! buffer '()))
 133     (define (should-read-char client)
 134       (and (not (port-closed? client))
 135            (char-ready? client)
 136            (not (eof-object? (peek-char client)))))
 137     (define (receive-handler client)
 138       (while (should-read-char client)
 139         (set! buffer (cons (read-char client) buffer))
 140         (match buffer
 141           (;; @@: Do we need the "char?"
 142            (#\newline #\return (? char? line-chars) ...)
 143            (let ((ready-line (list->string (reverse line-chars))))
 144              ;; reset buffer
 145              (set! buffer '())
 146              ;; run it
 147              (nm-handle-line nm client client-id ready-line)))
 148           (_ #f)))
 149       ;; Shut things down on closed port or EOF object
 150       (cond
 151        ((port-closed? client)
 152         (nm-handle-port-closed nm client client-id))
 153        ((and (char-ready? client)
 154              (eof-object? (peek-char client)))
 155         (nm-handle-port-eof nm client client-id))))
 156     receive-handler))
 157
 158 (define (nm-handle-port-closed nm client client-id)
 159   "Handle a closed port"
 160   (format #t "DEBUG: handled closed port ~x\n" client-id)
 161   (8sync-port-remove client)
 162   (hash-remove! (nm-clients nm) client-id))
 163
 164 (define-method (nm-handle-port-eof nm client client-id)
 165   "Handle seeing an EOF on port"
 166   (format #t "DEBUG: handled eof-object on port ~x\n" client-id)
 167   (close client)
 168   (8sync-port-remove client)
 169   (hash-remove! (nm-clients nm) client-id))
 170
 171 (define-method (nm-handle-line nm client client-id line)
 172   "Handle an incoming line of input from a client"
 173   (<- nm (nm-send-input-to nm) 'client-input
 174       #:data line
 175       #:client client-id))
 176
 177 (define-method (nm-send-to-client-id nm client-id data)
 178   "Send DATA to TO-CLIENT id"
 179   (define client-obj (hash-ref (nm-clients nm) client-id))
 180   (if (not client-obj)
 181       (throw 'no-such-client
 182              "Asked to send data to client but that client doesn't exist"
 183              #:client-id client-id
 184              #:data data))
 185   (display data client-obj))
 186
 187 ; (ez-run-hive hive (list (bootstrap-message hive (actor-id nm) 'start-listening)))
 188
 189
 190 ;; (define-method (nm-close-port (nm <network-manager>)))
 191
 192
 193 \f
 194 ;;; The game master!  Runs the world.
 195 ;;; =================================
 196
 197 ;; @@: We could call this a "world builder" instead...
 198 ;;   I kinda like calling it a GM though.
 199
 200 (define-class <game-master> (<actor>)
 201   ;; Directory of "special" objects.
 202   (special-dir #:init-thunk make-hash-table
 203                #:getter gm-special-dir)
 204
 205   ;; Room directory.  Room symbols to locations.
 206   (room-dir #:init-thunk make-hash-table
 207             #:getter gm-room-dir)
 208
 209   ;; A mapping of client ids to in-game actors
 210   ;; and a reverse ;p
 211   (client-dir #:init-thunk make-hash-table
 212               #:getter gm-client-dir)
 213   (reverse-client-dir #:init-thunk make-hash-table
 214                       #:getter gm-reverse-client-dir)
 215
 216   ;; Network manager
 217   (network-manager #:accessor gm-network-manager
 218                    #:init-value #f)
 219
 220   ;; How we get a new connection acclimated to the system
 221   (new-conn-handler #:accessor gm-new-conn-handler
 222                     #:init-keyword #:new-conn-handler)
 223
 224   (message-handler
 225    #:init-value
 226    (make-action-dispatch
 227     (init-world (wrap-apply gm-init-world))
 228     (client-input (wrap-apply gm-handle-client-input))
 229     (lookup-room (wrap-apply gm-lookup-room))
 230     (new-client (wrap-apply gm-new-client))
 231     (write-home (wrap-apply gm-write-home)))))
 232
 233
 234 ;;; .. begin world init stuff ..
 235
 236 (define (gm-init-world gm message)
 237   ;; Load database
 238   ;;  TODO
 239
 240   ;; Init basic rooms / structure
 241   (gm-init-rooms gm (message-ref message 'room-spec))
 242
 243   ;; Restore database-based actors
 244   ;;  TODO
 245
 246   ;; Set up the network
 247   (gm-setup-network gm))
 248
 249 (define (gm-init-rooms gm rooms-spec)
 250   "Initialize the prebuilt rooms"
 251   ;; @@: Would it be nicer to just allow passing in
 252   ;;     #:exits to the room spec itself?
 253   (define (exit-from-spec exit-spec)
 254     "Take room exits syntax from the spec, turn it into exits"
 255     (match exit-spec
 256       ((name to-symbol desc)
 257        (make <exit>
 258          #:name name
 259          #:to-symbol to-symbol
 260          #:desc desc))))
 261
 262   (define rooms
 263     (map
 264      (match-lambda
 265        ((room-symbol room-class
 266                      room-args ...
 267                      (room-exits ...))
 268         ;; initialize the room
 269         (let ((room
 270                (apply create-actor* gm room-class "room"
 271                       #:gm (actor-id gm)
 272                       #:exits (map exit-from-spec room-exits)
 273                       room-args)))
 274           ;; register the room
 275           (hash-set! (gm-room-dir gm) room-symbol room)
 276           ;; pass it back to the map
 277           room)))
 278      rooms-spec))
 279
 280   ;; now wire up all the exits
 281   (for-each
 282    (lambda (room)
 283      (format #t "Wiring up ~s...\n" (address->string room))
 284      (<-wait gm room 'wire-exits!))
 285    rooms))
 286
 287
 288 (define (gm-setup-network gm)
 289   ;; Create a default network manager if none available
 290   (set! (gm-network-manager gm)
 291         (create-actor* gm <network-manager> "netman"
 292                        #:send-input-to (actor-id gm)))
 293
 294   ;; TODO: Add host and port options
 295   (<-wait gm (gm-network-manager gm) 'start-listening))
 296
 297 (define (gm-setup-database gm)
 298   'TODO)
 299
 300 ;;; .. end world init stuff ...
 301
 302 (define-mhandler (gm-new-client actor message client)
 303   ;; @@: Maybe more indirection than needed for this
 304   ((gm-new-conn-handler actor) actor client))
 305
 306
 307 (define (gm-handle-client-input actor message)
 308   "Handle input from a client."
 309   (define client-id (message-ref message 'client))
 310   (define input (message-ref message 'data))
 311   (format #t "From ~s: ~s\n" client-id input)
 312   (<- actor (gm-network-manager actor) 'send-to-client
 313       #:client client-id
 314       #:data "Thanks, we got it!\n"))
 315
 316 (define-mhandler (gm-lookup-room actor message symbol)
 317   (define room-id
 318     (slot-ref (gm-room-dir actor) symbol))
 319   (<-reply actor message room-id))
 320
 321 (define-mhandler (gm-write-home actor message text)
 322   (define client-id (hash-ref (gm-reverse-client-dir actor)
 323                               (message-from message)))
 324   (<- actor (gm-network-manager actor) 'send-to-client
 325       #:client client-id
 326       #:data text))
 327
 328
 329 ;;; GM utilities
 330
 331 (define (gm-register-client! gm client-id player)
 332   (hash-set! (gm-client-dir gm) client-id player)
 333   (hash-set! (gm-reverse-client-dir gm) player client-id))
 334
 335 (define (gm-unregister-client! gm client-id)
 336   "Remove a connection/player combo and ask them to self destruct"
 337   (match (hash-remove! (gm-client-dir gm) client-id)  ; Remove from our client dir
 338     ((_ . player-id)
 339      ;; Remove from reverse table too
 340      (hash-remove! (gm-reverse-client-dir gm) client-id)
 341      ;; Destroy player
 342      (<- gm player-id 'destroy-self))
 343     (#f (throw 'no-client-to-unregister
 344                "Can't unregister a client that doesn't exist?"
 345                client-id))))
 346
 347 ;;; An easy default
 348
 349 (define (make-default-room-conn-handler default-room)
 350   "Make a handler for a GM that dumps people in a default room
 351 with an anonymous persona"
 352   (let ((count 0))
 353     (lambda (gm client-id)
 354       (define guest-name (string-append "Guest-"
 355                                         (number->string count)))
 356       (define room-id
 357         (hash-ref (gm-room-dir gm) default-room))
 358       ;; create and register the player
 359       (define player
 360         (create-actor* gm <player> "player"
 361                        #:username guest-name
 362                        #:gm (actor-id gm)
 363                        #:client client-id))
 364
 365       ;; Register the player in our database of players -> connections
 366       (gm-register-client! gm client-id player)
 367       ;; Dump the player into the default room
 368       (<-wait gm player 'set-loc! #:id room-id)
 369       ;; Initialize the player
 370       (<- gm player 'init))))
 371
 372
 373 ;;; Game actor
 374 ;;; ==========
 375
 376 ;;; *all* game components that talk to players should somehow
 377 ;;; derive from this class.
 378 ;;; And all of them need a GM!
 379
 380 (define-class <gameobj> (<actor>)
 381   ;; location id
 382   (loc #:init-value #f
 383        #:accessor gameobj-loc)
 384   ;; game master id
 385   (gm #:init-keyword #:gm
 386       #:getter gameobj-gm)
 387   ;; a name to be known by
 388   (name #:init-keyword #:name
 389         #:accessor gameobj-name)
 390
 391   ;; how to print our name
 392   (name-f #:init-keyword #:name-f
 393           #:getter gameobj-name-f
 394           #:init-value gameobj-simple-name-f)
 395
 396   ;; Name aliases
 397   (aliases #:init-keyword #:aliases
 398            #:init-value '())
 399
 400   ;; Commands we can handle
 401   (commands #:init-value #f)
 402   ;; Commands we can handle by being something's container
 403   (contain-commands #:init-value #f))
 404
 405
 406 (define (gameobj-simple-name-f gameobj)
 407   "Simplest version: return ourselves for our name."
 408   (gameobj-name gameobj))
 409
 410
 411 \f
 412 ;;; Rooms
 413 ;;; =====
 414
 415 ;; @@: Maybe make this into a record type when this congeals a bit?
 416 ;;   I dunno?
 417
 418 (define-class <exit> ()
 419   ;; Used for wiring
 420   (to-symbol #:accessor exit-to-symbol
 421              #:init-keyword #:to-symbol)
 422   ;; The actual address we use
 423   (to-address #:accessor exit-to-address
 424               #:init-keyword #:address)
 425   ;; Name of the room (@@: Should this be names?)
 426   (name #:accessor exit-name
 427         #:init-keyword #:name)
 428   (desc #:accessor exit-desc
 429                #:init-keyword #:desc)
 430
 431   ;; *Note*: These two methods have an extra layer of indirection, but
 432   ;;   it's for a good reason.
 433   (visible-check #:init-value (const #t)
 434                  #:init-keyword #:visible-check)
 435   ;; By default all exits can be traversed
 436   (traverse-check #:init-value (const #t)
 437                   #:init-keyword #:traverse-check))
 438
 439 (define* (exit-can-traverse? exit actor
 440                              #:optional (target-actor (actor-id actor)))
 441   ((slot-ref exit 'traverse-check) exit actor target-actor))
 442
 443 (define* (exit-is-visible? exit actor
 444                            #:optional (target-actor (actor-id actor)))
 445   ((slot-ref exit 'traverse-check) exit actor target-actor))
 446
 447
 448 ;; Kind of a useful utility, maybe?
 449 (define (simple-slot-getter slot)
 450   (lambda (actor message)
 451     (reply-message actor message
 452                    #:val (slot-ref actor slot))))
 453
 454
 455 ;; TODO: Subclass from container?
 456 (define-class <room> (<gameobj>)
 457   (desc #:init-value ""
 458                #:init-keyword #:desc)
 459   ;; TODO: Switch this to be loc based
 460   ;; Uses a hash table like a set (values ignored)
 461   (occupants #:init-thunk make-hash-table)
 462   ;; A list of <exit>
 463   (exits #:init-value '()
 464          #:getter room-exits)
 465   ;; @@: Maybe eventually <room> will inherit from some more general
 466   ;;  game object class
 467
 468   (contain-commands
 469    #:init-value %room-contain-commands)
 470
 471   (message-handler
 472    #:allocation #:each-subclass
 473    #:init-value
 474    (make-action-dispatch
 475     ;; desc == description
 476     (get-desc
 477      (simple-slot-getter 'desc))
 478     (get-name
 479      (simple-slot-getter 'name))
 480     ((register-occupant! actor message who)
 481      "Register an actor as being a occupant of this room"
 482      (hash-set! (slot-ref actor 'occupants) who #t))
 483     ((evict-occupant! actor message who)
 484      "De-register an occupant removed from the room"
 485      (hash-remove! (slot-ref actor 'occupants) who))
 486     (wire-exits! (wrap-apply room-wire-exits!)))))
 487
 488 (define always (const #t))
 489
 490 (define %room-contain-commands
 491   (list
 492    (command "look" cmatch-just-verb always 'look-room)
 493    (command "look" cmatch-direct-obj always 'look-member)
 494    (command "go" cmathc-just-verb always 'go-where)
 495    (command "go" cmatch-direct-obj always 'go-exit)))
 496
 497
 498 (define (room-wire-exits! room message)
 499   "Actually hook up the rooms' exit addresses to the rooms they
 500 claim to point to."
 501   (for-each
 502    (lambda (exit)
 503      (define new-exit
 504        (<-wait room (gameobj-gm room) 'lookup-room
 505                #:symbol (exit-to-symbol exit)))
 506
 507      (set! (exit-to-address exit) new-exit))
 508
 509    (room-exits room)))
 510
 511
 512 \f
 513 ;;; Players
 514 ;;; =======
 515
 516 (define-class <player> (<gameobj>)
 517   (username #:init-keyword #:username
 518             #:accessor player-username)
 519   ;; Connection id
 520   (client #:accessor player-client)
 521
 522   (self-commands
 523    #:init-value #f  ; TODO: Set me to a reasonable default
 524    #:accessor player-self-commands)
 525
 526   (message-handler
 527    #:init-value
 528    (make-action-dispatch
 529     (set-loc! (wrap-apply player-set-loc!))
 530     (init (wrap-apply player-init!)))))
 531
 532 ;;; player message handlers
 533
 534 (define-mhandler (player-set-loc! player message id)
 535   (format #t "DEBUG: Location set to ~s for player ~s\n"
 536           id (actor-id-actor player))
 537   (set! (gameobj-loc player) id))
 538
 539 (define-mhandler (player-init! player message)
 540   (player-look-around player))
 541
 542 ;;; player methods
 543
 544 (define (player-look-around player)
 545   (define room-name
 546     (message-ref
 547      (<-wait player (gameobj-loc player) 'get-name)
 548      'val))
 549   (define room-desc
 550     (message-ref
 551      (<-wait player (gameobj-loc player) 'get-desc)
 552      'val))
 553   (define message-text
 554     (format #f "**~a**\n~a\n" room-name room-desc))
 555
 556   (<- player (gameobj-gm player) 'write-home #:text message-text))
 557
 558 \f
 559 ;;; Debugging stuff
 560 ;;; ===============
 561
 562 (define %test-gm #f)
 563
 564 (define (run-demo db-path room-spec default-room)
 565   (define hive (make-hive))
 566   (define new-conn-handler
 567     (make-default-room-conn-handler default-room))
 568   (define gm
 569     (hive-create-actor-gimmie* hive <game-master> "gm"
 570                                #:new-conn-handler new-conn-handler))
 571   (set! %test-gm gm)
 572   ;; @@: Boy, wouldn't it be nice if the agenda could do things
 573   ;;   on interrupt :P
 574   (ez-run-hive hive
 575                (list (bootstrap-message hive (actor-id gm) 'init-world
 576                                         #:room-spec room-spec))))