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..0e8a8576fb 100644 --- a/basis/io/servers/connection/connection-docs.factor +++ b/basis/io/servers/connection/connection-docs.factor @@ -79,12 +79,12 @@ 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: -{ $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 723814bb13..8835e3d8a6 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 @@ -69,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 -- ) [ @@ -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 diff --git a/extra/managed-server/managed-server.factor b/extra/managed-server/managed-server.factor index 4d7ede84dc..4d4a440525 100644 --- a/extra/managed-server/managed-server.factor +++ b/extra/managed-server/managed-server.factor @@ -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 ; + +> ] 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 ; >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 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-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 ; 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