Merge branch 'master' of git://factorcode.org/git/factor

basis/concurrency/distributed/distributed.factor

@@ -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 ;
 

basis/ftp/server/server.factor

@@ -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
+        5 minutes >>timeout ;
-        latin1 >>encoding ;
 
 : ftpd ( directory port -- )
     <ftp-server> start-server ;

basis/http/server/server.factor

@@ -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 ;

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 <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 } }
+{ $values { "encoding" "an encoding descriptor" } { "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." } ;
+{ $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" } "." } ;

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 ] [ <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

basis/io/servers/connection/connection.factor

@@ -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 -- )

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 )
-    <threaded-server>
+    utf8 <threaded-server>
         "tty-server" >>name
-        utf8 >>encoding
         swap local-server >>insecure
         [ start-listener ] >>handler
         f >>timeout ;

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 ;
 
 : <chat-server> ( port -- managed-server )
-    "chat-server" chat-server new-managed-server
+    "chat-server" utf8 chat-server new-managed-server ;
-        utf8 >>encoding ;
 
 : 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."
+    username username-taken-string print flush ;
-    3append print flush ;
 
 M: chat-server handle-managed-client*
     readln dup f = [ t client (>>quit?) ] when

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 ;
+
+<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 '[
+    [ client-streams ] dip '[ _ (send-client) ] each ;
-        output-stream>> [ _ print flush ] with-output-stream*
-    ] 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? [
+    dup clients key? [ handle-already-logged-in ] when ;
-        [ server ] dip
-        [ handle-already-logged-in ] [ already-logged-in ] bi
-    ] 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 ]
+    handle-login <managed-client> managed-client set
-    [ delete-managed-client handle-client-disconnect ]
+    add-managed-client handle-client-join
-    [ ] cleanup ;
+    [ handle-managed-client* client quit?>> not ] loop ;
 
 PRIVATE>
 
 M: managed-server handle-client*
     managed-server set
-    handle-login <managed-client> managed-client set
+    [ handle-managed-client ]
-    add-managed-client
+    [ delete-managed-client handle-client-disconnect ]
-    handle-client-join handle-managed-client ;
+    [ ] cleanup ;
 
-: new-managed-server ( port name class -- server )
+: new-managed-server ( port name encoding class -- server )
     new-threaded-server
         swap >>name
         swap >>insecure

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
-    <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* ;
 

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
+USING: accessors calendar calendar.format io io.encodings.ascii
-calendar calendar.format ;
+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 ;

extra/tty-server/tty-server.factor

@@ -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 ;

unmaintained/modules/rpc-server/rpc-server.factor

@@ -2,7 +2,6 @@ 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
@@ -12,17 +11,24 @@ SYMBOL: serving-vocabs V{ } clone serving-vocabs set-global
 
 MEMO: mem-do-rpc ( args word -- bytes ) do-rpc ; inline
 
-: process ( vocabspec -- ) vocab-words [ deserialize ] dip deserialize
+: 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
+: (serve) ( -- )
+    deserialize dup serving-vocabs get-global index
     [ process ] [ drop ] if ;
 
-: start-serving-vocabs ( -- ) [
+: start-serving-vocabs ( -- )
-   <threaded-server> 5000 >>insecure binary >>encoding [ (serve) ] >>handler
+    [
-   start-server ] in-thread ;
+        binary <threaded-server>
+        5000 >>insecure
+        [ (serve) ] >>handler
+        start-server
+    ] in-thread ;
 
-: (service) ( -- ) serving-vocabs get-global empty? [ start-serving-vocabs ] when
+: (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
@@ -32,6 +38,8 @@ 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 ]
+        dup words>> values
-append ] change-global
+        \ mem-do-rpc "memoize" word-prop [ delete-at ] curry each
+    ] append
+] change-global