extra/managed-server/chat/chat.factor

   1 ! Copyright (C) 2009 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators combinators.smart
   4 destructors fry io io.encodings.utf8 kernel managed-server
   5 namespaces parser sequences sorting splitting strings.parser
   6 unicode.case unicode.categories calendar calendar.format
   7 locals io.encodings.binary io.encodings.string prettyprint ;
   8 FROM: namespaces => set ;
   9 IN: managed-server.chat
  10
  11 TUPLE: chat-server < managed-server ;
  12
  13 SYMBOL: commands
  14 commands [ H{ } clone ] initialize
  15
  16 SYMBOL: chat-docs
  17 chat-docs [ H{ } clone ] initialize
  18
  19 CONSTANT: line-beginning "-!- "
  20
  21 : send-line ( string -- )
  22     write "\r\n" write flush ;
  23
  24 : handle-me ( string -- )
  25     [
  26         [ "* " username " " ] dip
  27     ] "" append-outputs-as send-everyone ;
  28
  29 : handle-quit ( string -- )
  30     client [ (>>object) ] [ t >>quit? drop ] bi ;
  31
  32 : handle-help ( string -- )
  33     [
  34         "Commands: "
  35         commands get keys natural-sort ", " join append send-line
  36     ] [
  37         chat-docs get ?at
  38         [ send-line ]
  39         [ "Unknown command: " prepend send-line ] if
  40     ] if-empty ;
  41
  42 : usage ( string -- )
  43     chat-docs get at send-line ;
  44
  45 : username-taken-string ( username -- string )
  46     "The username ``" "'' is already in use; try again." surround ;
  47
  48 : warn-name-changed ( old new -- )
  49     [
  50         [ line-beginning "``" ] 2dip
  51         [ "'' is now known as ``" ] dip "''"
  52     ] "" append-outputs-as send-everyone ;
  53
  54 : handle-nick ( string -- )
  55     [
  56         "nick" usage
  57     ] [
  58         dup clients key? [
  59             username-taken-string send-line
  60         ] [
  61             [ username swap warn-name-changed ]
  62             [ username clients rename-at ]
  63             [ client (>>username) ] tri
  64         ] if
  65     ] if-empty ;
  66
  67 :: add-command ( quot docs key -- )
  68     quot key commands get set-at
  69     docs key chat-docs get set-at ;
  70
  71 [ handle-help ]
  72 """Syntax: /help [command]
  73 Displays the documentation for a command."""
  74 "help" add-command
  75
  76 [ drop clients keys [ "``" "''" surround ] map ", " join send-line ]
  77 """Syntax: /who
  78 Shows the list of connected users."""
  79 "who" add-command
  80
  81 [ drop gmt timestamp>rfc822 send-line ]
  82 """Syntax: /time
  83 Returns the current GMT time.""" "time" add-command
  84
  85 [ handle-nick ]
  86 """Syntax: /nick nickname
  87 Changes your nickname."""
  88 "nick" add-command
  89
  90 [ handle-me ]
  91 """Syntax: /me action"""
  92 "me" add-command
  93
  94 [ handle-quit ]
  95 """Syntax: /quit [message]
  96 Disconnects a user from the chat server.""" "quit" add-command
  97
  98 : handle-command ( string -- )
  99     dup " " split1 swap >lower commands get at* [
 100         call( string -- ) drop
 101     ] [
 102         2drop "Unknown command: " prepend send-line
 103     ] if ;
 104
 105 : <chat-server> ( port -- managed-server )
 106     "chat-server" utf8 chat-server new-managed-server ;
 107
 108 : handle-chat ( string -- )
 109     [
 110         [ username ": " ] dip
 111     ] "" append-outputs-as send-everyone ;
 112
 113 M: chat-server handle-login
 114     "Username: " write flush
 115     readln ;
 116
 117 M: chat-server handle-client-join
 118     [
 119         line-beginning username " has joined"
 120     ] "" append-outputs-as send-everyone ;
 121
 122 M: chat-server handle-client-disconnect
 123     [
 124         line-beginning username " has quit  "
 125         client object>> dup [ "\"" dup surround ] when
 126     ] "" append-outputs-as send-everyone ;
 127
 128 M: chat-server handle-already-logged-in
 129     username username-taken-string send-line
 130     t client (>>quit?) ;
 131
 132 M: chat-server handle-managed-client*
 133     readln dup f = [ t client (>>quit?) ] when
 134     [
 135         "/" ?head [ handle-command ] [ handle-chat ] if
 136     ] unless-empty ;