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 branchdb4
parent
4a018ebdfc
commit
aa8c12a84b
|
@ -5,7 +5,7 @@ HELP: local-node
|
||||||
{ $var-description "A variable containing the node the current thread is running on." } ;
|
{ $var-description "A variable containing the node the current thread is running on." } ;
|
||||||
|
|
||||||
HELP: start-node
|
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." } ;
|
{ $description "Starts a node server for receiving messages from remote Factor instances." } ;
|
||||||
|
|
||||||
ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example"
|
ARTICLE: "concurrency.distributed.example" "Distributed Concurrency Example"
|
||||||
|
|
|
@ -13,7 +13,7 @@ IN: concurrency.distributed.tests
|
||||||
|
|
||||||
[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
|
[ ] [ [ "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
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
[
|
[
|
||||||
|
|
|
@ -34,10 +34,10 @@ SYMBOL: local-node
|
||||||
"concurrency.distributed" >>name
|
"concurrency.distributed" >>name
|
||||||
[ handle-node-client ] >>handler ;
|
[ handle-node-client ] >>handler ;
|
||||||
|
|
||||||
: (start-node) ( addrspec addrspec -- )
|
: (start-node) ( addrspec addrspec -- threaded-server )
|
||||||
local-node set-global <node-server> start-server* ;
|
local-node set-global <node-server> start-server ;
|
||||||
|
|
||||||
: start-node ( port -- )
|
: start-node ( port -- threaded-server )
|
||||||
host-name over <inet> (start-node) ;
|
host-name over <inet> (start-node) ;
|
||||||
|
|
||||||
TUPLE: remote-thread node id ;
|
TUPLE: remote-thread node id ;
|
||||||
|
|
|
@ -1,12 +1,12 @@
|
||||||
USING: calendar ftp.server io.encodings.ascii io.files
|
USING: calendar ftp.server io.encodings.ascii io.files
|
||||||
io.files.unique namespaces threads tools.test kernel
|
io.files.unique namespaces threads tools.test kernel
|
||||||
io.servers.connection ftp.client accessors urls
|
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 ;
|
FROM: ftp.client => ftp-get ;
|
||||||
IN: ftp.server.tests
|
IN: ftp.server.tests
|
||||||
|
|
||||||
: test-file-contents ( -- string )
|
CONSTANT: test-file-contents "Files are so boring anymore."
|
||||||
"Files are so boring anymore." ;
|
|
||||||
|
|
||||||
: create-test-file ( -- path )
|
: create-test-file ( -- path )
|
||||||
test-file-contents
|
test-file-contents
|
||||||
|
@ -15,28 +15,24 @@ IN: ftp.server.tests
|
||||||
|
|
||||||
: test-ftp-server ( quot -- )
|
: test-ftp-server ( quot -- )
|
||||||
'[
|
'[
|
||||||
current-temporary-directory get 0
|
current-temporary-directory get
|
||||||
<ftp-server>
|
0 <ftp-server> [
|
||||||
[ start-server* ]
|
insecure-port
|
||||||
[
|
|
||||||
sockets>> first addr>> port>>
|
|
||||||
<url>
|
<url>
|
||||||
swap >>port
|
swap >>port
|
||||||
"ftp" >>protocol
|
"ftp" >>protocol
|
||||||
"localhost" >>host
|
"localhost" >>host
|
||||||
create-test-file >>path
|
create-test-file >>path
|
||||||
@
|
@
|
||||||
]
|
] with-threaded-server
|
||||||
[ stop-server ] tri
|
] cleanup-unique-directory ; inline
|
||||||
] with-unique-directory drop ; inline
|
|
||||||
|
|
||||||
[ t ]
|
[ t ]
|
||||||
[
|
[
|
||||||
|
|
||||||
[
|
[
|
||||||
unique-directory [
|
[
|
||||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||||
] with-directory
|
] cleanup-unique-working-directory
|
||||||
] test-ftp-server test-file-contents =
|
] test-ftp-server test-file-contents =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
@ -44,8 +40,8 @@ IN: ftp.server.tests
|
||||||
|
|
||||||
[
|
[
|
||||||
"/" >>path
|
"/" >>path
|
||||||
unique-directory [
|
[
|
||||||
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
[ ftp-get ] [ path>> file-name ascii file-contents ] bi
|
||||||
] with-directory
|
] cleanup-unique-working-directory
|
||||||
] test-ftp-server test-file-contents =
|
] test-ftp-server test-file-contents =
|
||||||
] must-fail
|
] must-fail
|
||||||
|
|
|
@ -365,7 +365,7 @@ M: ftp-server handle-client* ( server -- )
|
||||||
"ftp.server" >>name
|
"ftp.server" >>name
|
||||||
5 minutes >>timeout ;
|
5 minutes >>timeout ;
|
||||||
|
|
||||||
: ftpd ( directory port -- )
|
: ftpd ( directory port -- server )
|
||||||
<ftp-server> start-server ;
|
<ftp-server> start-server ;
|
||||||
|
|
||||||
! sudo tcpdump -i en1 -A -s 10000 tcp port 21
|
! sudo tcpdump -i en1 -A -s 10000 tcp port 21
|
||||||
|
|
|
@ -231,7 +231,7 @@ test-db [
|
||||||
<http-server>
|
<http-server>
|
||||||
0 >>insecure
|
0 >>insecure
|
||||||
f >>secure
|
f >>secure
|
||||||
dup start-server*
|
start-server
|
||||||
sockets>> first addr>> port>>
|
sockets>> first addr>> port>>
|
||||||
] with-scope "port" set ;
|
] with-scope "port" set ;
|
||||||
|
|
||||||
|
|
|
@ -46,7 +46,7 @@ HELP: <http-server>
|
||||||
{ $description "Creates a new HTTP server with default parameters." } ;
|
{ $description "Creates a new HTTP server with default parameters." } ;
|
||||||
|
|
||||||
HELP: httpd
|
HELP: httpd
|
||||||
{ $values { "port" integer } }
|
{ $values { "port" integer } { "http-server" http-server } }
|
||||||
{ $description "Starts an HTTP server on the specified port number." }
|
{ $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 } "." } ;
|
{ $notes "For more flexibility, use " { $link <http-server> } " and fill in the tuple slots before calling " { $link start-server } "." } ;
|
||||||
|
|
||||||
|
|
|
@ -298,7 +298,7 @@ M: http-server handle-client*
|
||||||
"http" protocol-port >>insecure
|
"http" protocol-port >>insecure
|
||||||
"https" protocol-port >>secure ;
|
"https" protocol-port >>secure ;
|
||||||
|
|
||||||
: httpd ( port -- )
|
: httpd ( port -- http-server )
|
||||||
<http-server>
|
<http-server>
|
||||||
swap >>insecure
|
swap >>insecure
|
||||||
f >>secure
|
f >>secure
|
||||||
|
|
|
@ -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
|
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"
|
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
|
{ $subsections
|
||||||
"server-config-logging"
|
"server-config-logging"
|
||||||
"server-config-listen"
|
"server-config-listen"
|
||||||
|
@ -66,13 +66,13 @@ ARTICLE: "io.servers.connection" "Threaded servers"
|
||||||
"The server must be configured before it can be started."
|
"The server must be configured before it can be started."
|
||||||
{ $subsections "server-config" }
|
{ $subsections "server-config" }
|
||||||
"Starting the server:"
|
"Starting the server:"
|
||||||
{ $subsections
|
{ $subsections start-server }
|
||||||
start-server
|
|
||||||
start-server*
|
|
||||||
wait-for-server
|
|
||||||
}
|
|
||||||
"Stopping the server:"
|
"Stopping the server:"
|
||||||
{ $subsections stop-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:"
|
"From within the dynamic scope of a client handler, several words can be used to interact with the threaded server:"
|
||||||
{ $subsections
|
{ $subsections
|
||||||
stop-this-server
|
stop-this-server
|
||||||
|
@ -105,30 +105,32 @@ HELP: handle-client*
|
||||||
|
|
||||||
HELP: start-server
|
HELP: start-server
|
||||||
{ $values { "threaded-server" threaded-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." } ;
|
{ $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
|
HELP: stop-server
|
||||||
{ $values { "threaded-server" threaded-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
|
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
|
HELP: secure-port
|
||||||
{ $values { "n" { $maybe integer } } }
|
{ $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." } ;
|
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||||
|
|
||||||
HELP: insecure-port
|
HELP: insecure-port
|
||||||
{ $values { "n" { $maybe integer } } }
|
{ $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." } ;
|
{ $notes "Can only be used from the dynamic scope of a " { $link handle-client* } " call." } ;
|
||||||
|
|
|
@ -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
|
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
|
[ 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>>
|
init-server semaphore>> count>>
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ "Hello world." ] [
|
||||||
ascii <threaded-server>
|
ascii <threaded-server>
|
||||||
5 >>max-connections
|
5 >>max-connections
|
||||||
0 >>insecure
|
0 >>insecure
|
||||||
[ "Hello world." write stop-this-server ] >>handler
|
[ "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
|
] 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
|
||||||
|
|
|
@ -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.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: continuations destructors kernel math math.parser
|
USING: accessors arrays calendar combinators
|
||||||
namespaces parser sequences strings prettyprint
|
combinators.short-circuit concurrency.combinators
|
||||||
quotations combinators logging calendar assocs present
|
concurrency.count-downs concurrency.flags
|
||||||
fry accessors arrays io io.sockets io.encodings.ascii
|
concurrency.semaphores continuations debugger destructors fry
|
||||||
io.sockets.secure io.files io.streams.duplex io.timeouts
|
io io.sockets io.sockets.secure io.streams.duplex io.styles
|
||||||
io.encodings threads make concurrency.combinators
|
io.timeouts kernel logging make math math.parser namespaces
|
||||||
concurrency.semaphores concurrency.flags
|
present prettyprint random sequences sets strings threads ;
|
||||||
combinators.short-circuit ;
|
FROM: namespaces => set ;
|
||||||
IN: io.servers.connection
|
IN: io.servers.connection
|
||||||
|
|
||||||
TUPLE: threaded-server
|
TUPLE: threaded-server < identity-tuple
|
||||||
name
|
name
|
||||||
log-level
|
log-level
|
||||||
secure
|
secure
|
||||||
insecure
|
insecure
|
||||||
secure-config
|
secure-config
|
||||||
sockets
|
servers
|
||||||
max-connections
|
max-connections
|
||||||
semaphore
|
semaphore
|
||||||
timeout
|
timeout
|
||||||
encoding
|
encoding
|
||||||
handler
|
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> ;
|
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
|
||||||
|
|
||||||
|
@ -33,10 +58,8 @@ ready ;
|
||||||
"server" >>name
|
"server" >>name
|
||||||
DEBUG >>log-level
|
DEBUG >>log-level
|
||||||
<secure-config> >>secure-config
|
<secure-config> >>secure-config
|
||||||
V{ } clone >>sockets
|
|
||||||
1 minutes >>timeout
|
1 minutes >>timeout
|
||||||
[ "No handler quotation" throw ] >>handler
|
[ "No handler quotation" throw ] >>handler
|
||||||
<flag> >>ready
|
|
||||||
swap >>encoding ;
|
swap >>encoding ;
|
||||||
|
|
||||||
: <threaded-server> ( encoding -- threaded-server )
|
: <threaded-server> ( encoding -- threaded-server )
|
||||||
|
@ -46,16 +69,25 @@ GENERIC: handle-client* ( threaded-server -- )
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
: >insecure ( addrspec -- addrspec' )
|
GENERIC: (>insecure) ( obj -- obj )
|
||||||
dup { [ integer? ] [ string? ] } 1|| [ internet-server ] when ;
|
|
||||||
|
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' )
|
: >secure ( addrspec -- addrspec' )
|
||||||
>insecure
|
>insecure
|
||||||
dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ;
|
[ dup { [ secure? ] [ not ] } 1|| [ <secure> ] unless ] map ;
|
||||||
|
|
||||||
: listen-on ( threaded-server -- addrspecs )
|
: listen-on ( threaded-server -- addrspecs )
|
||||||
[ secure>> >secure ] [ insecure>> >insecure ] bi
|
[ secure>> >secure ] [ insecure>> >insecure ] bi append
|
||||||
[ dup [ resolve-host ] when ] bi@ append ;
|
[ resolve-host ] map concat ;
|
||||||
|
|
||||||
: accepted-connection ( remote local -- )
|
: accepted-connection ( remote local -- )
|
||||||
[
|
[
|
||||||
|
@ -81,57 +113,72 @@ M: threaded-server handle-client* handler>> call( -- ) ;
|
||||||
|
|
||||||
\ handle-client NOTICE add-error-logging
|
\ 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 ;
|
unparse-short " connection from " glue ;
|
||||||
|
|
||||||
: accept-connection ( threaded-server -- )
|
: (accept-connection) ( server -- )
|
||||||
[ accept ] [ addr>> ] bi
|
[ accept ] [ addr>> ] bi
|
||||||
[ '[ _ _ _ handle-client ] ]
|
[ '[ _ _ _ handle-client ] ]
|
||||||
[ drop threaded-server get name>> swap thread-name ] 2bi
|
[ drop client-thread-name ] 2bi
|
||||||
spawn drop ;
|
spawn drop ;
|
||||||
|
|
||||||
: accept-loop ( threaded-server -- )
|
: accept-connection ( server -- )
|
||||||
[
|
threaded-server get semaphore>>
|
||||||
threaded-server get semaphore>>
|
[ [ (accept-connection) ] with-semaphore ]
|
||||||
[ [ accept-connection ] with-semaphore ]
|
[ (accept-connection) ]
|
||||||
[ accept-connection ]
|
if* ;
|
||||||
if*
|
|
||||||
] [ accept-loop ] bi ;
|
|
||||||
|
|
||||||
: started-accept-loop ( threaded-server -- )
|
: accept-loop ( server -- )
|
||||||
threaded-server get
|
[ accept-connection ] [ accept-loop ] bi ;
|
||||||
[ sockets>> push ] [ ready>> raise-flag ] bi ;
|
|
||||||
|
|
||||||
: start-accept-loop ( addrspec -- )
|
: start-accept-loop ( server -- ) accept-loop ;
|
||||||
threaded-server get encoding>> <server>
|
|
||||||
[ started-accept-loop ] [ [ accept-loop ] with-disposal ] bi ;
|
|
||||||
|
|
||||||
\ start-accept-loop NOTICE add-error-logging
|
\ start-accept-loop NOTICE add-error-logging
|
||||||
|
|
||||||
: init-server ( threaded-server -- threaded-server )
|
: init-server ( threaded-server -- threaded-server )
|
||||||
|
<flag> >>server-stopped
|
||||||
dup semaphore>> [
|
dup semaphore>> [
|
||||||
dup max-connections>> [
|
dup max-connections>> [
|
||||||
<semaphore> >>semaphore
|
<semaphore> >>semaphore
|
||||||
] when*
|
] when*
|
||||||
] unless ;
|
] 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 -- )
|
: (start-server) ( threaded-server -- )
|
||||||
init-server
|
init-server
|
||||||
dup threaded-server [
|
dup threaded-server [
|
||||||
[ ] [ name>> ] bi [
|
[ ] [ name>> ] bi
|
||||||
[ listen-on [ start-accept-loop ] parallel-each ]
|
[
|
||||||
[ ready>> raise-flag ]
|
set-servers
|
||||||
bi
|
dup add-running-server
|
||||||
|
dup servers>>
|
||||||
|
[
|
||||||
|
[ nip '[ _ [ start-accept-loop ] with-disposal ] ]
|
||||||
|
[ server-thread-name ] 2bi spawn drop
|
||||||
|
] with each
|
||||||
] with-logging
|
] with-logging
|
||||||
] with-variable ;
|
] with-variable ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: start-server ( threaded-server -- )
|
: start-server ( threaded-server -- threaded-server )
|
||||||
#! Only create a secure-context if we want to listen on
|
#! Only create a secure-context if we want to listen on
|
||||||
#! a secure port, otherwise start-server won't work at
|
#! a secure port, otherwise start-server won't work at
|
||||||
#! all if SSL is not available.
|
#! all if SSL is not available.
|
||||||
dup secure>> [
|
dup dup secure>> [
|
||||||
dup secure-config>> [
|
dup secure-config>> [
|
||||||
(start-server)
|
(start-server)
|
||||||
] with-secure-context
|
] with-secure-context
|
||||||
|
@ -139,28 +186,53 @@ PRIVATE>
|
||||||
(start-server)
|
(start-server)
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: wait-for-server ( threaded-server -- )
|
: server-running? ( threaded-server -- ? )
|
||||||
ready>> wait-for-flag ;
|
server-stopped>> [ value>> not ] [ f ] if* ;
|
||||||
|
|
||||||
: start-server* ( threaded-server -- )
|
|
||||||
[ [ start-server ] curry "Threaded server" spawn drop ]
|
|
||||||
[ wait-for-server ]
|
|
||||||
bi ;
|
|
||||||
|
|
||||||
: stop-server ( threaded-server -- )
|
: 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 ( -- )
|
: stop-this-server ( -- )
|
||||||
threaded-server get stop-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 )
|
: first-port ( quot -- n/f )
|
||||||
threaded-server get dup [ secure>> port ] when ;
|
[ threaded-server get servers>> ] dip
|
||||||
|
filter [ f ] [ first addr>> port>> ] if-empty ; inline
|
||||||
|
|
||||||
: insecure-port ( -- n )
|
PRIVATE>
|
||||||
threaded-server get dup [ insecure>> port ] when ;
|
|
||||||
|
: 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 ;
|
||||||
|
|
|
@ -1,8 +1,10 @@
|
||||||
! Copyright (C) 2009 Doug Coleman.
|
! Copyright (C) 2009 Doug Coleman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: io.encodings.ascii io.files io.files.unique kernel
|
USING: accessors assocs continuations fry http.server io
|
||||||
mime.multipart tools.test io.streams.duplex io multiline
|
io.encodings.ascii io.files io.files.unique
|
||||||
assocs accessors ;
|
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
|
IN: mime.multipart.tests
|
||||||
|
|
||||||
: upload-separator ( -- seq )
|
: upload-separator ( -- seq )
|
||||||
|
@ -33,3 +35,22 @@ IN: mime.multipart.tests
|
||||||
"file1" swap at filename>> "up.txt" =
|
"file1" swap at filename>> "up.txt" =
|
||||||
] unit-test
|
] 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
|
||||||
|
|
|
@ -68,7 +68,7 @@ M: quit-responder call-responder*
|
||||||
<http-server>
|
<http-server>
|
||||||
0 >>insecure
|
0 >>insecure
|
||||||
f >>secure
|
f >>secure
|
||||||
dup start-server*
|
start-server
|
||||||
sockets>> first addr>> port>>
|
sockets>> first addr>> port>>
|
||||||
dup number>string "resource:temp/port-number" ascii set-file-contents
|
dup number>string "resource:temp/port-number" ascii set-file-contents
|
||||||
] with-scope
|
] with-scope
|
||||||
|
|
|
@ -24,7 +24,7 @@ IN: fuel.remote
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: fuel-start-remote-listener ( port/f -- )
|
: 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 ;
|
: fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;
|
||||||
|
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors calendar calendar.format io io.encodings.ascii
|
USING: accessors calendar calendar.format io io.encodings.ascii
|
||||||
io.servers.connection threads ;
|
io.servers.connection kernel threads ;
|
||||||
IN: time-server
|
IN: time-server
|
||||||
|
|
||||||
: handle-time-client ( -- )
|
: handle-time-client ( -- )
|
||||||
|
@ -14,6 +14,6 @@ IN: time-server
|
||||||
[ handle-time-client ] >>handler ;
|
[ handle-time-client ] >>handler ;
|
||||||
|
|
||||||
: start-time-server ( -- )
|
: start-time-server ( -- )
|
||||||
<time-server> start-server ;
|
<time-server> start-server drop ;
|
||||||
|
|
||||||
MAIN: start-time-server
|
MAIN: start-time-server
|
||||||
|
|
|
@ -7,7 +7,7 @@ IN: tty-server
|
||||||
"tty-server" >>name
|
"tty-server" >>name
|
||||||
swap local-server >>insecure
|
swap local-server >>insecure
|
||||||
[ listener ] >>handler
|
[ listener ] >>handler
|
||||||
start-server ;
|
start-server drop ;
|
||||||
|
|
||||||
: tty-server ( -- ) 9999 <tty-server> ;
|
: tty-server ( -- ) 9999 <tty-server> ;
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: furnace furnace.actions furnace.redirection
|
USING: furnace furnace.actions furnace.redirection
|
||||||
http.server.dispatchers html.forms validators urls accessors
|
http.server.dispatchers html.forms validators urls accessors
|
||||||
math ;
|
math kernel ;
|
||||||
IN: webapps.calculator
|
IN: webapps.calculator
|
||||||
|
|
||||||
TUPLE: calculator < dispatcher ;
|
TUPLE: calculator < dispatcher ;
|
||||||
|
@ -39,6 +39,6 @@ USING: db.sqlite furnace.alloy namespaces http.server ;
|
||||||
<calculator>
|
<calculator>
|
||||||
calculator-db <alloy>
|
calculator-db <alloy>
|
||||||
main-responder set-global
|
main-responder set-global
|
||||||
8080 httpd ;
|
8080 httpd drop ;
|
||||||
|
|
||||||
MAIN: run-calculator
|
MAIN: run-calculator
|
||||||
|
|
|
@ -38,6 +38,6 @@ USING: db.sqlite furnace.alloy namespaces ;
|
||||||
<counter-app>
|
<counter-app>
|
||||||
counter-db <alloy>
|
counter-db <alloy>
|
||||||
main-responder set-global
|
main-responder set-global
|
||||||
8080 httpd ;
|
8080 httpd drop ;
|
||||||
|
|
||||||
MAIN: run-counter
|
MAIN: run-counter
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: accessors furnace.actions http.server
|
USING: accessors furnace.actions http.server
|
||||||
http.server.dispatchers html.forms io.sockets
|
http.server.dispatchers html.forms io.sockets
|
||||||
namespaces prettyprint ;
|
namespaces prettyprint kernel ;
|
||||||
IN: webapps.ip
|
IN: webapps.ip
|
||||||
|
|
||||||
TUPLE: ip-app < dispatcher ;
|
TUPLE: ip-app < dispatcher ;
|
||||||
|
@ -18,6 +18,6 @@ TUPLE: ip-app < dispatcher ;
|
||||||
|
|
||||||
: run-ip-app ( -- )
|
: run-ip-app ( -- )
|
||||||
<ip-app> main-responder set-global
|
<ip-app> main-responder set-global
|
||||||
8080 httpd ;
|
8080 httpd drop ;
|
||||||
|
|
||||||
MAIN: run-ip-app
|
MAIN: run-ip-app
|
||||||
|
|
|
@ -90,4 +90,4 @@ M: site-watcher-app init-user-profile
|
||||||
: start-site-watcher ( -- )
|
: start-site-watcher ( -- )
|
||||||
init-db
|
init-db
|
||||||
site-watcher-db run-site-watcher
|
site-watcher-db run-site-watcher
|
||||||
<site-watcher-server> start-server ;
|
<site-watcher-server> start-server drop ;
|
||||||
|
|
|
@ -162,6 +162,6 @@ io.sockets.secure ;
|
||||||
: run-todo ( -- )
|
: run-todo ( -- )
|
||||||
<todo-app> main-responder set-global
|
<todo-app> main-responder set-global
|
||||||
todo-db start-expiring
|
todo-db start-expiring
|
||||||
<todo-website-server> start-server ;
|
<todo-website-server> start-server drop ;
|
||||||
|
|
||||||
MAIN: run-todo
|
MAIN: run-todo
|
||||||
|
|
|
@ -125,7 +125,7 @@ SYMBOL: dh-file
|
||||||
8080 >>insecure
|
8080 >>insecure
|
||||||
8431 >>secure ;
|
8431 >>secure ;
|
||||||
|
|
||||||
: start-website ( -- )
|
: start-website ( -- server )
|
||||||
test-db start-expiring
|
test-db start-expiring
|
||||||
test-db start-update-task
|
test-db start-update-task
|
||||||
http-insomniac
|
http-insomniac
|
||||||
|
|
Loading…
Reference in New Issue