Squashed commit of the following:

commit 8a15381d30508b8f36a9e36dc3a0afc3c962c853
Author: Doug Coleman <doug.coleman@gmail.com>
Date:   Sat Sep 11 14:32:30 2010 -0500

    Squash threaded-server branch
db4
Doug Coleman 2010-09-19 13:38:02 -05:00
parent 4a018ebdfc
commit aa8c12a84b
22 changed files with 223 additions and 124 deletions

View File

@ -5,7 +5,7 @@ HELP: local-node
{ $var-description "A variable containing the node the current thread is running on." } ;
HELP: start-node
{ $values { "port" "a port number between 0 and 65535" } }
{ $values { "port" "a port number between 0 and 65535" } { "threaded-server" "a threaded-server tuple" } }
{ $description "Starts a node server for receiving messages from remote Factor instances." } ;
ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example"

View File

@ -13,7 +13,7 @@ IN: concurrency.distributed.tests
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
[ ] [ test-node dup (start-node) ] unit-test
[ ] [ test-node dup (start-node) drop ] unit-test
[ ] [
[

View File

@ -34,10 +34,10 @@ SYMBOL: local-node
"concurrency.distributed" >>name
[ handle-node-client ] >>handler ;
: (start-node) ( addrspec addrspec -- )
local-node set-global <node-server> start-server* ;
: (start-node) ( addrspec addrspec -- threaded-server )
local-node set-global <node-server> start-server ;
: start-node ( port -- )
: start-node ( port -- threaded-server )
host-name over <inet> (start-node) ;
TUPLE: remote-thread node id ;

View File

@ -1,12 +1,12 @@
USING: calendar ftp.server io.encodings.ascii io.files
io.files.unique namespaces threads tools.test kernel
io.servers.connection ftp.client accessors urls
io.pathnames io.directories sequences fry io.backend ;
io.pathnames io.directories sequences fry io.backend
continuations ;
FROM: ftp.client => ftp-get ;
IN: ftp.server.tests
: test-file-contents ( -- string )
"Files are so boring anymore." ;
CONSTANT: test-file-contents "Files are so boring anymore."
: create-test-file ( -- path )
test-file-contents
@ -15,28 +15,24 @@ IN: ftp.server.tests
: test-ftp-server ( quot -- )
'[
current-temporary-directory get 0
<ftp-server>
[ start-server* ]
[
sockets>> first addr>> port>>
current-temporary-directory get
0 <ftp-server> [
insecure-port
<url>
swap >>port
"ftp" >>protocol
"localhost" >>host
create-test-file >>path
@
]
[ stop-server ] tri
] with-unique-directory drop ; inline
] with-threaded-server
] cleanup-unique-directory ; inline
[ t ]
[
[
unique-directory [
[
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
] with-directory
] cleanup-unique-working-directory
] test-ftp-server test-file-contents =
] unit-test
@ -44,8 +40,8 @@ IN: ftp.server.tests
[
"/" >>path
unique-directory [
[
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
] with-directory
] cleanup-unique-working-directory
] test-ftp-server test-file-contents =
] must-fail

View File

@ -365,7 +365,7 @@ M: ftp-server handle-client* ( server -- )
"ftp.server" >>name
5 minutes >>timeout ;
: ftpd ( directory port -- )
: ftpd ( directory port -- server )
<ftp-server> start-server ;
! sudo tcpdump -i en1 -A -s 10000 tcp port 21

View File

@ -231,7 +231,7 @@ test-db [
<http-server>
0 >>insecure
f >>secure
dup start-server*
start-server
sockets>> first addr>> port>>
] with-scope "port" set ;

View File

@ -46,7 +46,7 @@ HELP: <http-server>
{ $description "Creates a new HTTP server with default parameters." } ;
HELP: httpd
{ $values { "port" integer } }
{ $values { "port" integer } { "http-server" http-server } }
{ $description "Starts an HTTP server on the specified port number." }
{ $notes "For more flexibility, use " { $link <http-server> } " and fill in the tuple slots before calling " { $link start-server } "." } ;

