Fix a problem with disconnects, add a lot of features to chat server, lots of refactoring of managed-server
Doug Coleman
parent
12e301cdea
commit
d39f0659b6
|
|
@ -1,23 +1,21 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators combinators.smart
|
||||
destructors fry io kernel managed-server namespaces
|
||||
sequences splitting unicode.case ;
|
||||
destructors fry io io.encodings.utf8 kernel managed-server
|
||||
namespaces parser sequences sorting splitting strings.parser
|
||||
unicode.case unicode.categories calendar calendar.format
|
||||
locals multiline ;
|
||||
IN: managed-server.chat
|
||||
|
||||
CONSTANT: line-beginning "-!- "
|
||||
|
||||
TUPLE: chat-server < managed-server ;
|
||||
|
||||
: <chat-server> ( port -- managed-server )
|
||||
"chat-server" chat-server new-managed-server ;
|
||||
SYMBOL: commands
|
||||
commands [ H{ } clone ] initialize
|
||||
|
||||
: unknown-command ( string -- )
|
||||
"Unknown command: " prepend print-client ;
|
||||
SYMBOL: chat-docs
|
||||
chat-docs [ H{ } clone ] initialize
|
||||
|
||||
: handle-who ( string -- )
|
||||
drop
|
||||
clients keys ", " join print flush ;
|
||||
CONSTANT: line-beginning "-!- "
|
||||
|
||||
: handle-me ( string -- )
|
||||
[
|
||||
|
|
@ -25,21 +23,64 @@ TUPLE: chat-server < managed-server ;
|
|||
] "" append-outputs-as send-everyone ;
|
||||
|
||||
: handle-quit ( string -- )
|
||||
client [ (>>object) ] [ output-stream>> dispose ] bi ;
|
||||
client [ (>>object) ] [ t >>quit? drop ] bi ;
|
||||
|
||||
: handle-help ( string -- )
|
||||
[
|
||||
"Commands: "
|
||||
commands get keys natural-sort ", " join append print flush
|
||||
] [
|
||||
chat-docs get ?at
|
||||
[ print flush ]
|
||||
[ "Unknown command: " prepend print flush ] if
|
||||
] if-empty ;
|
||||
|
||||
:: add-command ( quot docs key -- )
|
||||
quot key commands get set-at
|
||||
docs key chat-docs get set-at ;
|
||||
|
||||
[ handle-help ]
|
||||
<" Syntax: /help [command]
|
||||
Displays the documentation for a command.">
|
||||
"help" add-command
|
||||
|
||||
[ drop clients keys ", " join print flush ]
|
||||
<" Syntax: /who
|
||||
Shows the list of connected users.">
|
||||
"who" add-command
|
||||
|
||||
[ drop gmt timestamp>rfc822 print flush ]
|
||||
<" Syntax: /time
|
||||
Returns the current GMT time."> "time" add-command
|
||||
|
||||
[ handle-me ]
|
||||
<" Syntax: /me action">
|
||||
"me" add-command
|
||||
|
||||
[ handle-quit ]
|
||||
<" Syntax: /quit [message]
|
||||
Disconnects a user from the chat server."> "quit" add-command
|
||||
|
||||
: handle-command ( string -- )
|
||||
" " split1 swap >lower {
|
||||
{ "who" [ handle-who ] }
|
||||
{ "me" [ handle-me ] }
|
||||
{ "quit" [ handle-quit ] }
|
||||
[ " " glue unknown-command ]
|
||||
} case ;
|
||||
dup " " split1 swap >lower commands get at* [
|
||||
call( string -- ) drop
|
||||
] [
|
||||
2drop "Unknown command: " prepend print flush
|
||||
] if ;
|
||||
|
||||
: <chat-server> ( port -- managed-server )
|
||||
"chat-server" chat-server new-managed-server
|
||||
utf8 >>encoding ;
|
||||
|
||||
: handle-chat ( string -- )
|
||||
[
|
||||
[ username ": " ] dip
|
||||
] "" append-outputs-as send-everyone ;
|
||||
|
||||
M: chat-server handle-login
|
||||
"Username: " write flush
|
||||
readln ;
|
||||
|
||||
M: chat-server handle-client-join
|
||||
[
|
||||
line-beginning username " has joined"
|
||||
|
|
@ -56,6 +97,7 @@ M: chat-server handle-already-logged-in
|
|||
3append print flush ;
|
||||
|
||||
M: chat-server handle-managed-client*
|
||||
readln [
|
||||
readln dup f = [ t client (>>quit?) ] when
|
||||
[
|
||||
"/" ?head [ handle-command ] [ handle-chat ] if
|
||||
] unless-empty ;
|
||||
|
|
|
|||
|
|
@ -11,9 +11,9 @@ TUPLE: managed-server < threaded-server clients ;
|
|||
|
||||
TUPLE: managed-client
|
||||
input-stream output-stream local-address remote-address
|
||||
username object ;
|
||||
username object quit? ;
|
||||
|
||||
HOOK: login threaded-server ( -- username )
|
||||
HOOK: handle-login threaded-server ( -- username )
|
||||
HOOK: handle-already-logged-in managed-server ( -- )
|
||||
HOOK: handle-client-join managed-server ( -- )
|
||||
HOOK: handle-client-disconnect managed-server ( -- )
|
||||
|
|
@ -31,16 +31,11 @@ M: managed-server handle-managed-client* ;
|
|||
: username ( -- string ) client username>> ;
|
||||
|
||||
: send-everyone ( seq -- )
|
||||
client-streams swap '[
|
||||
[ client-streams ] dip '[
|
||||
output-stream>> [ _ print flush ] with-output-stream*
|
||||
] each ;
|
||||
|
||||
: print-client ( string -- )
|
||||
client output-stream>>
|
||||
[ stream-print ] [ stream-flush ] bi ;
|
||||
|
||||
ERROR: already-logged-in username ;
|
||||
ERROR: normal-quit ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -65,17 +60,15 @@ ERROR: normal-quit ;
|
|||
username server clients>> delete-at ;
|
||||
|
||||
: handle-managed-client ( -- )
|
||||
[ [ handle-managed-client* t ] loop ]
|
||||
[ [ handle-managed-client* client quit?>> not ] loop ]
|
||||
[ delete-managed-client handle-client-disconnect ]
|
||||
[ ] cleanup ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: managed-server login readln ;
|
||||
|
||||
M: managed-server handle-client*
|
||||
managed-server set
|
||||
login <managed-client> managed-client set
|
||||
handle-login <managed-client> managed-client set
|
||||
add-managed-client
|
||||
handle-client-join handle-managed-client ;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue