Merge branch 'master' of git://factorcode.org/git/factor
commit
0091558ff6
|
@ -13,9 +13,8 @@ SYMBOL: local-node
|
|||
[ first2 get-process send ] [ stop-this-server ] if* ;
|
||||
|
||||
: <node-server> ( addrspec -- threaded-server )
|
||||
<threaded-server>
|
||||
binary <threaded-server>
|
||||
swap >>insecure
|
||||
binary >>encoding
|
||||
"concurrency.distributed" >>name
|
||||
[ handle-node-client ] >>handler ;
|
||||
|
||||
|
|
|
@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- )
|
|||
] with-destructors ;
|
||||
|
||||
: <ftp-server> ( directory port -- server )
|
||||
ftp-server new-threaded-server
|
||||
latin1 ftp-server new-threaded-server
|
||||
swap >>insecure
|
||||
swap canonicalize-path >>serving-directory
|
||||
"ftp.server" >>name
|
||||
5 minutes >>timeout
|
||||
latin1 >>encoding ;
|
||||
5 minutes >>timeout ;
|
||||
|
||||
: ftpd ( directory port -- )
|
||||
<ftp-server> start-server ;
|
||||
|
|
|
@ -269,7 +269,7 @@ M: http-server handle-client*
|
|||
] with-destructors ;
|
||||
|
||||
: <http-server> ( -- server )
|
||||
http-server new-threaded-server
|
||||
ascii http-server new-threaded-server
|
||||
"http.server" >>name
|
||||
"http" protocol-port >>insecure
|
||||
"https" protocol-port >>secure ;
|
||||
|
|
|
@ -79,12 +79,12 @@ HELP: threaded-server
|
|||
{ $class-description "The class of threaded servers. New instances are created with " { $link <threaded-server> } ". This class may be subclassed, and instances of subclasses should be created with " { $link new-threaded-server } ". See " { $link "server-config" } " for slot documentation." } ;
|
||||
|
||||
HELP: new-threaded-server
|
||||
{ $values { "class" class } { "threaded-server" threaded-server } }
|
||||
{ $values { "encoding" "an encoding descriptor" } { "class" class } { "threaded-server" threaded-server } }
|
||||
{ $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ;
|
||||
|
||||
HELP: <threaded-server>
|
||||
{ $values { "threaded-server" threaded-server } }
|
||||
{ $description "Creates a new threaded server. Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
|
||||
{ $values { "encoding" "an encoding descriptor" } { "threaded-server" threaded-server } }
|
||||
{ $description "Creates a new threaded server with streams encoded " { $snippet "encoding" } ". Its slots should be filled in as per " { $link "server-config" } ", before " { $link start-server } " is called to begin waiting for connections." } ;
|
||||
|
||||
HELP: remote-address
|
||||
{ $var-description "Variable holding the address specifier of the current client connection. See " { $link "network-addressing" } "." } ;
|
||||
|
|
|
@ -3,10 +3,10 @@ USING: tools.test io.servers.connection io.sockets namespaces
|
|||
io.servers.connection.private kernel accessors sequences
|
||||
concurrency.promises io.encodings.ascii io threads calendar ;
|
||||
|
||||
[ t ] [ <threaded-server> listen-on empty? ] unit-test
|
||||
[ t ] [ ascii <threaded-server> listen-on empty? ] unit-test
|
||||
|
||||
[ f ] [
|
||||
<threaded-server>
|
||||
ascii <threaded-server>
|
||||
25 internet-server >>insecure
|
||||
listen-on
|
||||
empty?
|
||||
|
@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ;
|
|||
and
|
||||
] unit-test
|
||||
|
||||
[ ] [ <threaded-server> init-server drop ] unit-test
|
||||
[ ] [ ascii <threaded-server> init-server drop ] unit-test
|
||||
|
||||
[ 10 ] [
|
||||
<threaded-server>
|
||||
ascii <threaded-server>
|
||||
10 >>max-connections
|
||||
init-server semaphore>> count>>
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
<threaded-server>
|
||||
ascii <threaded-server>
|
||||
5 >>max-connections
|
||||
0 >>insecure
|
||||
[ "Hello world." write stop-this-server ] >>handler
|
||||
|
|
|
@ -27,18 +27,18 @@ ready ;
|
|||
|
||||
: internet-server ( port -- addrspec ) f swap <inet> ;
|
||||
|
||||
: new-threaded-server ( class -- threaded-server )
|
||||
: new-threaded-server ( encoding class -- threaded-server )
|
||||
new
|
||||
swap >>encoding
|
||||
"server" >>name
|
||||
DEBUG >>log-level
|
||||
ascii >>encoding
|
||||
1 minutes >>timeout
|
||||
V{ } clone >>sockets
|
||||
<secure-config> >>secure-config
|
||||
[ "No handler quotation" throw ] >>handler
|
||||
<flag> >>ready ; inline
|
||||
|
||||
: <threaded-server> ( -- threaded-server )
|
||||
: <threaded-server> ( encoding -- threaded-server )
|
||||
threaded-server new-threaded-server ;
|
||||
|
||||
GENERIC: handle-client* ( threaded-server -- )
|
||||
|
|
|
@ -11,9 +11,8 @@ IN: fuel.remote
|
|||
[ [ print-error-and-restarts ] error-hook set listener ] with-scope ;
|
||||
|
||||
: server ( port -- server )
|
||||
<threaded-server>
|
||||
utf8 <threaded-server>
|
||||
"tty-server" >>name
|
||||
utf8 >>encoding
|
||||
swap local-server >>insecure
|
||||
[ start-listener ] >>handler
|
||||
f >>timeout ;
|
||||
|
|
|
@ -4,7 +4,8 @@ USING: accessors assocs combinators combinators.smart
|
|||
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 ;
|
||||
locals multiline io.encodings.binary io.encodings.string
|
||||
prettyprint ;
|
||||
IN: managed-server.chat
|
||||
|
||||
TUPLE: chat-server < managed-server ;
|
||||
|
@ -35,6 +36,31 @@ CONSTANT: line-beginning "-!- "
|
|||
[ "Unknown command: " prepend print flush ] if
|
||||
] if-empty ;
|
||||
|
||||
: usage ( string -- )
|
||||
chat-docs get at print flush ;
|
||||
|
||||
: username-taken-string ( username -- string )
|
||||
"The username ``" "'' is already in use; try again." surround ;
|
||||
|
||||
: warn-name-changed ( old new -- )
|
||||
[
|
||||
[ line-beginning "``" ] 2dip
|
||||
[ "'' is now known as ``" ] dip "''"
|
||||
] "" append-outputs-as send-everyone ;
|
||||
|
||||
: handle-nick ( string -- )
|
||||
[
|
||||
"nick" usage
|
||||
] [
|
||||
dup clients key? [
|
||||
username-taken-string print flush
|
||||
] [
|
||||
[ username swap warn-name-changed ]
|
||||
[ username clients rename-at ]
|
||||
[ client (>>username) ] tri
|
||||
] if
|
||||
] if-empty ;
|
||||
|
||||
:: add-command ( quot docs key -- )
|
||||
quot key commands get set-at
|
||||
docs key chat-docs get set-at ;
|
||||
|
@ -44,7 +70,7 @@ CONSTANT: line-beginning "-!- "
|
|||
Displays the documentation for a command.">
|
||||
"help" add-command
|
||||
|
||||
[ drop clients keys ", " join print flush ]
|
||||
[ drop clients keys [ "``" "''" surround ] map ", " join print flush ]
|
||||
<" Syntax: /who
|
||||
Shows the list of connected users.">
|
||||
"who" add-command
|
||||
|
@ -53,6 +79,11 @@ Shows the list of connected users.">
|
|||
<" Syntax: /time
|
||||
Returns the current GMT time."> "time" add-command
|
||||
|
||||
[ handle-nick ]
|
||||
<" Syntax: /nick nickname
|
||||
Changes your nickname.">
|
||||
"nick" add-command
|
||||
|
||||
[ handle-me ]
|
||||
<" Syntax: /me action">
|
||||
"me" add-command
|
||||
|
@ -69,8 +100,7 @@ Disconnects a user from the chat server."> "quit" add-command
|
|||
] if ;
|
||||
|
||||
: <chat-server> ( port -- managed-server )
|
||||
"chat-server" chat-server new-managed-server
|
||||
utf8 >>encoding ;
|
||||
"chat-server" utf8 chat-server new-managed-server ;
|
||||
|
||||
: handle-chat ( string -- )
|
||||
[
|
||||
|
@ -93,8 +123,7 @@ M: chat-server handle-client-disconnect
|
|||
] "" append-outputs-as send-everyone ;
|
||||
|
||||
M: chat-server handle-already-logged-in
|
||||
"The username ``" username "'' is already in use; try again."
|
||||
3append print flush ;
|
||||
username username-taken-string print flush ;
|
||||
|
||||
M: chat-server handle-managed-client*
|
||||
readln dup f = [ t client (>>quit?) ] when
|
||||
|
|
|
@ -14,28 +14,43 @@ input-stream output-stream local-address remote-address
|
|||
username object quit? ;
|
||||
|
||||
HOOK: handle-login threaded-server ( -- username )
|
||||
HOOK: handle-managed-client* managed-server ( -- )
|
||||
HOOK: handle-already-logged-in managed-server ( -- )
|
||||
HOOK: handle-client-join managed-server ( -- )
|
||||
HOOK: handle-client-disconnect managed-server ( -- )
|
||||
HOOK: handle-managed-client* managed-server ( -- )
|
||||
|
||||
M: managed-server handle-already-logged-in ;
|
||||
ERROR: already-logged-in username ;
|
||||
|
||||
M: managed-server handle-already-logged-in already-logged-in ;
|
||||
M: managed-server handle-client-join ;
|
||||
M: managed-server handle-client-disconnect ;
|
||||
M: managed-server handle-managed-client* ;
|
||||
|
||||
: server ( -- managed-client ) managed-server get ;
|
||||
: client ( -- managed-client ) managed-client get ;
|
||||
: clients ( -- assoc ) server clients>> ;
|
||||
: client-streams ( -- assoc ) clients values ;
|
||||
: username ( -- string ) client username>> ;
|
||||
: everyone-else ( -- assoc )
|
||||
clients [ drop username = not ] assoc-filter ;
|
||||
: everyone-else-streams ( -- assoc ) everyone-else values ;
|
||||
|
||||
ERROR: no-such-client username ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (send-client) ( managed-client seq -- )
|
||||
[ output-stream>> ] dip '[ _ print flush ] with-output-stream* ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: send-client ( seq username -- )
|
||||
clients ?at [ no-such-client ] [ (send-client) ] if ;
|
||||
|
||||
: send-everyone ( seq -- )
|
||||
[ client-streams ] dip '[
|
||||
output-stream>> [ _ print flush ] with-output-stream*
|
||||
] each ;
|
||||
[ client-streams ] dip '[ _ (send-client) ] each ;
|
||||
|
||||
ERROR: already-logged-in username ;
|
||||
: send-everyone-else ( seq -- )
|
||||
[ everyone-else-streams ] dip '[ _ (send-client) ] each ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
@ -48,10 +63,7 @@ ERROR: already-logged-in username ;
|
|||
remote-address get >>remote-address ;
|
||||
|
||||
: check-logged-in ( username -- username )
|
||||
dup server clients>> key? [
|
||||
[ server ] dip
|
||||
[ handle-already-logged-in ] [ already-logged-in ] bi
|
||||
] when ;
|
||||
dup clients key? [ handle-already-logged-in ] when ;
|
||||
|
||||
: add-managed-client ( -- )
|
||||
client username check-logged-in clients set-at ;
|
||||
|
@ -60,19 +72,19 @@ ERROR: already-logged-in username ;
|
|||
username server clients>> delete-at ;
|
||||
|
||||
: handle-managed-client ( -- )
|
||||
[ [ handle-managed-client* client quit?>> not ] loop ]
|
||||
[ delete-managed-client handle-client-disconnect ]
|
||||
[ ] cleanup ;
|
||||
handle-login <managed-client> managed-client set
|
||||
add-managed-client handle-client-join
|
||||
[ handle-managed-client* client quit?>> not ] loop ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: managed-server handle-client*
|
||||
managed-server set
|
||||
handle-login <managed-client> managed-client set
|
||||
add-managed-client
|
||||
handle-client-join handle-managed-client ;
|
||||
[ handle-managed-client ]
|
||||
[ delete-managed-client handle-client-disconnect ]
|
||||
[ ] cleanup ;
|
||||
|
||||
: new-managed-server ( port name class -- server )
|
||||
: new-managed-server ( port name encoding class -- server )
|
||||
new-threaded-server
|
||||
swap >>name
|
||||
swap >>insecure
|
||||
|
|
|
@ -89,9 +89,8 @@ M: mdb-msg dump-message ( message -- )
|
|||
|
||||
: start-mmm-server ( -- )
|
||||
output-stream get mmm-dump-output set
|
||||
<threaded-server> [ mmm-t-srv set ] keep
|
||||
binary <threaded-server> [ mmm-t-srv set ] keep
|
||||
"127.0.0.1" mmm-port get <inet4> >>insecure
|
||||
binary >>encoding
|
||||
[ handle-mmm-connection ] >>handler
|
||||
start-server* ;
|
||||
|
||||
|
@ -99,4 +98,4 @@ M: mdb-msg dump-message ( message -- )
|
|||
check-options
|
||||
start-mmm-server ;
|
||||
|
||||
MAIN: run-mmm
|
||||
MAIN: run-mmm
|
||||
|
|
|
@ -1,14 +1,14 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io io.servers.connection accessors threads
|
||||
calendar calendar.format ;
|
||||
USING: accessors calendar calendar.format io io.encodings.ascii
|
||||
io.servers.connection threads ;
|
||||
IN: time-server
|
||||
|
||||
: handle-time-client ( -- )
|
||||
now timestamp>rfc822 print ;
|
||||
|
||||
: <time-server> ( -- threaded-server )
|
||||
<threaded-server>
|
||||
ascii <threaded-server>
|
||||
"time-server" >>name
|
||||
1234 >>insecure
|
||||
[ handle-time-client ] >>handler ;
|
||||
|
|
|
@ -3,9 +3,8 @@ accessors kernel ;
|
|||
IN: tty-server
|
||||
|
||||
: <tty-server> ( port -- )
|
||||
<threaded-server>
|
||||
utf8 <threaded-server>
|
||||
"tty-server" >>name
|
||||
utf8 >>encoding
|
||||
swap local-server >>insecure
|
||||
[ listener ] >>handler
|
||||
start-server ;
|
||||
|
|
|
@ -2,36 +2,44 @@ USING: accessors assocs continuations effects io
|
|||
io.encodings.binary io.servers.connection kernel
|
||||
memoize namespaces parser sets sequences serialize
|
||||
threads vocabs vocabs.parser words ;
|
||||
|
||||
IN: modules.rpc-server
|
||||
|
||||
SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
|
||||
|
||||
: do-rpc ( args word -- bytes )
|
||||
[ execute ] curry with-datastack object>bytes ; inline
|
||||
[ execute ] curry with-datastack object>bytes ; inline
|
||||
|
||||
MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
|
||||
|
||||
: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
|
||||
swap at "executer" get execute( args word -- bytes ) write flush ;
|
||||
: process ( vocabspec -- )
|
||||
vocab-words [ deserialize ] dip deserialize
|
||||
swap at "executer" get execute( args word -- bytes ) write flush ;
|
||||
|
||||
: (serve) ( -- ) deserialize dup serving-vocabs get-global index
|
||||
[ process ] [ drop ] if ;
|
||||
: (serve) ( -- )
|
||||
deserialize dup serving-vocabs get-global index
|
||||
[ process ] [ drop ] if ;
|
||||
|
||||
: start-serving-vocabs ( -- ) [
|
||||
<threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
|
||||
start-server ] in-thread ;
|
||||
: start-serving-vocabs ( -- )
|
||||
[
|
||||
binary <threaded-server>
|
||||
5000 >>insecure
|
||||
[ (serve) ] >>handler
|
||||
start-server
|
||||
] in-thread ;
|
||||
|
||||
: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
|
||||
current-vocab serving-vocabs get-global adjoin
|
||||
"get-words" create-in
|
||||
in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
|
||||
(( -- words )) define-inline ;
|
||||
: (service) ( -- )
|
||||
serving-vocabs get-global empty? [ start-serving-vocabs ] when
|
||||
current-vocab serving-vocabs get-global adjoin
|
||||
"get-words" create-in
|
||||
in get [ vocab vocab-words [ stack-effect ] { } assoc-map-as ] curry
|
||||
(( -- words )) define-inline ;
|
||||
|
||||
SYNTAX: service \ do-rpc "executer" set (service) ;
|
||||
SYNTAX: mem-service \ mem-do-rpc "executer" set (service) ;
|
||||
|
||||
load-vocab-hook [
|
||||
[ dup words>> values
|
||||
\ mem-do-rpc "memoize" word-prop [ delete-at ] curry each ]
|
||||
append ] change-global
|
||||
[
|
||||
dup words>> values
|
||||
\ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
|
||||
] append
|
||||
] change-global
|
||||
|
|
Loading…
Reference in New Issue