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