View File

@ -298,7 +298,7 @@ M: http-server handle-client*
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
: httpd ( port -- )
: httpd ( port -- http-server )
<http-server>
swap >>insecure
f >>secure

View File

@ -1,9 +1,9 @@
USING: calendar classes concurrency.semaphores help.markup
help.syntax io io.sockets io.sockets.secure math quotations ;
IN: io.servers.connection
USING: help help.syntax help.markup io io.sockets
io.sockets.secure concurrency.semaphores calendar classes math ;
ARTICLE: "server-config" "Threaded server configuration"
"The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } " or " { $link start-server* } "."
"The " { $link threaded-server } " tuple has a variety of slots which can be set before starting the server with " { $link start-server } "."
{ $subsections
"server-config-logging"
"server-config-listen"
@ -66,13 +66,13 @@ ARTICLE: "io.servers.connection" "Threaded servers"
"The server must be configured before it can be started."
{ $subsections "server-config" }
"Starting the server:"
{ $subsections
start-server
start-server*
wait-for-server
}
{ $subsections start-server }
"Stopping the server:"
{ $subsections stop-server }
"Waiting for the server to stop:"
{ $subsections wait-for-server }
"Combinator for running a server:"
{ $subsections with-threaded-server }
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
{ $subsections
stop-this-server
@ -105,30 +105,32 @@ HELP: handle-client*
HELP: start-server
{ $values { "threaded-server" threaded-server } }
{ $description "Starts a threaded server." }
{ $description "Starts a threaded server and returns after the server is fully running. Throws an error if any of the ports cannot be aquired." }
{ $notes "Use " { $link stop-server } " or " { $link stop-this-server } " to stop the server." } ;
HELP: wait-for-server
{ $values { "threaded-server" threaded-server } }
{ $description "Waits for a threaded server to begin accepting connections." } ;
HELP: start-server*
{ $values { "threaded-server" threaded-server } }
{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ;
HELP: stop-server
{ $values { "threaded-server" threaded-server } }
{ $description "Stops a threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
{ $description "Stops a threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ;
HELP: wait-for-server
{ $values { "threaded-server" threaded-server } }
{ $description "Waits for a threaded server to stop serving new connections." } ;
HELP: stop-this-server
{ $description "Stops the current threaded server, preventing it from accepting any more connections and returning to the caller of " { $link start-server } ". All client connections which have already been opened continue to be serviced." } ;
{ $description "Stops the current threaded server, preventing it from accepting any more connections. All client connections which have already been opened continue to be serviced." } ;
HELP: with-threaded-server
{ $values
{ "threaded-server" threaded-server } { "quot" quotation }
}
{ $description "Runs a server and calls a quotation, stopping the server once the quotation returns." } ;
HELP: secure-port
{ $values { "n" { $maybe integer } } }
{ $description "Outputs the port number on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
{ $description "Outputs one of the port numbers on which the current threaded server accepts secure socket connections. Outputs " { $link f } " if the current threaded server does not accept secure socket connections." }
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
HELP: insecure-port
{ $values { "n" { $maybe integer } } }
{ $description "Outputs the port number on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
{ $description "Outputs one of the port numbers on which the current threaded server accepts ordinary socket connections. Outputs " { $link f } " if the current threaded server does not accept ordinary socket connections." }
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;

View File

@ -1,7 +1,8 @@
USING: accessors calendar concurrency.promises fry io
io.encodings.ascii io.servers.connection
io.servers.connection.private io.sockets kernel namespaces
sequences threads tools.test ;
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 ] [ ascii <threaded-server> listen-on empty? ] unit-test
@ -27,12 +28,19 @@ concurrency.promises io.encodings.ascii io threads calendar ;
init-server semaphore>> count>>
] unit-test
[ ] [
[ "Hello world." ] [
ascii <threaded-server>
5 >>max-connections
0 >>insecure
[ "Hello world." write stop-this-server ] >>handler
dup start-server* sockets>> first addr>> port>> "port" set
[
"localhost" insecure-port <inet> ascii <client> drop stream-contents
] with-threaded-server
] unit-test
[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test
[ ] [
ascii <threaded-server>
5 >>max-connections
0 >>insecure
start-server [ '[ _ wait-for-server ] in-thread ] [ stop-server ] bi
] unit-test

View File

@ -1,28 +1,53 @@
! Copyright (C) 2003, 2009 Slava Pestov.
! Copyright (C) 2003, 2010 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: continuations destructors kernel math math.parser
namespaces parser sequences strings prettyprint
quotations combinators logging calendar assocs present
fry accessors arrays io io.sockets io.encodings.ascii
io.sockets.secure io.files io.streams.duplex io.timeouts
io.encodings threads make concurrency.combinators
concurrency.semaphores concurrency.flags
combinators.short-circuit ;
USING: accessors arrays calendar combinators
combinators.short-circuit concurrency.combinators
concurrency.count-downs concurrency.flags
concurrency.semaphores continuations debugger destructors fry
io io.sockets io.sockets.secure io.streams.duplex io.styles
io.timeouts kernel logging make math math.parser namespaces
present prettyprint random sequences sets strings threads ;
FROM: namespaces => set ;
IN: io.servers.connection
TUPLE: threaded-server
TUPLE: threaded-server < identity-tuple
name
log-level
secure
insecure
secure-config
sockets
servers
max-connections
semaphore
timeout
encoding
handler
ready ;
server-stopped ;
SYMBOL: running-servers
running-servers [ HS{ } clone ] initialize
ERROR: server-already-running threaded-server ;
ERROR: server-not-running threaded-server ;
<PRIVATE
: must-be-running ( threaded-server -- threaded-server )
dup running-servers get in? [ server-not-running ] unless ;
: must-not-be-running ( threaded-server -- threaded-server )
dup running-servers get in? [ server-already-running ] when ;
: add-running-server ( threaded-server -- )
must-not-be-running
running-servers get adjoin ;
: remove-running-server ( threaded-server -- )
must-be-running
running-servers get delete ;
PRIVATE>
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
@ -33,10 +58,8 @@ ready ;
"server" >>name
DEBUG >>log-level
<secure-config> >>secure-config
V{ } clone >>sockets
1 minutes >>timeout
[ "No handler quotation" throw ] >>handler
<flag> >>ready
swap >>encoding ;
: <threaded-server> ( encoding -- threaded-server )
@ -46,16 +69,25 @@ GENERIC: handle-client* ( threaded-server -- )
<PRIVATE
: >insecure ( addrspec -- addrspec' )
dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
GENERIC: (>insecure) ( obj -- obj )
M: inet (>insecure) ;
M: local (>insecure) ;
M: integer (>insecure) internet-server ;
M: string (>insecure) internet-server ;
M: array (>insecure) [ (>insecure) ] map ;
M: f (>insecure) ;
: >insecure ( obj -- seq )
(>insecure) dup sequence? [ 1array ] unless ;
: >secure ( addrspec -- addrspec' )
>insecure
dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
[ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ] map ;
: listen-on ( threaded-server -- addrspecs )
[ secure>> >secure ] [ insecure>> >insecure ] bi
[ dup [ resolve-host ] when ] bi@ append ;
[ secure>> >secure ] [ insecure>> >insecure ] bi append
[ resolve-host ] map concat ;
: accepted-connection ( remote local -- )
[
@ -81,57 +113,72 @@ M: threaded-server handle-client* handler>> call( -- ) ;
\ handle-client NOTICE add-error-logging
: thread-name ( server-name addrspec -- string )
: client-thread-name ( addrspec -- string )
[ threaded-server get name>> ] dip
unparse-short " connection from " glue ;
: accept-connection ( threaded-server -- )
: (accept-connection) ( server -- )
[ accept ] [ addr>> ] bi
[ '[ _ _ _ handle-client ] ]
[ drop threaded-server get name>> swap thread-name ] 2bi
[ drop client-thread-name ] 2bi
spawn drop ;
: accept-loop ( threaded-server -- )
[
threaded-server get semaphore>>
[ [ accept-connection ] with-semaphore ]
[ accept-connection ]
if*
] [ accept-loop ] bi ;
: accept-connection ( server -- )
threaded-server get semaphore>>
[ [ (accept-connection) ] with-semaphore ]
[ (accept-connection) ]
if* ;
: started-accept-loop ( threaded-server -- )
threaded-server get
[ sockets>> push ] [ ready>> raise-flag ] bi ;
: accept-loop ( server -- )
[ accept-connection ] [ accept-loop ] bi ;
: start-accept-loop ( addrspec -- )
threaded-server get encoding>> <server>
[ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
: start-accept-loop ( server -- ) accept-loop ;
\ start-accept-loop NOTICE add-error-logging
: init-server ( threaded-server -- threaded-server )
<flag> >>server-stopped
dup semaphore>> [
dup max-connections>> [
<semaphore> >>semaphore
] when*
] unless ;
ERROR: no-ports-configured threaded-server ;
: (make-servers) ( theaded-server addrspecs -- servers )
swap encoding>>
'[ [ _ <server> |dispose ] map ] with-destructors ;
: set-servers ( threaded-server -- threaded-server )
dup dup listen-on [ no-ports-configured ] [ (make-servers) ] if-empty
>>servers ;
: server-thread-name ( threaded-server addrspec -- string )
[ name>> ] [ addr>> present ] bi* " server on " glue ;
: (start-server) ( threaded-server -- )
init-server
dup threaded-server [
[ ] [ name>> ] bi [
[ listen-on [ start-accept-loop ] parallel-each ]
[ ready>> raise-flag ]
bi
[ ] [ name>> ] bi
[
set-servers
dup add-running-server
dup servers>>
[
[ nip '[ _ [ start-accept-loop ] with-disposal ] ]
[ server-thread-name ] 2bi spawn drop
] with each
] with-logging
] with-variable ;
PRIVATE>
: start-server ( threaded-server -- )
: start-server ( threaded-server -- threaded-server )
#! Only create a secure-context if we want to listen on
#! a secure port, otherwise start-server won't work at
#! all if SSL is not available.
dup secure>> [
dup dup secure>> [
dup secure-config>> [
(start-server)
] with-secure-context
@ -139,28 +186,53 @@ PRIVATE>
(start-server)
] if ;
: wait-for-server ( threaded-server -- )
ready>> wait-for-flag ;
: start-server* ( threaded-server -- )
[ [ start-server ] curry "Threaded server" spawn drop ]
[ wait-for-server ]
bi ;
: server-running? ( threaded-server -- ? )
server-stopped>> [ value>> not ] [ f ] if* ;
: stop-server ( threaded-server -- )
[ f ] change-sockets drop dispose-each ;
dup server-running? [
[ [ f ] change-servers drop dispose-each ]
[ remove-running-server ]
[ server-stopped>> raise-flag ] tri
] [
drop
] if ;
: stop-this-server ( -- )
threaded-server get stop-server ;
GENERIC: port ( addrspec -- n )
: wait-for-server ( threaded-server -- )
server-stopped>> wait-for-flag ;
M: integer port ;
: with-threaded-server ( threaded-server quot -- )
over
'[
[ _ start-server threaded-server _ with-variable ]
[ _ stop-server ]
[ ] cleanup
] call ; inline
M: object port port>> ;
<PRIVATE
: secure-port ( -- n )
threaded-server get dup [ secure>> port ] when ;
: first-port ( quot -- n/f )
[ threaded-server get servers>> ] dip
filter [ f ] [ first addr>> port>> ] if-empty ; inline
: insecure-port ( -- n )
threaded-server get dup [ insecure>> port ] when ;
PRIVATE>
: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
: server. ( threaded-server -- )
[ [ "=== " write name>> ] [ ] bi write-object nl ]
[ servers>> [ addr>> present print ] each ] bi ;
: all-servers ( -- sequence )
running-servers get-global members ;
: servers. ( -- )
all-servers [ server. ] each ;
: stop-all-servers ( -- )
all-servers [ stop-server ] each ;

View File

@ -1,8 +1,10 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.ascii io.files io.files.unique kernel
mime.multipart tools.test io.streams.duplex io multiline
assocs accessors ;
USING: accessors assocs continuations fry http.server io
io.encodings.ascii io.files io.files.unique
io.servers.connection io.streams.duplex io.streams.string
kernel math.ranges mime.multipart multiline namespaces random
sequences strings threads tools.test ;
IN: mime.multipart.tests
: upload-separator ( -- seq )
@ -33,3 +35,22 @@ IN: mime.multipart.tests
"file1" swap at filename>> "up.txt" =
] unit-test
SYMBOL: mime-test-server
: with-test-server ( quot -- )
[
<http-server>
f >>secure
0 >>insecure
] dip with-threaded-server ; inline
: test-server-port ( -- n )
mime-test-server get insecure>> ;
: a-stream ( n -- stream )
CHAR: a <string> <string-reader> ;
[ ] [
[
] with-test-server
] unit-test

View File

@ -68,7 +68,7 @@ M: quit-responder call-responder*
<http-server>
0 >>insecure
f >>secure
dup start-server*
start-server
sockets>> first addr>> port>>
dup number>string "resource:temp/port-number" ascii set-file-contents
] with-scope

View File

@ -24,7 +24,7 @@ IN: fuel.remote
PRIVATE>
: fuel-start-remote-listener ( port/f -- )
print-banner integer? [ 9000 ] unless* server start-server ;
print-banner integer? [ 9000 ] unless* server start-server drop ;
: fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors calendar calendar.format io io.encodings.ascii
io.servers.connection threads ;
io.servers.connection kernel threads ;
IN: time-server
: handle-time-client ( -- )
@ -14,6 +14,6 @@ IN: time-server
[ handle-time-client ] >>handler ;
: start-time-server ( -- )
<time-server> start-server ;
<time-server> start-server drop ;
MAIN: start-time-server

View File

@ -7,7 +7,7 @@ IN: tty-server
"tty-server" >>name
swap local-server >>insecure
[ listener ] >>handler
start-server ;
start-server drop ;
: tty-server ( -- ) 9999 <tty-server> ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: furnace furnace.actions furnace.redirection
http.server.dispatchers html.forms validators urls accessors
math ;
math kernel ;
IN: webapps.calculator
TUPLE: calculator < dispatcher ;
@ -39,6 +39,6 @@ USING: db.sqlite furnace.alloy namespaces http.server ;
<calculator>
calculator-db <alloy>
main-responder set-global
8080 httpd ;
8080 httpd drop ;
MAIN: run-calculator

View File

@ -38,6 +38,6 @@ USING: db.sqlite furnace.alloy namespaces ;
<counter-app>
counter-db <alloy>
main-responder set-global
8080 httpd ;
8080 httpd drop ;
MAIN: run-counter

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors furnace.actions http.server
http.server.dispatchers html.forms io.sockets
namespaces prettyprint ;
namespaces prettyprint kernel ;
IN: webapps.ip
TUPLE: ip-app < dispatcher ;
@ -18,6 +18,6 @@ TUPLE: ip-app < dispatcher ;
: run-ip-app ( -- )
<ip-app> main-responder set-global
8080 httpd ;
8080 httpd drop ;
MAIN: run-ip-app

View File

@ -90,4 +90,4 @@ M: site-watcher-app init-user-profile
: start-site-watcher ( -- )
init-db
site-watcher-db run-site-watcher
<site-watcher-server> start-server ;
<site-watcher-server> start-server drop ;

View File

@ -162,6 +162,6 @@ io.sockets.secure ;
: run-todo ( -- )
<todo-app> main-responder set-global
todo-db start-expiring
<todo-website-server> start-server ;
<todo-website-server> start-server drop ;
MAIN: run-todo

View File

@ -125,7 +125,7 @@ SYMBOL: dh-file
8080 >>insecure
8431 >>secure ;
: start-website ( -- )
: start-website ( -- server )
test-db start-expiring
test-db start-update-task
http-insomniac