chat_client.scm

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