chat_client.scm

   1 (import sam
   2         matchable
   3         srfi-13
   4         (chicken process-context))
   5
   6 (define client-beh
   7   (let ((name "name")
   8         (recipients '()))
   9
  10     (lambda (self . message)
  11       (match message
  12         (('start)
  13          (send-message system 'print "Welcome to chat!\n"
  14                        "Your client address is " self ".\n"
  15                        "Type '/help' for a list of commands.\n")
  16          (send-message system 'read self))
  17         (('show-msg from text)
  18          (send-message system 'print "Message from " from ": " text))
  19         (((? string? str))
  20          (if (string-prefix? "/" str)
  21              (let* ((maybe-idx (string-index str #\space))
  22                     (idx (if maybe-idx maybe-idx (string-length str)))
  23                     (cmd (substring str 1 idx))
  24                     (arg (string-trim (substring str idx))))
  25                (match cmd
  26                  ((or "h" "help")
  27                   (send-message system 'print
  28                                 "Command          | Description\n"
  29                                 "------------------------------\n"
  30                                 "/help              List commands\n"
  31                                 "/name Name         Set name to use in chat.\n"
  32                                 "/join <address>    Join chat with specified client\n"
  33                                 "/clear             Clear recipients\n"
  34                                 "/list              List current recipients\n"
  35                                 "/quit              Quit chat"))
  36                  ((or "j" "join")
  37                   (if (string-null? arg)
  38                       (send-message system 'print "Missing address of client.")
  39                       (begin
  40                         (set! recipients (cons arg recipients))
  41                         (send-message system 'print "Added recipient to chat."))))
  42                  ((or "c" "clear")
  43                   (set! recipients '())
  44                   (send-message system 'print "Cleared recipient list."))
  45                  ((or "n" "name")
  46                   (set! name arg)
  47                   (send-message system 'print "Name now set to '" name "'."))
  48                  ((or "l" "list")
  49                   (if (null? recipients)
  50                       (send-message system 'print "Recipients list empty.")
  51                       (begin
  52                         (send-message system 'print "Current recipients:")
  53                         (let loop ((recipients-left recipients))
  54                           (unless (null? recipients-left)
  55                             (send-message system 'print (car recipients-left))
  56                             (loop (cdr recipients-left)))))))
  57                  ((or "q" "quit")
  58                   (send-message system 'shutdown))
  59                  (else
  60                   (send-message system 'print "Unrecognised command '" cmd "'"))))
  61              (if (null? recipients)
  62                  (send-message system 'print "Speaking to the void.")
  63                  (let loop ((recipients-left recipients))
  64                    (unless (null? recipients-left)
  65                      (send-message (car recipients-left) 'show-msg name str)
  66                      (loop (cdr recipients-left))))))))
  67       (send-message system 'read self)
  68       'sleep)))
  69
  70 (define (print-usage)
  71   (print "Actor-driven chat client.\n")
  72   (print "Usage: chat_client -h")
  73   (print "       chat_client [-p port_num] [-n host_name]"))
  74
  75 (let loop ((args (cdr (argv)))
  76            (host "localhost")
  77            (port 8000))
  78   (match args
  79     (((or "-h" "--help"))
  80      (print-usage))
  81     (((or "-p" "--port") pstr rest ...)
  82      (loop rest host (string->number pstr)))
  83     (((or "-n" "--hostname") hstr rest ...)
  84      (loop rest hstr port))
  85     (()
  86      (init-sam host port)
  87      (send-message (make-actor client-beh) 'start)
  88      (start-console))
  89     (else
  90      (print "Unrecognised argument '" (car args) "'.\n")
  91      (print-usage))))
  92