From 0a436e1184a2c6e56315ac8efb4e1937d6e4aad4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 17 Jun 2008 00:04:18 -0500 Subject: [PATCH] New threaded-server --- extra/io/server/server-docs.factor | 10 -- extra/io/server/server-tests.factor | 7 - extra/io/server/server.factor | 76 ---------- extra/io/server/summary.txt | 1 - .../connection}/authors.txt | 0 .../servers/connection/connection-docs.factor | 2 + .../connection/connection-tests.factor | 47 +++++++ extra/io/servers/connection/connection.factor | 131 ++++++++++++++++++ extra/io/servers/connection/summary.txt | 1 + .../{server => servers/connection}/tags.txt | 0 extra/io/servers/packet/authors.txt | 1 + extra/io/servers/packet/datagram.factor | 21 +++ extra/io/servers/packet/summary.txt | 1 + extra/io/servers/packet/tags.txt | 1 + extra/io/sockets/secure/secure-tests.factor | 5 +- extra/io/sockets/secure/secure.factor | 13 +- extra/io/sockets/sockets-docs.factor | 20 +-- extra/io/sockets/sockets-tests.factor | 2 +- extra/io/sockets/sockets.factor | 27 ++-- 19 files changed, 245 insertions(+), 121 deletions(-) delete mode 100755 extra/io/server/server-docs.factor delete mode 100755 extra/io/server/server-tests.factor delete mode 100755 extra/io/server/server.factor delete mode 100644 extra/io/server/summary.txt rename extra/io/{server => servers/connection}/authors.txt (100%) mode change 100755 => 100644 create mode 100755 extra/io/servers/connection/connection-docs.factor create mode 100755 extra/io/servers/connection/connection-tests.factor create mode 100755 extra/io/servers/connection/connection.factor create mode 100644 extra/io/servers/connection/summary.txt rename extra/io/{server => servers/connection}/tags.txt (100%) create mode 100755 extra/io/servers/packet/authors.txt create mode 100644 extra/io/servers/packet/datagram.factor create mode 100644 extra/io/servers/packet/summary.txt create mode 100644 extra/io/servers/packet/tags.txt diff --git a/extra/io/server/server-docs.factor b/extra/io/server/server-docs.factor deleted file mode 100755 index 50f38cb146..0000000000 --- a/extra/io/server/server-docs.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: help help.syntax help.markup io ; -IN: io.server - -HELP: with-server -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "encoding" "an encoding to use for client connections" } { "quot" "a quotation" } } -{ $description "Starts a TCP/IP server. The quotation is called in a new thread for each client connection, with the client connection being both the " { $link input-stream } " and " { $link output-stream } "." } ; - -HELP: with-datagrams -{ $values { "seq" "a sequence of address specifiers" } { "service" "a string or " { $link f } } { "quot" "a quotation" } } -{ $description "Starts a UDP/IP server. The quotation is called for each datagram packet received." } ; diff --git a/extra/io/server/server-tests.factor b/extra/io/server/server-tests.factor deleted file mode 100755 index 965a70718b..0000000000 --- a/extra/io/server/server-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -IN: io.server.tests -USING: tools.test io.server io.server.private kernel ; - -{ 2 0 } [ [ ] server-loop ] must-infer-as -{ 3 0 } [ [ ] with-connection ] must-infer-as -{ 1 0 } [ [ ] swap datagram-loop ] must-infer-as -{ 2 0 } [ [ ] with-datagrams ] must-infer-as diff --git a/extra/io/server/server.factor b/extra/io/server/server.factor deleted file mode 100755 index e975880a14..0000000000 --- a/extra/io/server/server.factor +++ /dev/null @@ -1,76 +0,0 @@ -! Copyright (C) 2003, 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: io io.sockets io.sockets.secure io.files -io.streams.duplex logging continuations destructors kernel math -math.parser namespaces parser sequences strings prettyprint -debugger quotations calendar threads concurrency.combinators -assocs fry accessors arrays ; -IN: io.server - -SYMBOL: servers - -SYMBOL: remote-address - -> ] bi ] dip - '[ , , , , with-connection ] "Client" spawn drop - ] 2keep accept-loop ; inline - -: server-loop ( addrspec encoding quot -- ) - >r dup servers get push r> - '[ , accept-loop ] with-disposal ; inline - -\ server-loop NOTICE add-error-logging - -PRIVATE> - -: local-server ( port -- seq ) - "localhost" swap t resolve-host ; - -: internet-server ( port -- seq ) - f swap t resolve-host ; - -: secure-server ( port -- seq ) - internet-server [ ] map ; - -: with-server ( seq service encoding quot -- ) - V{ } clone servers [ - '[ , [ , , server-loop ] with-logging ] parallel-each - ] with-variable ; inline - -: stop-server ( -- ) - servers get dispose-each ; - - [ datagram-loop ] with-disposal ; inline - -\ spawn-datagrams NOTICE add-input-logging - -PRIVATE> - -: with-datagrams ( seq service quot -- ) - '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/server/summary.txt b/extra/io/server/summary.txt deleted file mode 100644 index e791b704eb..0000000000 --- a/extra/io/server/summary.txt +++ /dev/null @@ -1 +0,0 @@ -TCP/IP and UDP/IP servers diff --git a/extra/io/server/authors.txt b/extra/io/servers/connection/authors.txt old mode 100755 new mode 100644 similarity index 100% rename from extra/io/server/authors.txt rename to extra/io/servers/connection/authors.txt diff --git a/extra/io/servers/connection/connection-docs.factor b/extra/io/servers/connection/connection-docs.factor new file mode 100755 index 0000000000..b033ec287c --- /dev/null +++ b/extra/io/servers/connection/connection-docs.factor @@ -0,0 +1,2 @@ +USING: help help.syntax help.markup io ; +IN: io.servers.connection diff --git a/extra/io/servers/connection/connection-tests.factor b/extra/io/servers/connection/connection-tests.factor new file mode 100755 index 0000000000..bb87d67917 --- /dev/null +++ b/extra/io/servers/connection/connection-tests.factor @@ -0,0 +1,47 @@ +IN: io.servers.connection +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 + +[ f ] [ + + 25 internet-server >>insecure + listen-on + empty? +] unit-test + +[ t ] [ + T{ inet4 "1.2.3.4" 1234 } T{ inet4 "1.2.3.5" 1235 } + [ log-connection ] 2keep + [ remote-address get = ] [ local-address get = ] bi* + and +] unit-test + +[ ] [ init-server drop ] unit-test + +[ 10 ] [ + + 10 >>max-connections + init-server semaphore>> count>> +] unit-test + +[ ] [ "p" set ] unit-test + +[ ] [ + [ + + 5 >>max-connections + 1237 >>insecure + [ "Hello world." write stop-server ] >>handler + start-server + t "p" get fulfill + ] in-thread +] unit-test + +[ ] [ 100 sleep ] unit-test + +[ "Hello world." ] [ "localhost" 1237 ascii drop contents ] unit-test + +[ t ] [ "p" get 2 seconds ?promise-timeout ] unit-test diff --git a/extra/io/servers/connection/connection.factor b/extra/io/servers/connection/connection.factor new file mode 100755 index 0000000000..f01112a70f --- /dev/null +++ b/extra/io/servers/connection/connection.factor @@ -0,0 +1,131 @@ +! Copyright (C) 2003, 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations destructors kernel math math.parser +namespaces parser sequences strings prettyprint debugger +quotations combinators combinators.lib logging calendar assocs +fry accessors arrays io io.sockets io.encodings.ascii +io.sockets.secure io.files io.streams.duplex io.timeouts +io.encodings threads concurrency.combinators +concurrency.semaphores ; +IN: io.servers.connection + +TUPLE: threaded-server +name +secure insecure +secure-config +sockets +max-connections +semaphore +timeout +encoding +handler ; + +: local-server ( port -- addrspec ) "localhost" swap ; + +: internet-server ( port -- addrspec ) f swap ; + +: new-threaded-server ( class -- threaded-server ) + new + "server" >>name + ascii >>encoding + 1 minutes >>timeout + V{ } clone >>sockets + >>secure-config + [ "No handler quotation" throw ] >>handler ; inline + +: ( -- threaded-server ) + threaded-server new-threaded-server ; + +SYMBOL: remote-address + +GENERIC: handle-client* ( server -- ) + +insecure ( addrspec -- addrspec' ) + dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ; + +: >secure ( addrspec -- addrspec' ) + >insecure + dup { [ secure? ] [ not ] } 1|| [ ] unless ; + +: listen-on ( threaded-server -- addrspecs ) + [ secure>> >secure ] [ insecure>> >insecure ] bi + [ resolve-host ] bi@ append ; + +LOG: accepted-connection NOTICE + +: log-connection ( remote local -- ) + [ [ remote-address set ] [ local-address set ] bi* ] + [ 2array accepted-connection ] + 2bi ; + +M: threaded-server handle-client* handler>> call ; + +: handle-client ( client remote local -- ) + '[ + , , log-connection + threaded-server get + [ timeout>> timeouts ] [ handle-client* ] bi + ] with-stream ; + +: thread-name ( server-name addrspec -- string ) + unparse " connection from " swap 3append ; + +: accept-connection ( server -- ) + [ accept ] [ addr>> ] bi + [ '[ , , , handle-client ] ] + [ drop threaded-server get name>> swap thread-name ] 2bi + spawn drop ; + +: accept-loop ( server -- ) + [ + threaded-server get semaphore>> + [ [ accept-connection ] with-semaphore ] + [ accept-connection ] + if* + ] [ accept-loop ] bi ; inline + +\ accept-loop ERROR add-error-logging + +: start-accept-loop ( server -- ) + threaded-server get encoding>> + [ threaded-server get sockets>> push ] + [ [ accept-loop ] with-disposal ] + bi ; + +: init-server ( threaded-server -- threaded-server ) + dup semaphore>> [ + dup max-connections>> [ + >>semaphore + ] when* + ] unless ; + +PRIVATE> + +: start-server ( threaded-server -- ) + init-server + dup secure-config>> [ + dup threaded-server [ + dup name>> [ + listen-on [ + start-accept-loop + ] parallel-each + ] with-logging + ] with-variable + ] with-secure-context ; + +: stop-server ( -- ) + threaded-server get [ f ] change-sockets drop dispose-each ; + +GENERIC: port ( addrspec -- n ) + +M: integer port ; + +M: object port port>> ; + +: secure-port ( -- n ) + threaded-server get dup [ secure>> port ] when ; + +: insecure-port ( -- n ) + threaded-server get dup [ insecure>> port ] when ; diff --git a/extra/io/servers/connection/summary.txt b/extra/io/servers/connection/summary.txt new file mode 100644 index 0000000000..8269ecfc38 --- /dev/null +++ b/extra/io/servers/connection/summary.txt @@ -0,0 +1 @@ +Multi-threaded TCP/IP servers diff --git a/extra/io/server/tags.txt b/extra/io/servers/connection/tags.txt similarity index 100% rename from extra/io/server/tags.txt rename to extra/io/servers/connection/tags.txt diff --git a/extra/io/servers/packet/authors.txt b/extra/io/servers/packet/authors.txt new file mode 100755 index 0000000000..1901f27a24 --- /dev/null +++ b/extra/io/servers/packet/authors.txt @@ -0,0 +1 @@ +Slava Pestov diff --git a/extra/io/servers/packet/datagram.factor b/extra/io/servers/packet/datagram.factor new file mode 100644 index 0000000000..03596ee43c --- /dev/null +++ b/extra/io/servers/packet/datagram.factor @@ -0,0 +1,21 @@ +IN: io.servers.datagram + + [ datagram-loop ] with-disposal ; inline + +\ spawn-datagrams NOTICE add-input-logging + +PRIVATE> + +: with-datagrams ( seq service quot -- ) + '[ [ , _ spawn-datagrams ] parallel-each ] with-logging ; inline diff --git a/extra/io/servers/packet/summary.txt b/extra/io/servers/packet/summary.txt new file mode 100644 index 0000000000..29247a2937 --- /dev/null +++ b/extra/io/servers/packet/summary.txt @@ -0,0 +1 @@ +Multi-threaded UDP/IP servers diff --git a/extra/io/servers/packet/tags.txt b/extra/io/servers/packet/tags.txt new file mode 100644 index 0000000000..992ae12982 --- /dev/null +++ b/extra/io/servers/packet/tags.txt @@ -0,0 +1 @@ +network diff --git a/extra/io/sockets/secure/secure-tests.factor b/extra/io/sockets/secure/secure-tests.factor index 9b9436a8db..75ac39e190 100644 --- a/extra/io/sockets/secure/secure-tests.factor +++ b/extra/io/sockets/secure/secure-tests.factor @@ -1 +1,4 @@ -! No unit tests here, until Windows SSL is implemented +IN: io.sockets.secure.tests +USING: io.sockets.secure tools.test ; + +[ "hello" 24 ] [ "hello" 24 [ host>> ] [ port>> ] bi ] unit-test diff --git a/extra/io/sockets/secure/secure.factor b/extra/io/sockets/secure/secure.factor index 448a5cdda0..10aec22ee5 100644 --- a/extra/io/sockets/secure/secure.factor +++ b/extra/io/sockets/secure/secure.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel symbols namespaces continuations -destructors io.sockets sequences inspector calendar ; +destructors io.sockets sequences inspector calendar delegate ; IN: io.sockets.secure SYMBOL: secure-socket-timeout @@ -42,8 +42,10 @@ TUPLE: secure addrspec ; C: secure -: resolve-secure-host ( host port passive? -- seq ) - resolve-host [ ] map ; +CONSULT: inet secure addrspec>> ; + +M: secure resolve-host ( secure -- seq ) + addrspec>> resolve-host [ ] map ; HOOK: check-certificate secure-socket-backend ( host handle -- ) @@ -53,9 +55,8 @@ PREDICATE: secure-inet < secure addrspec>> inet? ; M: secure-inet (client) [ - addrspec>> - [ [ host>> ] [ port>> ] bi f resolve-secure-host (client) >r |dispose r> ] keep - host>> pick handle>> check-certificate + [ resolve-host (client) [ |dispose ] dip ] keep + addrspec>> host>> pick handle>> check-certificate ] with-destructors ; PRIVATE> diff --git a/extra/io/sockets/sockets-docs.factor b/extra/io/sockets/sockets-docs.factor index 78cddd5d3b..6aa46ccdbc 100755 --- a/extra/io/sockets/sockets-docs.factor +++ b/extra/io/sockets/sockets-docs.factor @@ -27,7 +27,7 @@ $nl { { $link inet4 } " - a TCP/IP connection to an IPv4 address and port number; no name lookup is performed" } { { $link inet6 } " - a TCP/IP connection to an IPv6 address and port number; no name lookup is performed" } } -"The " { $vocab-link "io.server" } " library defines a nice high-level wrapper around " { $link } " which makes it easy to listen for IPv4 and IPv6 connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." +"The " { $vocab-link "io.servers.connection" } " library defines high-level wrappers around " { $link } " which makes it easy to listen for IPv4, IPv6 and secure socket connections simultaneously, perform logging, and optionally only allow connections from the loopback interface." { $see-also "io.sockets.secure" } ; ARTICLE: "network-packet" "Packet-oriented networking" @@ -79,7 +79,7 @@ HELP: inet HELP: inet4 { $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes -"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." +"Most applications do not operate on IPv4 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name. Also, try to support IPv6 where possible." } { $examples { $code "\"127.0.0.1\" 8080 " } @@ -88,7 +88,7 @@ HELP: inet4 HELP: inet6 { $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link } "." } { $notes -"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." } +"Most applications do not operate on IPv6 addresses directly, and instead should use " { $link resolve-host } " to look up the address associated to a host name." } { $examples { $code "\"::1\" 8080 " } } ; @@ -118,10 +118,10 @@ HELP: } { $notes "To start a TCP/IP server which listens for connections from any host, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "f 1234 t resolve-host" } + { $code "f 1234 resolve-host" } "To start a server which listens for connections from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "\"localhost\" 1234 t resolve-host" } - "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.server" } " vocabulary can be used to help with this." + { $code "\"localhost\" 1234 resolve-host" } + "Since " { $link resolve-host } " can return multiple address specifiers, your server code must listen on them all to work properly. The " { $vocab-link "io.servers.connection" } " vocabulary can be used to help with this." $nl "To start a TCP/IP server which listens for connections on a randomly-assigned port, set the port number in the address specifier to 0, and then read the " { $snippet "addr" } " slot of the server instance to obtain the actual port number it is listening on:" { $unchecked-example @@ -148,9 +148,9 @@ HELP: } { $notes "To accept UDP/IP packets from any host, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "f 1234 t resolve-host" } + { $code "f 1234 resolve-host" } "To accept UDP/IP packets from the loopback interface only, use an address specifier returned by the following code, where 1234 is the desired port number:" - { $code "\"localhost\" 1234 t resolve-host" } + { $code "\"localhost\" 1234 resolve-host" } "Since " { $link resolve-host } " can return multiple address specifiers, your code must create a datagram socket for each one and co-ordinate packet sending accordingly." "Datagrams are low-level binary ports that don't map onto streams, so the constructor does not use an encoding" } @@ -165,3 +165,7 @@ HELP: send { $values { "packet" byte-array } { "addrspec" "an address specifier" } { "datagram" "a datagram socket" } } { $description "Sends a packet to the given address." } { $errors "Throws an error if the packet could not be sent." } ; + +HELP: resolve-host +{ $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } } +{ $description "Resolves host names to IP addresses." } ; diff --git a/extra/io/sockets/sockets-tests.factor b/extra/io/sockets/sockets-tests.factor index 8264bec032..4b95a31512 100755 --- a/extra/io/sockets/sockets-tests.factor +++ b/extra/io/sockets/sockets-tests.factor @@ -45,7 +45,7 @@ concurrency.promises threads io.streams.string ; [ "1:2:0:0:0:0:3:4" ] [ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } T{ inet6 } inet-ntop ] unit-test -[ t ] [ "localhost" 80 f resolve-host length 1 >= ] unit-test +[ t ] [ "localhost" 80 resolve-host length 1 >= ] unit-test ! Smoke-test UDP [ ] [ "127.0.0.1" 0 "datagram1" set ] unit-test diff --git a/extra/io/sockets/sockets.factor b/extra/io/sockets/sockets.factor index 4efd30c65e..a9278c8357 100755 --- a/extra/io/sockets/sockets.factor +++ b/extra/io/sockets/sockets.factor @@ -259,20 +259,26 @@ HOOK: (send) io-backend ( packet addrspec datagram -- ) [ addrinfo>addrspec ] map sift ; -: prepare-resolve-host ( host serv passive? -- host' serv' flags ) +: prepare-resolve-host ( addrspec -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then #! change it later. This is a workaround for a FreeBSD #! getaddrinfo() limitation -- on Windows, Linux and Mac, #! we can convert a number to a string and pass that as the #! service name, but on FreeBSD this gives us an unknown #! service error. - >r - dup integer? [ port-override set "http" ] when - r> AI_PASSIVE 0 ? ; + [ host>> ] + [ port>> dup integer? [ port-override set "http" ] when ] bi + over 0 AI_PASSIVE ? ; HOOK: addrinfo-error io-backend ( n -- ) -: resolve-host ( host serv passive? -- seq ) +GENERIC: resolve-host ( addrspec -- seq ) + +TUPLE: inet host port ; + +C: inet + +M: inet resolve-host [ prepare-resolve-host "addrinfo" @@ -284,17 +290,16 @@ HOOK: addrinfo-error io-backend ( n -- ) freeaddrinfo ] with-scope ; +M: f resolve-host drop { } ; + +M: object resolve-host 1array ; + : host-name ( -- string ) 256 dup dup length gethostname zero? [ "gethostname failed" throw ] unless ascii alien>string ; -TUPLE: inet host port ; - -C: inet - -M: inet (client) - [ host>> ] [ port>> ] bi f resolve-host (client) ; +M: inet (client) resolve-host (client) ; ERROR: invalid-inet-server addrspec ;