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