Major I/O cleanup
Slava Pestov
parent
1342d0964c
commit
62c7aabf35
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax io io.nonblocking kernel math
|
||||
USING: help.markup help.syntax io io.ports kernel math
|
||||
io.files.unique.private math.parser io.files ;
|
||||
IN: io.files.unique
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: system kernel namespaces strings hashtables sequences
|
|||
assocs combinators vocabs.loader init threads continuations
|
||||
math accessors concurrency.flags destructors
|
||||
io io.backend io.timeouts io.pipes io.pipes.private io.encodings
|
||||
io.streams.duplex io.nonblocking ;
|
||||
io.streams.duplex io.ports ;
|
||||
IN: io.launcher
|
||||
|
||||
TUPLE: process < identity-tuple
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: io io.pipes io.streams.string io.encodings.utf8
|
||||
io.streams.duplex io.encodings namespaces continuations
|
||||
tools.test kernel ;
|
||||
io.streams.duplex io.encodings io.timeouts namespaces
|
||||
continuations tools.test kernel calendar ;
|
||||
IN: io.pipes.tests
|
||||
|
||||
[ "Hello" ] [
|
||||
|
|
@ -24,3 +24,10 @@ IN: io.pipes.tests
|
|||
[ input-stream [ utf8 <decoder> ] change readln ]
|
||||
} run-pipeline
|
||||
] unit-test
|
||||
|
||||
[
|
||||
utf8 <pipe> [
|
||||
5 seconds over set-timeout
|
||||
stream-readln
|
||||
] with-disposal
|
||||
] must-fail
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.encodings io.backend io.nonblocking io.streams.duplex
|
||||
USING: io.encodings io.backend io.ports io.streams.duplex
|
||||
io splitting sequences sequences.lib namespaces kernel
|
||||
destructors math concurrency.combinators accessors
|
||||
arrays continuations quotations ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,9 @@
|
|||
USING: io io.buffers io.backend help.markup help.syntax kernel
|
||||
byte-arrays sbufs words continuations byte-vectors classes ;
|
||||
IN: io.nonblocking
|
||||
IN: io.ports
|
||||
|
||||
ARTICLE: "io.nonblocking" "Non-blocking I/O implementation"
|
||||
"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.nonblocking" } " vocabulary."
|
||||
ARTICLE: "io.ports" "Non-blocking I/O implementation"
|
||||
"On Windows and Unix, Factor implements blocking file and network streams on top of a non-blocking I/O substrate, ensuring that Factor threads will yield when performing I/O. This substrate is implemented in the " { $vocab-link "io.ports" } " vocabulary."
|
||||
$nl
|
||||
"A " { $emphasis "port" } " is a stream using non-blocking I/O substrate:"
|
||||
{ $subsection port }
|
||||
|
|
@ -29,7 +29,7 @@ $nl
|
|||
{ $subsection server-port }
|
||||
{ $subsection datagram-port } ;
|
||||
|
||||
ABOUT: "io.nonblocking"
|
||||
ABOUT: "io.ports"
|
||||
|
||||
HELP: port
|
||||
{ $class-description "Instances of this class present a blocking stream interface on top of an underlying non-blocking I/O system, giving the illusion of blocking by yielding the thread which is waiting for input or output."
|
||||
|
|
@ -81,10 +81,6 @@ HELP: (wait-to-read)
|
|||
{ $contract "Suspends the current thread until the port's buffer has data available for reading." } ;
|
||||
|
||||
HELP: wait-to-read
|
||||
{ $values { "count" "a non-negative integer" } { "port" input-port } }
|
||||
{ $description "If the port's buffer has at least " { $snippet "count" } " unread bytes, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
|
||||
|
||||
HELP: wait-to-read1
|
||||
{ $values { "port" input-port } }
|
||||
{ $description "If the port's buffer has unread data, returns immediately, otherwise suspends the current thread until some data is available for reading." } ;
|
||||
|
||||
|
|
@ -5,12 +5,12 @@ byte-vectors system io.encodings math.order io.backend
|
|||
continuations debugger classes byte-arrays namespaces splitting
|
||||
dlists assocs io.encodings.binary inspector accessors
|
||||
destructors ;
|
||||
IN: io.nonblocking
|
||||
IN: io.ports
|
||||
|
||||
SYMBOL: default-buffer-size
|
||||
64 1024 * default-buffer-size set-global
|
||||
|
||||
TUPLE: port handle buffer error timeout closed eof ;
|
||||
TUPLE: port handle error timeout closed ;
|
||||
|
||||
M: port timeout timeout>> ;
|
||||
|
||||
|
|
@ -37,26 +37,6 @@ M: handle-destructor dispose ( obj -- )
|
|||
new
|
||||
swap dup init-handle >>handle ; inline
|
||||
|
||||
: <buffered-port> ( handle class -- port )
|
||||
<port>
|
||||
default-buffer-size get <buffer> >>buffer ; inline
|
||||
|
||||
TUPLE: input-port < port ;
|
||||
|
||||
: <input-port> ( handle -- input-port )
|
||||
input-port <buffered-port> ;
|
||||
|
||||
TUPLE: output-port < port ;
|
||||
|
||||
: <output-port> ( handle -- output-port )
|
||||
output-port <buffered-port> ;
|
||||
|
||||
: <ports> ( read-handle write-handle -- input-port output-port )
|
||||
[
|
||||
[ <input-port> dup add-error-destructor ]
|
||||
[ <output-port> dup add-error-destructor ] bi*
|
||||
] with-destructors ;
|
||||
|
||||
: pending-error ( port -- )
|
||||
[ f ] change-error drop [ throw ] when* ;
|
||||
|
||||
|
|
@ -68,19 +48,21 @@ M: port-closed-error summary
|
|||
: check-closed ( port -- port )
|
||||
dup closed>> [ port-closed-error ] when ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
TUPLE: buffered-port < port buffer ;
|
||||
|
||||
M: object cancel-io drop ;
|
||||
: <buffered-port> ( handle class -- port )
|
||||
<port>
|
||||
default-buffer-size get <buffer> >>buffer ; inline
|
||||
|
||||
M: port timed-out cancel-io ;
|
||||
TUPLE: input-port < buffered-port eof ;
|
||||
|
||||
: <input-port> ( handle -- input-port )
|
||||
input-port <buffered-port> ;
|
||||
|
||||
HOOK: (wait-to-read) io-backend ( port -- )
|
||||
|
||||
: wait-to-read ( count port -- )
|
||||
tuck buffer>> buffer-length > [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: wait-to-read1 ( port -- )
|
||||
1 swap wait-to-read ;
|
||||
: wait-to-read ( port -- )
|
||||
dup buffer>> buffer-empty? [ (wait-to-read) ] [ drop ] if ;
|
||||
|
||||
: unless-eof ( port quot -- value )
|
||||
>r dup buffer>> buffer-empty? over eof>> and
|
||||
|
|
@ -88,12 +70,16 @@ HOOK: (wait-to-read) io-backend ( port -- )
|
|||
|
||||
M: input-port stream-read1
|
||||
check-closed
|
||||
dup wait-to-read1 [ buffer>> buffer-pop ] unless-eof ;
|
||||
dup wait-to-read [ buffer>> buffer-pop ] unless-eof ;
|
||||
|
||||
: read-step ( count port -- byte-array/f )
|
||||
[ wait-to-read ] 2keep
|
||||
[ wait-to-read ] keep
|
||||
[ dupd buffer>> buffer-read ] unless-eof nip ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
check-closed
|
||||
>r 0 max >integer r> read-step ;
|
||||
|
||||
: read-loop ( count port accum -- )
|
||||
pick over length - dup 0 > [
|
||||
pick read-step dup [
|
||||
|
|
@ -117,9 +103,10 @@ M: input-port stream-read
|
|||
] [ 2nip ] if
|
||||
] [ 2nip ] if ;
|
||||
|
||||
M: input-port stream-read-partial ( max stream -- byte-array/f )
|
||||
check-closed
|
||||
>r 0 max >fixnum r> read-step ;
|
||||
TUPLE: output-port < buffered-port ;
|
||||
|
||||
: <output-port> ( handle -- output-port )
|
||||
output-port <buffered-port> ;
|
||||
|
||||
: can-write? ( len buffer -- ? )
|
||||
[ buffer-fill + ] keep buffer-capacity <= ;
|
||||
|
|
@ -143,7 +130,10 @@ M: output-port stream-write
|
|||
[ buffer>> >buffer ] 2bi
|
||||
] if ;
|
||||
|
||||
HOOK: flush-port io-backend ( port -- )
|
||||
HOOK: (wait-to-write) io-backend ( port -- )
|
||||
|
||||
: flush-port ( port -- )
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
|
||||
M: output-port stream-flush ( port -- )
|
||||
check-closed
|
||||
|
|
@ -154,35 +144,23 @@ GENERIC: close-port ( port -- )
|
|||
M: output-port close-port
|
||||
[ flush-port ] [ call-next-method ] bi ;
|
||||
|
||||
M: buffered-port close-port
|
||||
[ call-next-method ]
|
||||
[ [ [ buffer-free ] when* f ] change-buffer drop ]
|
||||
bi ;
|
||||
|
||||
HOOK: cancel-io io-backend ( port -- )
|
||||
|
||||
M: port timed-out cancel-io ;
|
||||
|
||||
M: port close-port
|
||||
dup cancel-io
|
||||
dup handle>> close-handle
|
||||
[ [ buffer-free ] when* f ] change-buffer drop ;
|
||||
[ cancel-io ] [ handle>> close-handle ] bi ;
|
||||
|
||||
M: port dispose
|
||||
dup closed>> [ drop ] [ t >>closed close-port ] if ;
|
||||
|
||||
TUPLE: server-port < port addr client client-addr encoding ;
|
||||
|
||||
: <server-port> ( handle addr encoding -- server )
|
||||
rot server-port <port>
|
||||
swap >>encoding
|
||||
swap >>addr ;
|
||||
|
||||
: check-server-port ( port -- port )
|
||||
dup server-port? [ "Not a server port" throw ] unless ; inline
|
||||
|
||||
TUPLE: datagram-port < port addr packet packet-addr ;
|
||||
|
||||
: <datagram-port> ( handle addr -- datagram )
|
||||
swap datagram-port <port>
|
||||
swap >>addr ;
|
||||
|
||||
: check-datagram-port ( port -- port )
|
||||
check-closed
|
||||
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
|
||||
|
||||
: check-datagram-send ( packet addrspec port -- packet addrspec port )
|
||||
check-datagram-port
|
||||
2dup addr>> [ class ] bi@ assert=
|
||||
pick class byte-array assert= ;
|
||||
: <ports> ( read-handle write-handle -- input-port output-port )
|
||||
[
|
||||
[ <input-port> dup add-error-destructor ]
|
||||
[ <output-port> dup add-error-destructor ] bi*
|
||||
] with-destructors ;
|
||||
|
|
@ -2,3 +2,4 @@ IN: io.server.tests
|
|||
USING: tools.test io.server io.server.private ;
|
||||
|
||||
{ 2 0 } [ [ ] server-loop ] must-infer-as
|
||||
{ 2 0 } [ [ ] with-connection ] must-infer-as
|
||||
|
|
|
|||
|
|
@ -12,17 +12,19 @@ SYMBOL: servers
|
|||
|
||||
LOG: accepted-connection NOTICE
|
||||
|
||||
: with-client ( client addrspec quot -- )
|
||||
[
|
||||
swap accepted-connection
|
||||
with-stream*
|
||||
] 2curry with-disposal ; inline
|
||||
SYMBOL: remote-address
|
||||
|
||||
\ with-client DEBUG add-error-logging
|
||||
: with-connection ( client addrspec quot -- )
|
||||
[
|
||||
>r [ remote-address set ] [ accepted-connection ] bi
|
||||
r> call
|
||||
] 2curry with-stream ; inline
|
||||
|
||||
\ with-connection DEBUG add-error-logging
|
||||
|
||||
: accept-loop ( server quot -- )
|
||||
[
|
||||
>r accept r> [ with-client ] 3curry "Client" spawn drop
|
||||
>r accept r> [ with-connection ] 3curry "Client" spawn drop
|
||||
] 2keep accept-loop ; inline
|
||||
|
||||
: server-loop ( addrspec encoding quot -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.syntax byte-arrays io
|
||||
io.sockets.impl kernel structs math math.parser
|
||||
io.sockets kernel structs math math.parser
|
||||
prettyprint sequences ;
|
||||
IN: io.sockets.headers
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Slava Pestov
|
||||
|
|
@ -1,45 +0,0 @@
|
|||
USING: io.sockets.impl io.sockets kernel tools.test ;
|
||||
IN: io.sockets.impl.tests
|
||||
|
||||
[ B{ 1 2 3 4 } ]
|
||||
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
|
||||
|
||||
[ "1.2.3.4" ]
|
||||
[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test
|
||||
|
||||
[ "255.255.255.255" ]
|
||||
[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 255 255 255 255 } ]
|
||||
[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ]
|
||||
[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "1:2:3:4:5:6:7:8" ]
|
||||
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
|
||||
[ "::" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "0:0:0:0:0:0:0:0" ]
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
|
||||
[ "1::" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ]
|
||||
[ "::1" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ]
|
||||
[ "1::2" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ]
|
||||
[ "1::2:3" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ]
|
||||
[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "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
|
||||
|
||||
|
|
@ -1,134 +0,0 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays byte-arrays io.backend io.binary io.sockets
|
||||
io.encodings.ascii kernel math math.parser sequences splitting
|
||||
system alien.c-types alien.strings alien combinators namespaces
|
||||
parser ;
|
||||
IN: io.sockets.impl
|
||||
|
||||
<< {
|
||||
{ [ os windows? ] [ "windows.winsock" ] }
|
||||
{ [ os unix? ] [ "unix" ] }
|
||||
} cond use+ >>
|
||||
|
||||
GENERIC: protocol-family ( addrspec -- af )
|
||||
|
||||
GENERIC: sockaddr-type ( addrspec -- type )
|
||||
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
dup make-sockaddr swap sockaddr-type heap-size ;
|
||||
|
||||
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
|
||||
|
||||
HOOK: addrinfo-error io-backend ( n -- )
|
||||
|
||||
! IPV4 and IPV6
|
||||
GENERIC: address-size ( addrspec -- n )
|
||||
|
||||
GENERIC: inet-ntop ( data addrspec -- str )
|
||||
|
||||
GENERIC: inet-pton ( str addrspec -- data )
|
||||
|
||||
|
||||
M: inet4 inet-ntop ( data addrspec -- str )
|
||||
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
|
||||
|
||||
M: inet4 inet-pton ( str addrspec -- data )
|
||||
drop "." split [ string>number ] B{ } map-as ;
|
||||
|
||||
M: inet4 address-size drop 4 ;
|
||||
|
||||
M: inet4 protocol-family drop PF_INET ;
|
||||
|
||||
M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
|
||||
|
||||
M: inet4 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in" <c-object>
|
||||
AF_INET over set-sockaddr-in-family
|
||||
over inet4-port htons over set-sockaddr-in-port
|
||||
over inet4-host
|
||||
"0.0.0.0" or
|
||||
rot inet-pton *uint over set-sockaddr-in-addr ;
|
||||
|
||||
SYMBOL: port-override
|
||||
|
||||
: (port) port-override get swap or ;
|
||||
|
||||
M: inet4 parse-sockaddr
|
||||
>r dup sockaddr-in-addr <uint> r> inet-ntop
|
||||
swap sockaddr-in-port ntohs (port) <inet4> ;
|
||||
|
||||
M: inet6 inet-ntop ( data addrspec -- str )
|
||||
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
|
||||
|
||||
M: inet6 inet-pton ( str addrspec -- data )
|
||||
drop "::" split1
|
||||
[ [ ":" split [ hex> dup 0 ? ] map ] [ f ] if* ] bi@
|
||||
2dup [ length ] bi@ + 8 swap - 0 <array> swap 3append
|
||||
[ 2 >be ] map concat >byte-array ;
|
||||
|
||||
M: inet6 address-size drop 16 ;
|
||||
|
||||
M: inet6 protocol-family drop PF_INET6 ;
|
||||
|
||||
M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
|
||||
|
||||
M: inet6 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in6" <c-object>
|
||||
AF_INET6 over set-sockaddr-in6-family
|
||||
over inet6-port htons over set-sockaddr-in6-port
|
||||
over inet6-host "::" or
|
||||
rot inet-pton over set-sockaddr-in6-addr ;
|
||||
|
||||
M: inet6 parse-sockaddr
|
||||
>r dup sockaddr-in6-addr r> inet-ntop
|
||||
swap sockaddr-in6-port ntohs (port) <inet6> ;
|
||||
|
||||
: addrspec-of-family ( af -- addrspec )
|
||||
{
|
||||
{ [ dup AF_INET = ] [ T{ inet4 } ] }
|
||||
{ [ dup AF_INET6 = ] [ T{ inet6 } ] }
|
||||
{ [ dup AF_UNIX = ] [ T{ local } ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
||||
M: f parse-sockaddr nip ;
|
||||
|
||||
: addrinfo>addrspec ( addrinfo -- addrspec )
|
||||
[ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
|
||||
parse-sockaddr ;
|
||||
|
||||
: parse-addrinfo-list ( addrinfo -- seq )
|
||||
[ addrinfo-next ] follow
|
||||
[ addrinfo>addrspec ] map
|
||||
[ ] filter ;
|
||||
|
||||
: prepare-resolve-host ( host serv passive? -- 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 ? ;
|
||||
|
||||
M: object resolve-host ( host serv passive? -- seq )
|
||||
[
|
||||
prepare-resolve-host
|
||||
"addrinfo" <c-object>
|
||||
[ set-addrinfo-flags ] keep
|
||||
PF_UNSPEC over set-addrinfo-family
|
||||
IPPROTO_TCP over set-addrinfo-protocol
|
||||
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
|
||||
[ parse-addrinfo-list ] keep
|
||||
freeaddrinfo
|
||||
] with-scope ;
|
||||
|
||||
M: object host-name ( -- name )
|
||||
256 <byte-array> dup dup length gethostname
|
||||
zero? [ "gethostname failed" throw ] unless
|
||||
ascii alien>string ;
|
||||
|
|
@ -64,7 +64,7 @@ HELP: local
|
|||
} ;
|
||||
|
||||
HELP: inet
|
||||
{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet-host } " and " { $link inet-port } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link <inet> } "." }
|
||||
{ $class-description "Host name/port number specifier for TCP/IP and UDP/IP connections. The " { $snippet "host" } " and " { $snippet "port" } " slots hold the host name and port name or number, respectively. New instances are created by calling " { $link <inet> } "." }
|
||||
{ $notes
|
||||
"This address specifier is only supported by " { $link <client> } ", which calls " { $link resolve-host } " to obtain a list of IP addresses associated with the host name, and attempts a connection to each one in turn until one succeeds. Other network words do not accept this address specifier, and " { $link resolve-host } " must be called directly; it is then up to the application to pick the correct address from the (possibly several) addresses associated to the host name."
|
||||
}
|
||||
|
|
@ -74,7 +74,7 @@ HELP: inet
|
|||
} ;
|
||||
|
||||
HELP: inet4
|
||||
{ $class-description "IPv4 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet4-host } " and " { $link inet4-port } " slots hold the IPv4 address and port number, respectively. New instances are created by calling " { $link <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 <inet4> } "." }
|
||||
{ $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."
|
||||
}
|
||||
|
|
@ -83,7 +83,7 @@ HELP: inet4
|
|||
} ;
|
||||
|
||||
HELP: inet6
|
||||
{ $class-description "IPv6 address/port number specifier for TCP/IP and UDP/IP connections. The " { $link inet6-host } " and " { $link inet6-port } " slots hold the IPv6 address and port number, respectively. New instances are created by calling " { $link <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 <inet6> } "." }
|
||||
{ $notes
|
||||
"New instances should not be created directly; instead, use " { $link resolve-host } " to look up the address associated to a host name." }
|
||||
{ $examples
|
||||
|
|
@ -91,13 +91,19 @@ HELP: inet6
|
|||
} ;
|
||||
|
||||
HELP: <client>
|
||||
{ $values { "addrspec" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } }
|
||||
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding." }
|
||||
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "stream" "a bidirectional stream" } { "local" "an address specifier" } }
|
||||
{ $description "Opens a network connection and outputs a bidirectional stream using the given encoding, together with the local address the socket was bound to." }
|
||||
{ $errors "Throws an error if the connection cannot be established." }
|
||||
{ $notes "The " { $link with-client } " word is easier to use in most situations." }
|
||||
{ $examples
|
||||
{ $code "\"www.apple.com\" \"http\" <inet> utf8 <client>" }
|
||||
} ;
|
||||
|
||||
HELP: with-client
|
||||
{ $values { "remote" "an address specifier" } { "encoding" "an encding descriptor" } { "quot" quotation } }
|
||||
{ $description "Opens a network connection and calls the quotation in a new dynamic scope with " { $link input-stream } " and " { $link output-stream } " rebound to the network streams. The local address the socket is bound to is stored in the " { $link local-address } " variable." }
|
||||
{ $errors "Throws an error if the connection cannot be established." } ;
|
||||
|
||||
HELP: <server>
|
||||
{ $values { "addrspec" "an address specifier" } { "encoding" "an encoding descriptor" } { "server" "a handle" } }
|
||||
{ $description
|
||||
|
|
@ -113,6 +119,13 @@ HELP: <server>
|
|||
"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."
|
||||
$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
|
||||
"f 0 <inet4> ascii <server>"
|
||||
"[ addr>> . ] [ dispose ] bi"
|
||||
"T{ inet4 f \"0.0.0.0\" 58901 }"
|
||||
}
|
||||
}
|
||||
{ $errors "Throws an error if the address is already in use, or if it if the system forbids access." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,46 @@
|
|||
IN: io.sockets.tests
|
||||
USING: io.sockets sequences math tools.test ;
|
||||
|
||||
[ B{ 1 2 3 4 } ]
|
||||
[ "1.2.3.4" T{ inet4 } inet-pton ] unit-test
|
||||
|
||||
[ "1.2.3.4" ]
|
||||
[ B{ 1 2 3 4 } T{ inet4 } inet-ntop ] unit-test
|
||||
|
||||
[ "255.255.255.255" ]
|
||||
[ B{ 255 255 255 255 } T{ inet4 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 255 255 255 255 } ]
|
||||
[ "255.255.255.255" T{ inet4 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } ]
|
||||
[ "1:2:3:4:5:6:7:8" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "1:2:3:4:5:6:7:8" ]
|
||||
[ B{ 0 1 0 2 0 3 0 4 0 5 0 6 0 7 0 8 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
|
||||
[ "::" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "0:0:0:0:0:0:0:0" ]
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } T{ inet6 } inet-ntop ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 } ]
|
||||
[ "1::" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 } ]
|
||||
[ "::1" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 2 } ]
|
||||
[ "1::2" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 0 0 0 0 0 0 0 0 0 0 2 0 3 } ]
|
||||
[ "1::2:3" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ B{ 0 1 0 2 0 0 0 0 0 0 0 0 0 3 0 4 } ]
|
||||
[ "1:2::3:4" T{ inet6 } inet-pton ] unit-test
|
||||
|
||||
[ "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
|
||||
|
|
|
|||
|
|
@ -1,10 +1,39 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Daniel Ehrenberg.
|
||||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman,
|
||||
! Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: generic kernel io.backend namespaces continuations
|
||||
sequences arrays io.encodings io.nonblocking io.streams.duplex
|
||||
accessors destructors ;
|
||||
sequences arrays io.encodings io.ports io.streams.duplex
|
||||
io.encodings.ascii alien.strings io.binary accessors destructors
|
||||
classes debugger byte-arrays system combinators parser
|
||||
alien.c-types math.parser splitting math assocs inspector ;
|
||||
IN: io.sockets
|
||||
|
||||
<< {
|
||||
{ [ os windows? ] [ "windows.winsock" ] }
|
||||
{ [ os unix? ] [ "unix" ] }
|
||||
} cond use+ >>
|
||||
|
||||
! Addressing
|
||||
GENERIC: protocol-family ( addrspec -- af )
|
||||
|
||||
GENERIC: sockaddr-type ( addrspec -- type )
|
||||
|
||||
GENERIC: make-sockaddr ( addrspec -- sockaddr )
|
||||
|
||||
GENERIC: address-size ( addrspec -- n )
|
||||
|
||||
GENERIC: inet-ntop ( data addrspec -- str )
|
||||
|
||||
GENERIC: inet-pton ( str addrspec -- data )
|
||||
|
||||
: make-sockaddr/size ( addrspec -- sockaddr size )
|
||||
dup make-sockaddr swap sockaddr-type heap-size ;
|
||||
|
||||
: empty-sockaddr/size ( addrspec -- sockaddr len )
|
||||
sockaddr-type [ <c-object> ] [ heap-size <int> ] bi ;
|
||||
|
||||
GENERIC: parse-sockaddr ( sockaddr addrspec -- newaddrspec )
|
||||
|
||||
TUPLE: local path ;
|
||||
|
||||
: <local> ( path -- addrspec )
|
||||
|
|
@ -14,59 +43,248 @@ TUPLE: inet4 host port ;
|
|||
|
||||
C: <inet4> inet4
|
||||
|
||||
M: inet4 inet-ntop ( data addrspec -- str )
|
||||
drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
|
||||
|
||||
ERROR: invalid-inet4 string reason ;
|
||||
|
||||
M: invalid-inet4 summary drop "Invalid IPv4 address" ;
|
||||
|
||||
M: inet4 inet-pton ( str addrspec -- data )
|
||||
drop
|
||||
[
|
||||
"." split dup length 4 = [
|
||||
"Must have four components" throw
|
||||
] unless
|
||||
[
|
||||
string>number
|
||||
[ "Dotted component not a number" throw ] unless*
|
||||
] B{ } map-as
|
||||
] [ invalid-inet4 ] recover ;
|
||||
|
||||
M: inet4 address-size drop 4 ;
|
||||
|
||||
M: inet4 protocol-family drop PF_INET ;
|
||||
|
||||
M: inet4 sockaddr-type drop "sockaddr-in" c-type ;
|
||||
|
||||
M: inet4 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in" <c-object>
|
||||
AF_INET over set-sockaddr-in-family
|
||||
over inet4-port htons over set-sockaddr-in-port
|
||||
over inet4-host
|
||||
"0.0.0.0" or
|
||||
rot inet-pton *uint over set-sockaddr-in-addr ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: port-override
|
||||
|
||||
: (port) port-override get swap or ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: inet4 parse-sockaddr
|
||||
>r dup sockaddr-in-addr <uint> r> inet-ntop
|
||||
swap sockaddr-in-port ntohs (port) <inet4> ;
|
||||
|
||||
TUPLE: inet6 host port ;
|
||||
|
||||
C: <inet6> inet6
|
||||
|
||||
M: inet6 inet-ntop ( data addrspec -- str )
|
||||
drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
|
||||
|
||||
ERROR: invalid-inet6 string reason ;
|
||||
|
||||
M: invalid-inet6 summary drop "Invalid IPv6 address" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: parse-inet6 ( string -- seq )
|
||||
dup empty? [ drop f ] [
|
||||
":" split [
|
||||
hex> [ "Component not a number" throw ] unless*
|
||||
] B{ } map-as
|
||||
] if ;
|
||||
|
||||
: pad-inet6 ( string1 string2 -- seq )
|
||||
2dup [ length ] bi@ + 8 swap -
|
||||
dup 0 < [ "More than 8 components" throw ] when
|
||||
<byte-array> swap 3append ;
|
||||
|
||||
: inet6-bytes ( seq -- bytes )
|
||||
[ 2 >be ] { } map-as concat >byte-array ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: inet6 inet-pton ( str addrspec -- data )
|
||||
drop
|
||||
[
|
||||
"::" split1 [ parse-inet6 ] bi@ pad-inet6 inet6-bytes
|
||||
] [ invalid-inet6 ] recover ;
|
||||
|
||||
M: inet6 address-size drop 16 ;
|
||||
|
||||
M: inet6 protocol-family drop PF_INET6 ;
|
||||
|
||||
M: inet6 sockaddr-type drop "sockaddr-in6" c-type ;
|
||||
|
||||
M: inet6 make-sockaddr ( inet -- sockaddr )
|
||||
"sockaddr-in6" <c-object>
|
||||
AF_INET6 over set-sockaddr-in6-family
|
||||
over inet6-port htons over set-sockaddr-in6-port
|
||||
over inet6-host "::" or
|
||||
rot inet-pton over set-sockaddr-in6-addr ;
|
||||
|
||||
M: inet6 parse-sockaddr
|
||||
>r dup sockaddr-in6-addr r> inet-ntop
|
||||
swap sockaddr-in6-port ntohs (port) <inet6> ;
|
||||
|
||||
: addrspec-of-family ( af -- addrspec )
|
||||
{
|
||||
{ AF_INET [ T{ inet4 } ] }
|
||||
{ AF_INET6 [ T{ inet6 } ] }
|
||||
{ AF_UNIX [ T{ local } ] }
|
||||
[ drop f ]
|
||||
} case ;
|
||||
|
||||
M: f parse-sockaddr nip ;
|
||||
|
||||
GENERIC# (wait-to-connect) 1 ( client-out handle remote -- sockaddr )
|
||||
|
||||
: wait-to-connect ( client-out handle remote -- local )
|
||||
[ (wait-to-connect) ] keep parse-sockaddr ;
|
||||
|
||||
GENERIC: ((client)) ( remote -- handle )
|
||||
|
||||
GENERIC: (client) ( remote -- client-in client-out local )
|
||||
|
||||
M: array (client) [ (client) 3array ] attempt-all first3 ;
|
||||
|
||||
M: object (client) ( remote -- client-in client-out local )
|
||||
[
|
||||
[
|
||||
((client))
|
||||
dup <ports>
|
||||
2dup [ add-error-destructor ] bi@
|
||||
dup dup handle>>
|
||||
] keep wait-to-connect
|
||||
] with-destructors ;
|
||||
|
||||
: <client> ( remote encoding -- stream local )
|
||||
>r (client) -rot r> <encoder-duplex> swap ;
|
||||
|
||||
SYMBOL: local-address
|
||||
|
||||
: with-client ( addrspec encoding quot -- )
|
||||
>r <client> [ local-address set ] curry
|
||||
r> compose with-stream ; inline
|
||||
|
||||
TUPLE: server-port < port addr encoding ;
|
||||
|
||||
: check-server-port ( port -- port )
|
||||
check-closed
|
||||
dup server-port? [ "Not a server port" throw ] unless ; inline
|
||||
|
||||
GENERIC: (server) ( addrspec -- handle sockaddr )
|
||||
|
||||
: <server> ( addrspec encoding -- server )
|
||||
>r [ (server) ] keep parse-sockaddr
|
||||
swap server-port <port>
|
||||
swap >>addr
|
||||
r> >>encoding ;
|
||||
|
||||
HOOK: (accept) io-backend ( server -- handle sockaddr )
|
||||
|
||||
: accept ( server -- client addrspec )
|
||||
check-server-port
|
||||
[ (accept) ] keep
|
||||
tuck
|
||||
[ [ dup <ports> ] [ encoding>> ] bi* <encoder-duplex> ]
|
||||
[ addr>> parse-sockaddr ]
|
||||
2bi* ;
|
||||
|
||||
TUPLE: datagram-port < port addr ;
|
||||
|
||||
HOOK: (datagram) io-backend ( addr -- datagram )
|
||||
|
||||
: <datagram> ( addr -- datagram )
|
||||
dup (datagram) datagram-port <port> swap >>addr ;
|
||||
|
||||
: check-datagram-port ( port -- port )
|
||||
check-closed
|
||||
dup datagram-port? [ "Not a datagram port" throw ] unless ; inline
|
||||
|
||||
HOOK: (receive) io-backend ( datagram -- packet addrspec )
|
||||
|
||||
: receive ( datagram -- packet sockaddr )
|
||||
check-datagram-port
|
||||
[ (receive) ] [ addr>> ] bi parse-sockaddr ;
|
||||
|
||||
: check-datagram-send ( packet addrspec port -- packet addrspec port )
|
||||
check-datagram-port
|
||||
2dup addr>> [ class ] bi@ assert=
|
||||
pick class byte-array assert= ;
|
||||
|
||||
HOOK: (send) io-backend ( packet addrspec datagram -- )
|
||||
|
||||
: send ( packet addrspec datagram -- )
|
||||
check-datagram-send (send) ;
|
||||
|
||||
: addrinfo>addrspec ( addrinfo -- addrspec )
|
||||
[ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi
|
||||
parse-sockaddr ;
|
||||
|
||||
: parse-addrinfo-list ( addrinfo -- seq )
|
||||
[ addrinfo-next ] follow
|
||||
[ addrinfo>addrspec ] map
|
||||
[ ] filter ;
|
||||
|
||||
: prepare-resolve-host ( host serv passive? -- 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 ? ;
|
||||
|
||||
HOOK: addrinfo-error io-backend ( n -- )
|
||||
|
||||
: resolve-host ( host serv passive? -- seq )
|
||||
[
|
||||
prepare-resolve-host
|
||||
"addrinfo" <c-object>
|
||||
[ set-addrinfo-flags ] keep
|
||||
PF_UNSPEC over set-addrinfo-family
|
||||
IPPROTO_TCP over set-addrinfo-protocol
|
||||
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
|
||||
[ parse-addrinfo-list ] keep
|
||||
freeaddrinfo
|
||||
] with-scope ;
|
||||
|
||||
: host-name ( -- string )
|
||||
256 <byte-array> dup dup length gethostname
|
||||
zero? [ "gethostname failed" throw ] unless
|
||||
ascii alien>string ;
|
||||
|
||||
TUPLE: inet host port ;
|
||||
|
||||
C: <inet> inet
|
||||
|
||||
GENERIC: wait-to-connect ( client-out handle -- )
|
||||
|
||||
GENERIC: ((client)) ( addrspec -- handle )
|
||||
|
||||
GENERIC: (client) ( addrspec -- client-in client-out )
|
||||
|
||||
M: array (client) [ (client) 2array ] attempt-all first2 ;
|
||||
|
||||
M: object (client)
|
||||
[
|
||||
((client))
|
||||
dup <ports>
|
||||
2dup [ add-error-destructor ] bi@
|
||||
dup dup handle>> wait-to-connect
|
||||
] with-destructors ;
|
||||
|
||||
: <client> ( addrspec encoding -- stream )
|
||||
>r (client) r> <encoder-duplex> ;
|
||||
|
||||
: with-client ( addrspec encoding quot -- )
|
||||
>r <client> r> with-stream ; inline
|
||||
|
||||
HOOK: (server) io-backend ( addrspec -- handle )
|
||||
|
||||
: <server> ( addrspec encoding -- server )
|
||||
>r [ (server) ] keep r> <server-port> ;
|
||||
|
||||
HOOK: (accept) io-backend ( server -- addrspec handle )
|
||||
|
||||
: accept ( server -- client addrspec )
|
||||
[ (accept) dup <ports> ] [ encoding>> ] bi
|
||||
<encoder-duplex> swap ;
|
||||
|
||||
HOOK: <datagram> io-backend ( addrspec -- datagram )
|
||||
|
||||
HOOK: receive io-backend ( datagram -- packet addrspec )
|
||||
|
||||
HOOK: send io-backend ( packet addrspec datagram -- )
|
||||
|
||||
HOOK: resolve-host io-backend ( host serv passive? -- seq )
|
||||
|
||||
HOOK: host-name io-backend ( -- string )
|
||||
|
||||
: resolve-client-addr ( inet -- seq )
|
||||
[ host>> ] [ port>> ] bi f resolve-host ;
|
||||
|
||||
M: inet (client)
|
||||
resolve-client-addr (client) ;
|
||||
|
||||
ERROR: invalid-inet-server addrspec ;
|
||||
|
||||
M: invalid-inet-server summary
|
||||
drop "Cannot use <server> with <inet>; use <inet4> or <inet6> instead" ;
|
||||
|
||||
M: inet (server)
|
||||
invalid-inet-server ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,6 @@ USING: kernel calendar alarms io io.encodings accessors
|
|||
namespaces ;
|
||||
IN: io.timeouts
|
||||
|
||||
! Won't need this with new slot accessors
|
||||
GENERIC: timeout ( obj -- dt/f )
|
||||
GENERIC: set-timeout ( dt/f obj -- )
|
||||
|
||||
|
|
@ -14,8 +13,6 @@ M: encoder set-timeout stream>> set-timeout ;
|
|||
|
||||
GENERIC: timed-out ( obj -- )
|
||||
|
||||
M: object timed-out drop ;
|
||||
|
||||
: queue-timeout ( obj timeout -- alarm )
|
||||
>r [ timed-out ] curry r> later ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,69 +1,85 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien generic assocs kernel kernel.private math
|
||||
io.nonblocking sequences strings structs sbufs threads unix
|
||||
io.ports sequences strings structs sbufs threads unix
|
||||
vectors io.buffers io.backend io.encodings math.parser
|
||||
continuations system libc qualified namespaces io.timeouts
|
||||
io.encodings.utf8 accessors ;
|
||||
io.encodings.utf8 accessors inspector combinators ;
|
||||
QUALIFIED: io
|
||||
IN: io.unix.backend
|
||||
|
||||
! I/O tasks
|
||||
TUPLE: io-task port callbacks ;
|
||||
|
||||
GENERIC: handle-fd ( handle -- fd )
|
||||
|
||||
M: integer handle-fd ;
|
||||
|
||||
: io-task-fd port>> handle>> handle-fd ;
|
||||
|
||||
: <io-task> ( port continuation/f class -- task )
|
||||
new
|
||||
swap [ 1vector ] [ V{ } clone ] if* >>callbacks
|
||||
swap >>port ; inline
|
||||
|
||||
TUPLE: input-task < io-task ;
|
||||
|
||||
TUPLE: output-task < io-task ;
|
||||
|
||||
GENERIC: do-io-task ( task -- ? )
|
||||
GENERIC: io-task-container ( mx task -- hashtable )
|
||||
|
||||
! I/O multiplexers
|
||||
TUPLE: mx fd reads writes ;
|
||||
|
||||
M: input-task io-task-container drop reads>> ;
|
||||
|
||||
M: output-task io-task-container drop writes>> ;
|
||||
|
||||
: new-mx ( class -- obj )
|
||||
new
|
||||
H{ } clone >>reads
|
||||
H{ } clone >>writes ; inline
|
||||
|
||||
GENERIC: register-io-task ( task mx -- )
|
||||
GENERIC: unregister-io-task ( task mx -- )
|
||||
GENERIC: add-input-callback ( thread fd mx -- )
|
||||
|
||||
: add-callback ( thread fd assoc -- )
|
||||
[ ?push ] change-at ;
|
||||
|
||||
M: mx add-input-callback reads>> add-callback ;
|
||||
|
||||
GENERIC: add-output-callback ( thread fd mx -- )
|
||||
|
||||
M: mx add-output-callback writes>> add-callback ;
|
||||
|
||||
GENERIC: remove-input-callbacks ( fd mx -- callbacks )
|
||||
|
||||
M: mx remove-input-callbacks reads>> delete-at* drop ;
|
||||
|
||||
GENERIC: remove-output-callbacks ( fd mx -- callbacks )
|
||||
|
||||
M: mx remove-output-callbacks writes>> delete-at* drop ;
|
||||
|
||||
GENERIC: wait-for-events ( ms mx -- )
|
||||
|
||||
: fd/container ( task mx -- task fd container )
|
||||
over io-task-container >r dup io-task-fd r> ; inline
|
||||
TUPLE: unix-io-error error port ;
|
||||
|
||||
: check-io-task ( task mx -- )
|
||||
fd/container key? nip [
|
||||
"Cannot perform multiple reads from the same port" throw
|
||||
] when ;
|
||||
: report-error ( error port -- )
|
||||
tuck unix-io-error boa >>error drop ;
|
||||
|
||||
M: mx register-io-task ( task mx -- )
|
||||
2dup check-io-task fd/container set-at ;
|
||||
: input-available ( fd mx -- )
|
||||
remove-input-callbacks [ resume ] each ;
|
||||
|
||||
: add-io-task ( task -- )
|
||||
mx get-global register-io-task ;
|
||||
: output-available ( fd mx -- )
|
||||
remove-output-callbacks [ resume ] each ;
|
||||
|
||||
: with-port-continuation ( port quot -- port )
|
||||
[ "I/O" suspend drop ] curry with-timeout ; inline
|
||||
TUPLE: io-timeout ;
|
||||
|
||||
M: mx unregister-io-task ( task mx -- )
|
||||
fd/container delete-at drop ;
|
||||
M: io-timeout summary drop "I/O operation timed out" ;
|
||||
|
||||
M: unix cancel-io ( port -- )
|
||||
io-timeout new over report-error
|
||||
handle>> handle-fd mx get-global
|
||||
[ input-available ] [ output-available ] 2bi ;
|
||||
|
||||
SYMBOL: +retry+ ! just try the operation again without blocking
|
||||
SYMBOL: +input+
|
||||
SYMBOL: +output+
|
||||
|
||||
: wait-for-port ( port event -- )
|
||||
dup +retry+ eq? [ 2drop ] [
|
||||
[
|
||||
[
|
||||
>r
|
||||
swap handle>> handle-fd
|
||||
mx get-global
|
||||
r> {
|
||||
{ +input+ [ add-input-callback ] }
|
||||
{ +output+ [ add-output-callback ] }
|
||||
} case
|
||||
] curry "I/O" suspend drop
|
||||
] curry with-timeout pending-error
|
||||
] if ;
|
||||
|
||||
! Some general stuff
|
||||
: file-mode OCT: 0666 ;
|
||||
|
|
@ -88,43 +104,8 @@ M: integer init-handle ( fd -- )
|
|||
M: integer close-handle ( fd -- )
|
||||
close ;
|
||||
|
||||
TUPLE: unix-io-error error port ;
|
||||
|
||||
: report-error ( error port -- )
|
||||
tuck unix-io-error boa >>error drop ;
|
||||
|
||||
: ignorable-error? ( n -- ? )
|
||||
[ EAGAIN number= ] [ EINTR number= ] bi or ;
|
||||
|
||||
: defer-error ( port -- ? )
|
||||
#! Return t if it is an unrecoverable error.
|
||||
err_no dup ignorable-error?
|
||||
[ 2drop f ] [ strerror swap report-error t ] if ;
|
||||
|
||||
: pop-callbacks ( mx task -- )
|
||||
dup rot unregister-io-task
|
||||
io-task-callbacks [ resume ] each ;
|
||||
|
||||
: perform-io-task ( mx task -- )
|
||||
dup do-io-task [ pop-callbacks ] [ 2drop ] if ;
|
||||
|
||||
: handle-timeout ( port mx assoc -- )
|
||||
>r swap port-handle r> delete-at* [
|
||||
"I/O operation cancelled" over port>> report-error
|
||||
pop-callbacks
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: cancel-io-tasks ( port mx -- )
|
||||
[ dup reads>> handle-timeout ]
|
||||
[ dup writes>> handle-timeout ] 2bi ;
|
||||
|
||||
M: unix cancel-io ( port -- )
|
||||
mx get-global cancel-io-tasks ;
|
||||
|
||||
! Readers
|
||||
: reader-eof ( reader -- )
|
||||
: eof ( reader -- )
|
||||
dup buffer>> buffer-empty? [ t >>eof ] when drop ;
|
||||
|
||||
: (refill) ( port -- n )
|
||||
|
|
@ -132,62 +113,42 @@ M: unix cancel-io ( port -- )
|
|||
[ buffer>> buffer-end ]
|
||||
[ buffer>> buffer-capacity ] tri read ;
|
||||
|
||||
GENERIC: refill ( port handle -- ? )
|
||||
! Returns an event to wait for which will ensure completion of
|
||||
! this request
|
||||
GENERIC: refill ( port handle -- event/f )
|
||||
|
||||
M: integer refill
|
||||
#! Return f if there is a recoverable error
|
||||
drop
|
||||
dup buffer>> buffer-empty? [
|
||||
dup (refill) dup 0 >= [
|
||||
swap buffer>> n>buffer t
|
||||
] [
|
||||
drop defer-error
|
||||
] if
|
||||
] [ drop t ] if ;
|
||||
over buffer>> [ buffer-end ] [ buffer-capacity ] bi read
|
||||
{
|
||||
{ [ dup 0 = ] [ drop eof f ] }
|
||||
{ [ dup 0 > ] [ swap buffer>> n>buffer f ] }
|
||||
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ err_no EAGAIN = ] [ 2drop +input+ ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: read-task < input-task ;
|
||||
|
||||
: <read-task> ( port continuation -- task ) read-task <io-task> ;
|
||||
|
||||
M: read-task do-io-task
|
||||
port>> dup dup handle>> refill
|
||||
[ [ reader-eof ] [ drop ] if ] keep ;
|
||||
|
||||
M: unix (wait-to-read)
|
||||
[ <read-task> add-io-task ] with-port-continuation
|
||||
pending-error ;
|
||||
M: unix (wait-to-read) ( port -- )
|
||||
dup dup handle>> refill dup
|
||||
[ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ;
|
||||
|
||||
! Writers
|
||||
GENERIC: drain ( port handle -- ? )
|
||||
GENERIC: drain ( port handle -- event/f )
|
||||
|
||||
M: integer drain
|
||||
drop
|
||||
dup
|
||||
[ handle>> ]
|
||||
[ buffer>> buffer@ ]
|
||||
[ buffer>> buffer-length ] tri
|
||||
write dup 0 >=
|
||||
[ swap buffer>> buffer-consume f ]
|
||||
[ drop defer-error ] if ;
|
||||
over buffer>> [ buffer@ ] [ buffer-length ] bi write
|
||||
{
|
||||
{ [ dup 0 >= ] [
|
||||
over buffer>> buffer-consume
|
||||
buffer>> buffer-empty? f +output+ ?
|
||||
] }
|
||||
{ [ err_no EINTR = ] [ 2drop +retry+ ] }
|
||||
{ [ err_no EAGAIN = ] [ 2drop +output+ ] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
TUPLE: write-task < output-task ;
|
||||
|
||||
: <write-task> ( port continuation -- task ) write-task <io-task> ;
|
||||
|
||||
M: write-task do-io-task
|
||||
io-task-port dup [ buffer>> buffer-empty? ] [ port-error ] bi or
|
||||
[ 0 swap buffer>> buffer-reset t ] [ dup handle>> drain ] if ;
|
||||
|
||||
: add-write-io-task ( port continuation -- )
|
||||
over handle>> mx get-global writes>> at*
|
||||
[ io-task-callbacks push drop ]
|
||||
[ drop <write-task> add-io-task ] if ;
|
||||
|
||||
: (wait-to-write) ( port -- )
|
||||
[ add-write-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: unix flush-port ( port -- )
|
||||
dup buffer>> buffer-empty? [ drop ] [ (wait-to-write) ] if ;
|
||||
M: unix (wait-to-write) ( port -- )
|
||||
dup dup handle>> drain dup
|
||||
[ dupd wait-for-port (wait-to-write) ] [ 2drop ] if ;
|
||||
|
||||
M: unix io-multiplex ( ms/f -- )
|
||||
mx get-global wait-for-events ;
|
||||
|
|
@ -203,16 +164,10 @@ TUPLE: mx-port < port mx ;
|
|||
: <mx-port> ( mx -- port )
|
||||
dup fd>> mx-port <port> swap >>mx ;
|
||||
|
||||
TUPLE: mx-task < io-task ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f mx-task <io-task> ;
|
||||
|
||||
M: mx-task do-io-task
|
||||
port>> mx>> 0 swap wait-for-events f ;
|
||||
|
||||
: multiplexer-error ( n -- )
|
||||
0 < [ err_no ignorable-error? [ (io-error) ] unless ] when ;
|
||||
0 < [
|
||||
err_no [ EAGAIN = ] [ EINTR = ] bi or [ (io-error) ] unless
|
||||
] when ;
|
||||
|
||||
: ?flag ( n mask symbol -- n )
|
||||
pick rot bitand 0 > [ , ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -3,16 +3,16 @@
|
|||
IN: io.unix.bsd
|
||||
USING: namespaces system kernel accessors assocs continuations
|
||||
unix
|
||||
io.backend io.unix.backend io.unix.select io.unix.kqueue io.monitors ;
|
||||
io.backend io.unix.backend io.unix.select io.monitors ;
|
||||
|
||||
M: bsd init-io ( -- )
|
||||
<select-mx> mx set-global
|
||||
<kqueue-mx> kqueue-mx set-global
|
||||
kqueue-mx get-global <mx-port> <mx-task>
|
||||
dup io-task-fd
|
||||
[ mx get-global reads>> set-at ]
|
||||
[ mx get-global writes>> set-at ] 2bi ;
|
||||
<select-mx> mx set-global ;
|
||||
! <kqueue-mx> kqueue-mx set-global
|
||||
! kqueue-mx get-global <mx-port> <mx-task>
|
||||
! dup io-task-fd
|
||||
! [ mx get-global reads>> set-at ]
|
||||
! [ mx get-global writes>> set-at ] 2bi ;
|
||||
|
||||
M: bsd (monitor) ( path recursive? mailbox -- )
|
||||
swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||
<vnode-monitor> ;
|
||||
! M: bsd (monitor) ( path recursive? mailbox -- )
|
||||
! swap [ "Recursive kqueue monitors not supported" throw ] when
|
||||
! <vnode-monitor> ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
USING: alien.c-types kernel io.ports io.unix.backend
|
||||
bit-arrays sequences assocs unix unix.linux.epoll math
|
||||
namespaces structs ;
|
||||
IN: io.unix.epoll
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io.backend io.nonblocking io.unix.backend io.files io
|
||||
USING: io.backend io.ports io.unix.backend io.files io
|
||||
unix unix.stat unix.time kernel math continuations
|
||||
math.bitfields byte-arrays alien combinators calendar
|
||||
io.encodings.binary accessors sequences strings system
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel io.nonblocking io.unix.backend math.bitfields
|
||||
USING: kernel io.ports io.unix.backend math.bitfields
|
||||
unix io.files.unique.backend system ;
|
||||
IN: io.unix.files.unique
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: alien.c-types kernel math math.bitfields namespaces
|
|||
locals accessors combinators threads vectors hashtables
|
||||
sequences assocs continuations sets
|
||||
unix unix.time unix.kqueue unix.process
|
||||
io.nonblocking io.unix.backend io.launcher io.unix.launcher
|
||||
io.ports io.unix.backend io.launcher io.unix.launcher
|
||||
io.monitors ;
|
||||
IN: io.unix.kqueue
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: kernel namespaces math system sequences debugger
|
||||
continuations arrays assocs combinators alien.c-types strings
|
||||
threads accessors
|
||||
io io.backend io.launcher io.nonblocking io.files
|
||||
io io.backend io.launcher io.ports io.files
|
||||
io.files.private io.unix.files io.unix.backend
|
||||
io.unix.launcher.parser
|
||||
unix unix.process ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel io.backend io.monitors io.monitors.recursive
|
||||
io.files io.buffers io.monitors io.nonblocking io.timeouts
|
||||
io.files io.buffers io.monitors io.ports io.timeouts
|
||||
io.unix.backend io.unix.select io.encodings.utf8
|
||||
unix.linux.inotify assocs namespaces threads continuations init
|
||||
math math.bitfields sets alien alien.strings alien.c-types
|
||||
|
|
@ -110,7 +110,7 @@ M: linux-monitor dispose ( monitor -- )
|
|||
] if ;
|
||||
|
||||
: inotify-read-loop ( port -- )
|
||||
dup wait-to-read1
|
||||
dup wait-to-read
|
||||
0 over buffer>> parse-file-notifications
|
||||
0 over buffer>> buffer-reset
|
||||
inotify-read-loop ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: system alien.c-types kernel unix math sequences
|
||||
qualified io.unix.backend io.nonblocking ;
|
||||
qualified io.unix.backend io.ports ;
|
||||
IN: io.unix.pipes
|
||||
QUALIFIED: io.pipes
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel io.nonblocking io.unix.backend
|
||||
USING: alien.c-types kernel io.ports io.unix.backend
|
||||
bit-arrays sequences assocs unix math namespaces structs
|
||||
accessors math.order ;
|
||||
accessors math.order locals ;
|
||||
IN: io.unix.select
|
||||
|
||||
TUPLE: select-mx < mx read-fdset write-fdset ;
|
||||
|
|
@ -21,21 +21,20 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
: clear-nth ( n seq -- ? )
|
||||
[ nth ] [ f -rot set-nth ] 2bi ;
|
||||
|
||||
: check-fd ( fd task fdset mx -- )
|
||||
roll munge rot clear-nth
|
||||
[ swap perform-io-task ] [ 2drop ] if ;
|
||||
:: check-fd ( fd fdset mx quot -- )
|
||||
fd munge fdset clear-nth [ fd mx quot call ] when ; inline
|
||||
|
||||
: check-fdset ( tasks fdset mx -- )
|
||||
[ check-fd ] 2curry assoc-each ;
|
||||
: check-fdset ( fds fdset mx quot -- )
|
||||
[ check-fd ] 3curry each ; inline
|
||||
|
||||
: init-fdset ( tasks fdset -- )
|
||||
[ >r drop t swap munge r> set-nth ] curry assoc-each ;
|
||||
: init-fdset ( fds fdset -- )
|
||||
[ >r t swap munge r> set-nth ] curry each ;
|
||||
|
||||
: read-fdset/tasks
|
||||
[ reads>> ] [ read-fdset>> ] bi ;
|
||||
[ reads>> keys ] [ read-fdset>> ] bi ;
|
||||
|
||||
: write-fdset/tasks
|
||||
[ writes>> ] [ write-fdset>> ] bi ;
|
||||
[ writes>> keys ] [ write-fdset>> ] bi ;
|
||||
|
||||
: max-fd ( assoc -- n )
|
||||
dup assoc-empty? [ drop 0 ] [ keys supremum ] if ;
|
||||
|
|
@ -45,12 +44,13 @@ TUPLE: select-mx < mx read-fdset write-fdset ;
|
|||
|
||||
: init-fdsets ( mx -- nfds read write except )
|
||||
[ num-fds ]
|
||||
[ read-fdset/tasks tuck init-fdset ]
|
||||
[ write-fdset/tasks tuck init-fdset ] tri
|
||||
[ read-fdset/tasks [ init-fdset ] keep ]
|
||||
[ write-fdset/tasks [ init-fdset ] keep ] tri
|
||||
f ;
|
||||
|
||||
M: select-mx wait-for-events ( ms mx -- )
|
||||
swap >r dup init-fdsets r> dup [ make-timeval ] when
|
||||
select multiplexer-error
|
||||
dup read-fdset/tasks pick check-fdset
|
||||
dup write-fdset/tasks rot check-fdset ;
|
||||
M:: select-mx wait-for-events ( ms mx -- )
|
||||
mx
|
||||
[ init-fdsets ms dup [ make-timeval ] when select multiplexer-error ]
|
||||
[ [ read-fdset/tasks ] keep [ input-available ] check-fdset ]
|
||||
[ [ write-fdset/tasks ] keep [ output-available ] check-fdset ]
|
||||
tri ;
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors byte-arrays kernel debugger sequences namespaces math
|
|||
math.order combinators init alien alien.c-types alien.strings libc
|
||||
continuations destructors
|
||||
openssl openssl.libcrypto openssl.libssl
|
||||
io.files io.nonblocking io.unix.backend io.unix.sockets
|
||||
io.files io.ports io.unix.backend io.unix.sockets
|
||||
io.encodings.ascii io.buffers io.sockets io.sockets.secure
|
||||
unix ;
|
||||
IN: io.unix.sockets.secure
|
||||
|
|
@ -16,64 +16,56 @@ IN: io.unix.sockets.secure
|
|||
|
||||
M: ssl-handle handle-fd file>> ;
|
||||
|
||||
: syscall-error ( port r -- )
|
||||
: syscall-error ( port r -- * )
|
||||
ERR_get_error dup zero? [
|
||||
drop
|
||||
{
|
||||
{ -1 [ err_no strerror ] }
|
||||
{ 0 [ "Premature EOF" ] }
|
||||
{ -1 [ (io-error) ] }
|
||||
{ 0 [ "Premature EOF" throw ] }
|
||||
} case
|
||||
] [
|
||||
nip (ssl-error-string)
|
||||
] if swap report-error ;
|
||||
nip (ssl-error)
|
||||
] if ;
|
||||
|
||||
: check-response ( port r -- port r n )
|
||||
over handle>> handle>> over SSL_get_error ; inline
|
||||
|
||||
! Input ports
|
||||
: report-ssl-error ( port r -- )
|
||||
drop ssl-error-string swap report-error ;
|
||||
|
||||
: check-read-response ( port r -- ? )
|
||||
: check-read-response ( port r -- event )
|
||||
check-response
|
||||
{
|
||||
{ SSL_ERROR_NONE [ swap buffer>> n>buffer t ] }
|
||||
{ SSL_ERROR_ZERO_RETURN [ drop reader-eof t ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
|
||||
{ SSL_ERROR_SSL [ report-ssl-error t ] }
|
||||
{ SSL_ERROR_NONE [ swap buffer>> n>buffer f ] }
|
||||
{ SSL_ERROR_ZERO_RETURN [ drop eof f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
M: ssl-handle refill
|
||||
drop
|
||||
dup buffer>> buffer-empty? [
|
||||
dup
|
||||
[ handle>> handle>> ] ! ssl
|
||||
[ buffer>> buffer-end ] ! buf
|
||||
[ buffer>> buffer-capacity ] tri ! len
|
||||
SSL_read
|
||||
check-read-response
|
||||
] [ drop t ] if ;
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer-end ] ! buf
|
||||
[ buffer-capacity ] bi ! len
|
||||
SSL_read
|
||||
check-read-response ;
|
||||
|
||||
! Output ports
|
||||
: check-write-response ( port r -- ? )
|
||||
: check-write-response ( port r -- event )
|
||||
check-response
|
||||
{
|
||||
{ SSL_ERROR_NONE [ swap buffer>> buffer-consume f ] }
|
||||
! { SSL_ERROR_ZERO_RETURN [ drop reader-eof ] } ! XXX
|
||||
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop f ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
|
||||
{ SSL_ERROR_SSL [ report-ssl-error t ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
M: ssl-handle drain
|
||||
drop
|
||||
dup
|
||||
[ handle>> handle>> ] ! ssl
|
||||
[ buffer>> buffer@ ] ! buf
|
||||
[ buffer>> buffer-length ] tri ! len
|
||||
handle>> ! ssl
|
||||
over buffer>>
|
||||
[ buffer@ ] ! buf
|
||||
[ buffer-length ] bi ! len
|
||||
SSL_write
|
||||
check-write-response ;
|
||||
|
||||
|
|
@ -81,17 +73,20 @@ M: ssl-handle drain
|
|||
M: ssl ((client)) ( addrspec -- handle )
|
||||
[ addrspec>> ((client)) <ssl-socket> ] with-destructors ;
|
||||
|
||||
: check-connect-response ( port r -- ? )
|
||||
: check-connect-response ( port r -- event )
|
||||
check-response
|
||||
{
|
||||
{ SSL_ERROR_NONE [ 2drop t ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop f ] } ! XXX
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error t ] }
|
||||
{ SSL_ERROR_SSL [ report-ssl-error t ] }
|
||||
{ SSL_ERROR_NONE [ 2drop f ] }
|
||||
{ SSL_ERROR_WANT_READ [ 2drop +input+ ] }
|
||||
{ SSL_ERROR_WANT_WRITE [ 2drop +output+ ] }
|
||||
{ SSL_ERROR_SYSCALL [ syscall-error ] }
|
||||
{ SSL_ERROR_SSL [ (ssl-error) ] }
|
||||
} case ;
|
||||
|
||||
M: ssl-handle (wait-to-connect)
|
||||
handle>> ! ssl
|
||||
SSL_connect
|
||||
check-connect-response ;
|
||||
: do-ssl-connect ( port ssl -- )
|
||||
2dup SSL_connect check-connect-response dup
|
||||
[ nip wait-for-port ] [ 3drop ] if ;
|
||||
|
||||
M: ssl-handle wait-to-connect
|
||||
[ file>> wait-to-connect ]
|
||||
[ handle>> do-ssl-connect ] 2bi ;
|
||||
|
|
|
|||
|
|
@ -1,11 +1,11 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov, Ivan Tikhonov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings generic kernel math
|
||||
namespaces threads sequences byte-arrays io.nonblocking
|
||||
io.binary io.unix.backend io.streams.duplex io.sockets.impl
|
||||
io.backend io.nonblocking io.files io.files.private
|
||||
namespaces threads sequences byte-arrays io.ports
|
||||
io.binary io.unix.backend io.streams.duplex
|
||||
io.backend io.ports io.files io.files.private
|
||||
io.encodings.utf8 math.parser continuations libc combinators
|
||||
system accessors qualified destructors unix ;
|
||||
system accessors qualified destructors unix locals ;
|
||||
|
||||
EXCLUDE: io => read write close ;
|
||||
EXCLUDE: io.sockets => accept ;
|
||||
|
|
@ -28,23 +28,11 @@ M: unix addrinfo-error ( n -- )
|
|||
: init-client-socket ( fd -- )
|
||||
SOL_SOCKET SO_OOBINLINE sockopt ;
|
||||
|
||||
TUPLE: connect-task < output-task ;
|
||||
|
||||
: <connect-task> ( port continuation -- task )
|
||||
connect-task <io-task> ;
|
||||
|
||||
GENERIC: (wait-to-connect) ( port handle -- ? )
|
||||
: get-socket-name ( fd addrspec -- sockaddr )
|
||||
empty-sockaddr/size [ getsockname io-error ] 2keep drop ;
|
||||
|
||||
M: integer (wait-to-connect)
|
||||
f 0 write 0 < [ defer-error ] [ drop t ] if ;
|
||||
|
||||
M: connect-task do-io-task
|
||||
port>> dup handle>> (wait-to-connect) ;
|
||||
|
||||
M: object wait-to-connect ( client-out fd -- )
|
||||
drop
|
||||
[ <connect-task> add-io-task ] with-port-continuation
|
||||
pending-error ;
|
||||
>r >r +output+ wait-for-port r> r> get-socket-name ;
|
||||
|
||||
M: object ((client)) ( addrspec -- fd )
|
||||
[ protocol-family SOCK_STREAM socket-fd ] [ make-sockaddr/size ] bi
|
||||
|
|
@ -56,49 +44,41 @@ M: object ((client)) ( addrspec -- fd )
|
|||
: init-server-socket ( fd -- )
|
||||
SOL_SOCKET SO_REUSEADDR sockopt ;
|
||||
|
||||
TUPLE: accept-task < input-task ;
|
||||
|
||||
: <accept-task> ( port continuation -- task )
|
||||
accept-task <io-task> ;
|
||||
|
||||
: accept-sockaddr ( port -- fd sockaddr )
|
||||
[ handle>> ] [ addr>> sockaddr-type ] bi
|
||||
dup <c-object> [ swap heap-size <int> accept ] keep ; inline
|
||||
|
||||
: do-accept ( port fd sockaddr -- )
|
||||
swapd over addr>> parse-sockaddr >>client-addr (>>client) ;
|
||||
|
||||
M: accept-task do-io-task
|
||||
io-task-port dup accept-sockaddr
|
||||
over 0 >= [ do-accept t ] [ 2drop defer-error ] if ;
|
||||
|
||||
: wait-to-accept ( server -- )
|
||||
[ <accept-task> add-io-task ] with-port-continuation drop ;
|
||||
|
||||
: server-socket-fd ( addrspec type -- fd )
|
||||
>r dup protocol-family r> socket-fd
|
||||
dup init-server-socket
|
||||
dup rot make-sockaddr/size bind
|
||||
zero? [ dup close (io-error) ] unless ;
|
||||
dup rot make-sockaddr/size bind io-error ;
|
||||
|
||||
M: unix (server) ( addrspec -- handle )
|
||||
M: object (server) ( addrspec -- handle sockaddr )
|
||||
[
|
||||
SOCK_STREAM server-socket-fd
|
||||
dup 10 listen io-error
|
||||
[
|
||||
SOCK_STREAM server-socket-fd
|
||||
dup 10 listen io-error
|
||||
dup
|
||||
] keep
|
||||
get-socket-name
|
||||
] with-destructors ;
|
||||
|
||||
M: unix (accept) ( server -- addrspec handle )
|
||||
#! Wait for a client connection.
|
||||
check-server-port
|
||||
[ wait-to-accept ]
|
||||
[ pending-error ]
|
||||
[ [ client-addr>> ] [ client>> ] bi ] tri ;
|
||||
: do-accept ( server -- fd sockaddr )
|
||||
[ handle>> ] [ addr>> empty-sockaddr/size ] bi
|
||||
[ accept ] 2keep drop ; inline
|
||||
|
||||
M: unix (accept) ( server -- fd sockaddr )
|
||||
dup do-accept
|
||||
{
|
||||
{ [ over 0 >= ] [ rot drop ] }
|
||||
{ [ err_no EINTR = ] [ 2drop do-accept ] }
|
||||
{ [ err_no EAGAIN = ] [
|
||||
2drop
|
||||
[ +input+ wait-for-port ]
|
||||
[ do-accept ] bi
|
||||
] }
|
||||
[ (io-error) ]
|
||||
} cond ;
|
||||
|
||||
! Datagram sockets - UDP and Unix domain
|
||||
M: unix <datagram>
|
||||
[
|
||||
[ SOCK_DGRAM server-socket-fd ] keep <datagram-port>
|
||||
] with-destructors ;
|
||||
M: unix (datagram)
|
||||
[ SOCK_DGRAM server-socket-fd ] with-destructors ;
|
||||
|
||||
SYMBOL: receive-buffer
|
||||
|
||||
|
|
@ -106,76 +86,45 @@ SYMBOL: receive-buffer
|
|||
|
||||
packet-size <byte-array> receive-buffer set-global
|
||||
|
||||
: setup-receive ( port -- s buffer len flags from fromlen )
|
||||
dup port-handle
|
||||
swap datagram-port-addr sockaddr-type
|
||||
dup <c-object> swap heap-size <int>
|
||||
>r >r receive-buffer get-global packet-size 0 r> r> ;
|
||||
:: do-receive ( port -- packet sockaddr )
|
||||
port addr>> empty-sockaddr/size [| sockaddr len |
|
||||
port handle>> ! s
|
||||
receive-buffer get-global ! buf
|
||||
packet-size ! nbytes
|
||||
0 ! flags
|
||||
sockaddr ! from
|
||||
len ! fromlen
|
||||
recvfrom dup 0 >= [
|
||||
receive-buffer get-global swap head sockaddr
|
||||
] [
|
||||
drop f f
|
||||
] if
|
||||
] call ;
|
||||
|
||||
: do-receive ( s buffer len flags from fromlen -- sockaddr data )
|
||||
over >r recvfrom r>
|
||||
over -1 = [
|
||||
2drop f f
|
||||
] [
|
||||
receive-buffer get-global
|
||||
rot head
|
||||
M: unix (receive) ( datagram -- packet sockaddr )
|
||||
dup do-receive dup [ rot drop ] [
|
||||
2drop [ +input+ wait-for-port ] [ (receive) ] bi
|
||||
] if ;
|
||||
|
||||
TUPLE: receive-task < input-task ;
|
||||
:: do-send ( packet sockaddr len socket datagram -- )
|
||||
socket packet dup length 0 sockaddr len sendto
|
||||
0 < [
|
||||
err_no EINTR = [
|
||||
packet sockaddr len socket datagram do-send
|
||||
] [
|
||||
err_no EAGAIN = [
|
||||
datagram +output+ wait-for-port
|
||||
packet sockaddr len socket datagram do-send
|
||||
] [
|
||||
(io-error)
|
||||
] if
|
||||
] if
|
||||
] when ;
|
||||
|
||||
: <receive-task> ( stream continuation -- task )
|
||||
receive-task <io-task> ;
|
||||
|
||||
M: receive-task do-io-task
|
||||
io-task-port
|
||||
dup setup-receive do-receive dup [
|
||||
pick set-datagram-port-packet
|
||||
over datagram-port-addr parse-sockaddr
|
||||
swap set-datagram-port-packet-addr
|
||||
t
|
||||
] [
|
||||
2drop defer-error
|
||||
] if ;
|
||||
|
||||
: wait-receive ( stream -- )
|
||||
[ <receive-task> add-io-task ] with-port-continuation drop ;
|
||||
|
||||
M: unix receive ( datagram -- packet addrspec )
|
||||
check-datagram-port
|
||||
[ wait-receive ]
|
||||
[ pending-error ]
|
||||
[ [ packet>> ] [ packet-addr>> ] bi ] tri ;
|
||||
|
||||
: do-send ( socket data sockaddr len -- n )
|
||||
>r >r dup length 0 r> r> sendto ;
|
||||
|
||||
TUPLE: send-task < output-task packet sockaddr len ;
|
||||
|
||||
: <send-task> ( packet sockaddr len stream continuation -- task )
|
||||
send-task <io-task> [
|
||||
{
|
||||
set-send-task-packet
|
||||
set-send-task-sockaddr
|
||||
set-send-task-len
|
||||
} set-slots
|
||||
] keep ;
|
||||
|
||||
M: send-task do-io-task
|
||||
[ io-task-port port-handle ] keep
|
||||
[ send-task-packet ] keep
|
||||
[ send-task-sockaddr ] keep
|
||||
[ send-task-len do-send ] keep
|
||||
swap 0 < [ io-task-port defer-error ] [ drop t ] if ;
|
||||
|
||||
: wait-send ( packet sockaddr len stream -- )
|
||||
[ <send-task> add-io-task ] with-port-continuation
|
||||
2drop 2drop ;
|
||||
|
||||
M: unix send ( packet addrspec datagram -- )
|
||||
check-datagram-send
|
||||
[ >r make-sockaddr/size r> wait-send ] keep
|
||||
pending-error ;
|
||||
M: unix (send) ( packet addrspec datagram -- )
|
||||
[ make-sockaddr/size ] [ [ handle>> ] keep ] bi* do-send ;
|
||||
|
||||
! Unix domain sockets
|
||||
M: local protocol-family drop PF_UNIX ;
|
||||
|
||||
M: local sockaddr-type drop "sockaddr-un" c-type ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: io.nonblocking io.windows threads.private kernel
|
||||
USING: io.ports io.windows threads.private kernel
|
||||
io.backend windows.winsock windows.kernel32 windows
|
||||
io.streams.duplex io namespaces alien.syntax system combinators
|
||||
io.buffers io.encodings io.encodings.utf8 combinators.lib ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types combinators io io.backend io.buffers
|
||||
io.files io.nonblocking io.windows kernel libc math namespaces
|
||||
io.files io.ports io.windows kernel libc math namespaces
|
||||
prettyprint sequences strings threads threads.private
|
||||
windows windows.kernel32 io.windows.ce.backend system ;
|
||||
IN: windows.ce.files
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types combinators io io.backend io.buffers
|
||||
io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
|
||||
io.ports io.sockets io.windows kernel libc
|
||||
math namespaces prettyprint qualified sequences strings threads
|
||||
threads.private windows windows.kernel32 io.windows.ce.backend
|
||||
byte-arrays system ;
|
||||
|
|
@ -41,7 +41,6 @@ M: wince (server) ( addrspec -- handle )
|
|||
|
||||
M: wince (accept) ( server -- client )
|
||||
[
|
||||
dup check-server-port
|
||||
[
|
||||
dup port-handle win32-file-handle
|
||||
swap server-port-addr sockaddr-type heap-size
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien.c-types io.backend io.files io.windows kernel math
|
||||
windows windows.kernel32 windows.time calendar combinators
|
||||
math.functions sequences namespaces words symbols system
|
||||
combinators.lib io.nonblocking destructors math.bitfields.lib ;
|
||||
combinators.lib io.ports destructors math.bitfields.lib ;
|
||||
IN: io.windows.files
|
||||
|
||||
SYMBOLS: +read-only+ +hidden+ +system+
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: kernel system io.files.unique.backend
|
||||
windows.kernel32 io.windows io.nonblocking windows ;
|
||||
windows.kernel32 io.windows io.ports windows ;
|
||||
IN: io.windows.files.unique
|
||||
|
||||
M: windows (make-unique-file) ( path -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations io
|
||||
io.windows io.windows.nt.pipes libc io.nonblocking
|
||||
io.windows io.windows.nt.pipes libc io.ports
|
||||
windows.types math windows.kernel32
|
||||
namespaces io.launcher kernel sequences windows.errors
|
||||
splitting system threads init strings combinators
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types alien.syntax arrays continuations
|
||||
destructors generic io.mmap io.nonblocking io.windows
|
||||
destructors generic io.mmap io.ports io.windows
|
||||
kernel libc math namespaces quotations sequences windows
|
||||
windows.advapi32 windows.kernel32 io.backend system ;
|
||||
IN: io.windows.mmap
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: alien alien.c-types arrays assocs combinators
|
||||
continuations destructors io io.backend io.nonblocking
|
||||
continuations destructors io io.backend io.ports
|
||||
io.windows libc kernel math namespaces sequences
|
||||
threads classes.tuple.lib windows windows.errors
|
||||
windows.kernel32 strings splitting io.files qualified ascii
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: continuations destructors io.buffers io.files io.backend
|
||||
io.timeouts io.nonblocking io.windows io.windows.nt.backend
|
||||
io.timeouts io.ports io.windows io.windows.nt.backend
|
||||
kernel libc math threads windows windows.kernel32 system
|
||||
alien.c-types alien.arrays alien.strings sequences combinators
|
||||
combinators.lib sequences.lib ascii splitting alien strings
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays continuations destructors io
|
||||
io.windows libc io.nonblocking io.pipes windows.types
|
||||
io.windows libc io.ports io.pipes windows.types
|
||||
math windows.kernel32 windows namespaces io.launcher kernel
|
||||
sequences windows.errors assocs splitting system strings
|
||||
io.windows.launcher io.windows.nt.pipes io.backend io.files
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ kernel math assocs namespaces continuations sequences hashtables
|
|||
sorting arrays combinators math.bitfields strings system
|
||||
accessors threads splitting
|
||||
io.backend io.windows io.windows.nt.backend io.windows.nt.files
|
||||
io.monitors io.nonblocking io.buffers io.files io.timeouts io
|
||||
io.monitors io.ports io.buffers io.files io.timeouts io
|
||||
windows windows.kernel32 windows.types ;
|
||||
IN: io.windows.nt.monitors
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: alien alien.c-types arrays destructors io io.windows libc
|
||||
windows.types math.bitfields windows.kernel32 windows namespaces
|
||||
kernel sequences windows.errors assocs math.parser system random
|
||||
combinators accessors io.pipes io.nonblocking ;
|
||||
combinators accessors io.pipes io.ports ;
|
||||
IN: io.windows.nt.pipes
|
||||
|
||||
! This code is based on
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.accessors alien.c-types byte-arrays
|
||||
continuations destructors io.nonblocking io.timeouts io.sockets
|
||||
io.sockets.impl io namespaces io.streams.duplex io.windows
|
||||
continuations destructors io.ports io.timeouts io.sockets
|
||||
io.sockets io namespaces io.streams.duplex io.windows
|
||||
io.windows.nt.backend windows.winsock kernel libc math sequences
|
||||
threads classes.tuple.lib system accessors ;
|
||||
IN: io.windows.nt.sockets
|
||||
|
|
@ -125,7 +125,6 @@ TUPLE: AcceptEx-args port
|
|||
M: winnt (accept) ( server -- addrspec handle )
|
||||
[
|
||||
[
|
||||
check-server-port
|
||||
\ AcceptEx-args new
|
||||
[ init-accept ] keep
|
||||
[ ((accept)) ] keep
|
||||
|
|
@ -141,13 +140,11 @@ M: winnt (server) ( addrspec -- handle )
|
|||
f <win32-socket>
|
||||
] with-destructors ;
|
||||
|
||||
M: winnt <datagram> ( addrspec -- datagram )
|
||||
M: winnt (datagram) ( addrspec -- handle )
|
||||
[
|
||||
[
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
] keep <datagram-port>
|
||||
SOCK_DGRAM server-fd
|
||||
dup add-completion
|
||||
f <win32-socket>
|
||||
] with-destructors ;
|
||||
|
||||
TUPLE: WSARecvFrom-args port
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2004, 2008 Mackenzie Straight, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays destructors io io.backend
|
||||
io.buffers io.files io.nonblocking io.sockets io.binary
|
||||
io.sockets.impl windows.errors strings
|
||||
io.buffers io.files io.ports io.sockets io.binary
|
||||
io.sockets windows.errors strings
|
||||
kernel math namespaces sequences windows windows.kernel32
|
||||
windows.shell32 windows.types windows.winsock splitting
|
||||
continuations math.bitfields system accessors ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ math.order combinators init alien alien.c-types alien.strings libc
|
|||
continuations destructors debugger inspector
|
||||
locals unicode.case
|
||||
openssl.libcrypto openssl.libssl
|
||||
io.nonblocking io.files io.encodings.ascii io.sockets.secure ;
|
||||
io.ports io.files io.encodings.ascii io.sockets.secure ;
|
||||
IN: openssl
|
||||
|
||||
! This code is based on http://www.rtfm.com/openssl-examples/
|
||||
|
|
@ -25,8 +25,11 @@ M: TLSv1 ssl-method drop TLSv1_method ;
|
|||
: ssl-error-string ( -- string )
|
||||
ERR_get_error ERR_clear_error f ERR_error_string ;
|
||||
|
||||
: (ssl-error) ( -- * )
|
||||
ssl-error-string throw ;
|
||||
|
||||
: ssl-error ( obj -- )
|
||||
{ f 0 } member? [ ssl-error-string throw ] when ;
|
||||
{ f 0 } member? [ (ssl-error) ] when ;
|
||||
|
||||
: init-ssl ( -- )
|
||||
SSL_library_init ssl-error
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: alien.c-types io io.files io.nonblocking kernel
|
||||
USING: alien.c-types io io.files io.ports kernel
|
||||
namespaces random io.encodings.binary init
|
||||
accessors system ;
|
||||
IN: random.unix
|
||||
|
|
|
|||
|
|
@ -133,7 +133,7 @@ IN: tools.deploy.shaker
|
|||
|
||||
[
|
||||
io.backend:io-backend ,
|
||||
"default-buffer-size" "io.nonblocking" lookup ,
|
||||
"default-buffer-size" "io.ports" lookup ,
|
||||
] { } make
|
||||
{ "alarms" "io" "tools" } strip-vocab-globals %
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,6 @@
|
|||
|
||||
USING: kernel alien alien.c-types
|
||||
io.sockets
|
||||
io.sockets.impl
|
||||
unix
|
||||
unix.linux.sockios
|
||||
unix.linux.if ;
|
||||
|
|
|
|||
|
|
@ -42,7 +42,7 @@ C-STRUCT: struct-rtentry
|
|||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
USING: kernel alien.c-types io.sockets io.sockets.impl
|
||||
USING: kernel alien.c-types io.sockets
|
||||
unix unix.linux.sockios ;
|
||||
|
||||
: route ( dst gateway genmask flags -- )
|
||||
|
|
|
|||
Loading…
Reference in New Issue