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