chat_client.scm

   1 (import matchable
   2         srfi-13
   3         (chicken process-context))
   4
   5 (define (make-client-beh system)
   6   (let ((name "name")
   7         (recipients '()))
   8     (lambda (self . message)
   9       (match message
  10         (('start)
  11          (send-message system 'print "Welcome to chat!\n"
  12                        "Your client address is " (address->string self) ".\n"
  13                        "Type '/help' for a list of commands.\n")
  14          (send-message system 'read self))
  15         (('show-msg from text)
  16          (send-message system 'print from "> " text))
  17         (((? string? str))
  18          (if (string-prefix? "/" str)
  19              (let* ((maybe-idx (string-index str #\space))
  20                     (idx (if maybe-idx maybe-idx (string-length str)))
  21                     (cmd (substring str 1 idx))
  22                     (arg (string-trim (substring str idx))))
  23                (match cmd
  24                  ((or "h" "help")
  25                   (send-message system 'print
  26                                 "Command          | Description\n"
  27                                 "------------------------------\n"
  28                                 "/help              List commands\n"
  29                                 "/name Name         Set name to use in chat.\n"
  30                                 "/join <address>    Join chat with specified client\n"
  31                                 "/clear             Clear recipients\n"
  32                                 "/list              List current recipients\n"
  33                                 "/quit              Quit chat"))
  34                  ((or "j" "join")
  35                   (if (string-null? arg)
  36                       (send-message system 'print "Missing address of client.")
  37                       (begin
  38                         (set! recipients (cons (string->address arg) recipients))
  39                         (send-message system 'print "Added recipient to chat."))))
  40                  ((or "c" "clear")
  41                   (set! recipients '())
  42                   (send-message system 'print "Cleared recipient list."))
  43                  ((or "n" "name")
  44                   (set! name arg)
  45                   (send-message system 'print "Name now set to '" name "'."))
  46                  ((or "l" "list")
  47                   (if (null? recipients)
  48                       (send-message system 'print "Recipients list empty.")
  49                       (begin
  50                         (send-message system 'print "Current recipients:")
  51                         (let loop ((recipients-left recipients))
  52                           (unless (null? recipients-left)
  53                             (send-message system 'print (address->string (car recipients-left)))
  54                             (loop (cdr recipients-left)))))))
  55                  ((or "q" "quit")
  56                   (send-message system 'shutdown))
  57                  (else
  58                   (send-message system 'print "Unrecognised command '" cmd "'"))))
  59              (if (null? recipients)
  60                  (send-message system 'print "Speaking to the void.")
  61                  (let loop ((recipients-left recipients))
  62                    (unless (null? recipients-left)
  63                      (send-message (car recipients-left) 'show-msg name str)
  64                      (loop (cdr recipients-left))))))))
  65       (send-message system 'read self)
  66       'sleep)))
  67
  68 (define (main-beh self system)
  69   (send-message (make-actor (make-client-beh system)) 'start)
  70   'done)