From ba826791687d48e00f744c128afd9fcd2023c985 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 13:38:40 -0500 Subject: [PATCH 1/7] add a few utility words to managed-server --- extra/managed-server/managed-server.factor | 22 +++++++++++++++++++--- 1 file changed, 19 insertions(+), 3 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 4d7ede84dc..ac4e275c9e 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -29,11 +29,27 @@ M: managed-server handle-managed-client* ; : 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 ; + +> '[ _ 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 ; + +: send-everyone-else ( seq -- ) + [ everyone-else-streams ] dip '[ _ (send-client) ] each ; ERROR: already-logged-in username ; From ecc2924eb67a17e7587f0fc8b2fcdef2470d7c20 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 13:51:03 -0500 Subject: [PATCH 2/7] fix a word in managed-server --- extra/managed-server/managed-server.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index ac4e275c9e..7d75976ea5 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -37,8 +37,8 @@ ERROR: no-such-client username ; > '[ _ print flush ] with-output-stream* ; +: (send-client) ( managed-client seq -- ) + [ output-stream>> ] dip '[ _ print flush ] with-output-stream* ; PRIVATE> From 77654ce7bd12e1a003583510b19aa159f15ebc27 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 15:50:08 -0500 Subject: [PATCH 3/7] fix error handling in managed-server --- extra/managed-server/managed-server.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 7d75976ea5..8fc06ddf2a 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -14,15 +14,14 @@ 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 ; 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 ; @@ -76,17 +75,17 @@ 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 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 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-threaded-server From 4b2dab10a0e11e46508151fb7f5e3e12e83d56f8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 16:50:38 -0400 Subject: [PATCH 4/7] refactor a bit of the chat server, add /nick --- extra/managed-server/chat/chat.factor | 38 ++++++++++++++++++++++++--- 1 file changed, 34 insertions(+), 4 deletions(-) diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index 723814bb13..e1331f360b 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -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 @@ -93,8 +124,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 From 50e6fac0138a1d995c07a5baa3cc7c161426125e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 19:15:53 -0500 Subject: [PATCH 5/7] change threaded-server and managed-server to take an encoding --- basis/concurrency/distributed/distributed.factor | 3 +-- basis/ftp/server/server.factor | 5 ++--- basis/http/server/server.factor | 2 +- basis/io/servers/connection/connection-docs.factor | 4 ++-- basis/io/servers/connection/connection-tests.factor | 10 +++++----- basis/io/servers/connection/connection.factor | 6 +++--- extra/fuel/remote/remote.factor | 3 +-- extra/managed-server/chat/chat.factor | 3 +-- extra/managed-server/managed-server.factor | 13 +++++-------- extra/mongodb/mmm/mmm.factor | 5 ++--- extra/time-server/time-server.factor | 6 +++--- extra/tty-server/tty-server.factor | 3 +-- 12 files changed, 27 insertions(+), 36 deletions(-) diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor index ca1c5762f6..52627f2ed9 100644 --- a/basis/concurrency/distributed/distributed.factor +++ b/basis/concurrency/distributed/distributed.factor @@ -13,9 +13,8 @@ SYMBOL: local-node [ first2 get-process send ] [ stop-this-server ] if* ; : ( addrspec -- threaded-server ) - + binary swap >>insecure - binary >>encoding "concurrency.distributed" >>name [ handle-node-client ] >>handler ; diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor index 8438aae94e..c9518bdef1 100644 --- a/basis/ftp/server/server.factor +++ b/basis/ftp/server/server.factor @@ -341,12 +341,11 @@ M: ftp-server handle-client* ( server -- ) ] with-destructors ; : ( 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 -- ) start-server ; diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index c838471e3f..8682c97c73 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -269,7 +269,7 @@ M: http-server handle-client* ] with-destructors ; : ( -- server ) - http-server new-threaded-server + ascii http-server new-threaded-server "http.server" >>name "http" protocol-port >>insecure "https" protocol-port >>secure ; diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 67c7cb13dd..872f3166c2 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -83,8 +83,8 @@ HELP: new-threaded-server { $description "Creates a new instance of a subclass of " { $link threaded-server } ". Subclasses can implement the " { $link handle-client* } " generic word." } ; HELP: -{ $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" } "." } ; diff --git a/basis/io/servers/connection/connection-tests.factor b/basis/io/servers/connection/connection-tests.factor index ab99531eb4..14100d3f04 100644 --- a/basis/io/servers/connection/connection-tests.factor +++ b/basis/io/servers/connection/connection-tests.factor @@ -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 ] [ listen-on empty? ] unit-test +[ t ] [ ascii listen-on empty? ] unit-test [ f ] [ - + ascii 25 internet-server >>insecure listen-on empty? @@ -19,16 +19,16 @@ concurrency.promises io.encodings.ascii io threads calendar ; and ] unit-test -[ ] [ init-server drop ] unit-test +[ ] [ ascii init-server drop ] unit-test [ 10 ] [ - + ascii 10 >>max-connections init-server semaphore>> count>> ] unit-test [ ] [ - + ascii 5 >>max-connections 0 >>insecure [ "Hello world." write stop-this-server ] >>handler diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index 8eafe1b5bf..df6c21e7cc 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -27,18 +27,18 @@ ready ; : internet-server ( port -- addrspec ) f swap ; -: 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 [ "No handler quotation" throw ] >>handler >>ready ; inline -: ( -- threaded-server ) +: ( encoding -- threaded-server ) threaded-server new-threaded-server ; GENERIC: handle-client* ( threaded-server -- ) diff --git a/extra/fuel/remote/remote.factor b/extra/fuel/remote/remote.factor index d13aff800a..d3b48efac6 100644 --- a/extra/fuel/remote/remote.factor +++ b/extra/fuel/remote/remote.factor @@ -11,9 +11,8 @@ IN: fuel.remote [ [ print-error-and-restarts ] error-hook set listener ] with-scope ; : server ( port -- server ) - + utf8 "tty-server" >>name - utf8 >>encoding swap local-server >>insecure [ start-listener ] >>handler f >>timeout ; diff --git a/extra/managed-server/chat/chat.factor b/extra/managed-server/chat/chat.factor index e1331f360b..8835e3d8a6 100644 --- a/extra/managed-server/chat/chat.factor +++ b/extra/managed-server/chat/chat.factor @@ -100,8 +100,7 @@ Disconnects a user from the chat server."> "quit" add-command ] if ; : ( port -- managed-server ) - "chat-server" chat-server new-managed-server - utf8 >>encoding ; + "chat-server" utf8 chat-server new-managed-server ; : handle-chat ( string -- ) [ diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 8fc06ddf2a..4d4a440525 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -19,7 +19,9 @@ HOOK: handle-already-logged-in managed-server ( -- ) HOOK: handle-client-join managed-server ( -- ) HOOK: handle-client-disconnect 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 ; @@ -50,8 +52,6 @@ PRIVATE> : send-everyone-else ( seq -- ) [ everyone-else-streams ] dip '[ _ (send-client) ] each ; -ERROR: already-logged-in username ; - ( username -- managed-client ) @@ -63,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 ; @@ -87,7 +84,7 @@ M: managed-server handle-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 diff --git a/extra/mongodb/mmm/mmm.factor b/extra/mongodb/mmm/mmm.factor index 25c4c88203..8e56143664 100644 --- a/extra/mongodb/mmm/mmm.factor +++ b/extra/mongodb/mmm/mmm.factor @@ -89,9 +89,8 @@ M: mdb-msg dump-message ( message -- ) : start-mmm-server ( -- ) output-stream get mmm-dump-output set - [ mmm-t-srv set ] keep + binary [ mmm-t-srv set ] keep "127.0.0.1" mmm-port get >>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 \ No newline at end of file +MAIN: run-mmm diff --git a/extra/time-server/time-server.factor b/extra/time-server/time-server.factor index 28debf17cd..500f0276d7 100644 --- a/extra/time-server/time-server.factor +++ b/extra/time-server/time-server.factor @@ -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 ; : ( -- threaded-server ) - + ascii "time-server" >>name 1234 >>insecure [ handle-time-client ] >>handler ; diff --git a/extra/tty-server/tty-server.factor b/extra/tty-server/tty-server.factor index 4ba38ad06a..0c7395f7f0 100644 --- a/extra/tty-server/tty-server.factor +++ b/extra/tty-server/tty-server.factor @@ -3,9 +3,8 @@ accessors kernel ; IN: tty-server : ( port -- ) - + utf8 "tty-server" >>name - utf8 >>encoding swap local-server >>insecure [ listener ] >>handler start-server ; From 10dd61d81f611fc72b829c5e025dfc1d114c62d0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 19:16:23 -0500 Subject: [PATCH 6/7] clean up formatting of rpc-server in unmaintained --- .../modules/rpc-server/rpc-server.factor | 42 +++++++++++-------- 1 file changed, 25 insertions(+), 17 deletions(-) diff --git a/unmaintained/modules/rpc-server/rpc-server.factor b/unmaintained/modules/rpc-server/rpc-server.factor index 525ff35a09..0c881adef6 100644 --- a/unmaintained/modules/rpc-server/rpc-server.factor +++ b/unmaintained/modules/rpc-server/rpc-server.factor @@ -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 ( -- ) [ - 5000 >>insecure binary >>encoding [ (serve) ] >>handler - start-server ] in-thread ; +: start-serving-vocabs ( -- ) + [ + binary + 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 \ No newline at end of file + [ + dup words>> values + \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each + ] append +] change-global From 802283c94c2cfbcfcb963d3b54b197e10a83f8ce Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 30 May 2009 19:24:11 -0500 Subject: [PATCH 7/7] fix help for new-threaded-server --- basis/io/servers/connection/connection-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/io/servers/connection/connection-docs.factor b/basis/io/servers/connection/connection-docs.factor index 872f3166c2..0e8a8576fb 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -79,7 +79,7 @@ HELP: threaded-server { $class-description "The class of threaded servers. New instances are created with " { $link } ". 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: