{ $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"
[ ] [ [ "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
[ ] [
[
"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 ;
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
: 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
[
"/" >>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
"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
<http-server>
0 >>insecure
f >>secure
- dup start-server*
+ start-server
sockets>> first addr>> port>>
] with-scope "port" set ;
{ $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 } "." } ;
"http" protocol-port >>insecure
"https" protocol-port >>secure ;
-: httpd ( port -- )
+: httpd ( port -- http-server )
<http-server>
swap >>insecure
f >>secure
+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"
"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
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*
+HELP: stop-server
{ $values { "threaded-server" threaded-server } }
-{ $description "Starts a threaded server, returning as soon as it is ready to begin accepting connections." } ;
+{ $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: stop-server
+HELP: wait-for-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 "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." } ;
+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
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
-! 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> ;
"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 )
<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 -- )
[
\ 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
(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 ;
+
+: with-threaded-server ( threaded-server quot -- )
+ over
+ '[
+ [ _ start-server threaded-server _ with-variable ]
+ [ _ stop-server ]
+ [ ] cleanup
+ ] call ; inline
+
+<PRIVATE
+
+: first-port ( quot -- n/f )
+ [ threaded-server get servers>> ] dip
+ filter [ f ] [ first addr>> port>> ] if-empty ; inline
+
+PRIVATE>
+
+: secure-port ( -- n/f ) [ addr>> secure? ] first-port ;
+
+: insecure-port ( -- n/f ) [ addr>> secure? not ] first-port ;
-M: integer port ;
+: server. ( threaded-server -- )
+ [ [ "=== " write name>> ] [ ] bi write-object nl ]
+ [ servers>> [ addr>> present print ] each ] bi ;
-M: object port port>> ;
+: all-servers ( -- sequence )
+ running-servers get-global members ;
-: secure-port ( -- n )
- threaded-server get dup [ secure>> port ] when ;
+: servers. ( -- )
+ all-servers [ server. ] each ;
-: insecure-port ( -- n )
- threaded-server get dup [ insecure>> port ] when ;
+: stop-all-servers ( -- )
+ all-servers [ stop-server ] each ;
! 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 )
"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
<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
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 ;
! 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 ( -- )
[ handle-time-client ] >>handler ;
: start-time-server ( -- )
- <time-server> start-server ;
+ <time-server> start-server drop ;
MAIN: start-time-server
"tty-server" >>name
swap local-server >>insecure
[ listener ] >>handler
- start-server ;
+ start-server drop ;
: tty-server ( -- ) 9999 <tty-server> ;
! 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 ;
<calculator>
calculator-db <alloy>
main-responder set-global
- 8080 httpd ;
+ 8080 httpd drop ;
MAIN: run-calculator
<counter-app>
counter-db <alloy>
main-responder set-global
- 8080 httpd ;
+ 8080 httpd drop ;
MAIN: run-counter
! 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 ;
: run-ip-app ( -- )
<ip-app> main-responder set-global
- 8080 httpd ;
+ 8080 httpd drop ;
MAIN: run-ip-app
: start-site-watcher ( -- )
init-db
site-watcher-db run-site-watcher
- <site-watcher-server> start-server ;
+ <site-watcher-server> start-server drop ;
: 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
8080 >>insecure
8431 >>secure ;
-: start-website ( -- )
+: start-website ( -- server )
test-db start-expiring
test-db start-update-task
http-insomniac
projects / factor.git / commitdiff