Permalink
Browse files

Squashed commit of the following:

commit 90deaafa9db083ecdb9e0e30ad3694317e616399
Merge: f392dfd 32cf7bb
Author: Doug Coleman <doug.coleman@gmail.com>
Date:   Tue Sep 21 00:33:37 2010 -0500

    Merge branch 'icmp-ping' of git://github.com/mrjbq7/factor into icmp-ping2

commit 32cf7bb0e0b876309bce248944dfeca243f02594
Author: John Benediktsson <mrjbq7@gmail.com>
Date:   Fri Sep 10 14:01:47 2010 -0700

    ping: Adding a simple IPv4 ping implementation.

commit da0c5ce7acf1407256c3ac2b98ac5b68858878c1
Author: John Benediktsson <mrjbq7@gmail.com>
Date:   Fri Sep 10 14:01:15 2010 -0700

    io.sockets.icmp: Adding ICMP support.

commit 60fdf7e7d995d63c11be87e8e1398f7bdd593833
Author: John Benediktsson <mrjbq7@gmail.com>
Date:   Fri Sep 10 14:00:48 2010 -0700

    io.sockets: Adding protocol support for sockets.

commit 2f130f1f9e0e2ea44d798beaad244a9c33b0d86a
Author: John Benediktsson <mrjbq7@gmail.com>
Date:   Fri Sep 10 14:00:28 2010 -0700

    Adding getprotobyname().
  • Loading branch information...
erg committed Sep 21, 2010
1 parent f392dfd commit a58278d0a33ef1227ed796d8772df4a84496d5a7
@@ -0,0 +1 @@
John Benediktsson
@@ -0,0 +1,85 @@
USING: help.markup help.syntax io.sockets ;
IN: io.sockets.icmp
HELP: icmp
{ $class-description
"Host name specifier for ICMP. "
"The " { $snippet "host" } " slot holds the host name. "
"New instances are created by calling " { $link <icmp> } "." }
{ $notes
"This address specifier can be used with " { $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."
}
{ $examples
{ $code "\"www.apple.com\" <icmp>" }
} ;
HELP: <icmp>
{ $values { "host" "a host name" } { "icmp" icmp } }
{ $description "Creates a new " { $link icmp } " address specifier." } ;
HELP: icmp4
{ $class-description
"IPv4 address specifier for ICMP. "
"The " { $snippet "host" } " slot holds the IPv4 address. "
"New instances are created by calling " { $link <icmp4> } "."
}
{ $notes
"Most applications do not operate on IPv4 addresses directly, "
"and instead should use the " { $link icmp }
" address specifier, or call " { $link resolve-host } "."
}
{ $examples
{ $code "\"127.0.0.1\" <icmp4>" }
} ;
HELP: <icmp4>
{ $values { "host" "an IPv4 address" } { "icmp4" icmp4 } }
{ $description "Creates a new " { $link icmp4 } " address specifier." } ;
HELP: icmp6
{ $class-description
"IPv6 address specifier for ICMP. "
"The " { $snippet "host" } " slot holds the IPv6 address. "
"New instances are created by calling " { $link <icmp6> } "."
}
{ $notes
"Most applications do not operate on IPv6 addresses directly, "
"and instead should use the " { $link icmp }
" address specifier, or call " { $link resolve-host } "."
}
{ $examples
{ $code "\"::1\" <icmp6>" }
} ;
HELP: <icmp6>
{ $values { "host" "an IPv6 address" } { "icmp6" icmp4 } }
{ $description "Creates a new " { $link icmp6 } " address specifier." } ;
ARTICLE: "network-icmp" "ICMP"
"ICMP support is implemented for both IPv4 and IPv6 addresses, using the "
"operating system's host name resolution (via " { $link resolve-host } "):"
{ $subsections
icmp
<icmp>
}
"IPv4 addresses, with no host name resolution:"
{ $subsections
icmp4
<icmp4>
}
"IPv6 addresses, with no host name resolution:"
{ $subsections
icmp6
<icmp6>
} ;
ABOUT: "network-icmp"
@@ -0,0 +1,15 @@
USING: accessors destructors kernel io.sockets io.sockets.icmp
sequences tools.test ;
IN: io.sockets.icmp.tests
[ { } ] [
"localhost" <icmp> resolve-host
[ [ icmp4? ] [ icmp6? ] bi or not ] filter
] unit-test
[ t ] [
"127.0.0.1" <icmp4> <datagram>
[ addr>> icmp4? ] with-disposal
] unit-test
@@ -0,0 +1,61 @@
! Copyright (C) 2010 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors arrays combinators generic kernel io.sockets
io.sockets.private memoize sequences system vocabs.parser ;
IN: io.sockets.icmp
<< {
{ [ os windows? ] [ "windows.winsock" ] }
{ [ os unix? ] [ "unix.ffi" ] }
} cond use-vocab >>
<PRIVATE
MEMO: IPPROTO_ICMP4 ( -- protocol )
"icmp" getprotobyname proto>> ;
MEMO: IPPROTO_ICMP6 ( -- protocol )
"ipv6-icmp" getprotobyname proto>> ;
GENERIC: with-icmp ( addrspec -- addrspec )
PRIVATE>
TUPLE: icmp4 < ipv4 ;
C: <icmp4> icmp4
M: ipv4 with-icmp host>> <icmp4> ;
M: icmp4 protocol drop IPPROTO_ICMP4 ;
M: icmp4 port>> drop 0 ;
M: icmp4 parse-sockaddr call-next-method with-icmp ;
M: icmp4 resolve-host 1array ;
TUPLE: icmp6 < ipv6 ;
C: <icmp6> icmp6
M: ipv6 with-icmp host>> <icmp6> ;
M: icmp6 protocol drop IPPROTO_ICMP6 ;
M: icmp6 port>> drop 0 ;
M: icmp6 parse-sockaddr call-next-method with-icmp ;
M: icmp6 resolve-host 1array ;
TUPLE: icmp < hostname ;
C: <icmp> icmp
M: icmp resolve-host call-next-method [ with-icmp ] map ;
@@ -0,0 +1 @@
Support for ICMP.
@@ -19,6 +19,8 @@ IN: io.sockets
UNION: ?string string POSTPONE: f ;
GENERIC: protocol ( addrspec -- n )
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
@@ -58,6 +60,8 @@ TUPLE: local { path read-only } ;
M: local present path>> "Unix domain socket: " prepend ;
M: local protocol drop 0 ;
SLOT: port
TUPLE: ipv4 { host ?string read-only } ;
@@ -117,6 +121,8 @@ M: inet4 parse-sockaddr ( sockaddr-in addrspec -- newaddrspec )
M: inet4 present
[ host>> ] [ port>> number>string ] bi ":" glue ;
M: inet4 protocol drop 0 ;
TUPLE: ipv6 { host ?string read-only } ;
C: <ipv6> ipv6
@@ -194,6 +200,8 @@ M: inet6 parse-sockaddr
M: inet6 present
[ host>> ] [ port>> number>string ] bi ":" glue ;
M: inet6 protocol drop 0 ;
<PRIVATE
GENERIC: (get-local-address) ( handle remote -- sockaddr )
@@ -13,8 +13,8 @@ EXCLUDE: io.sockets => accept ;
IN: io.sockets.unix
: socket-fd ( domain type -- fd )
0 socket dup io-error <fd> init-fd |dispose ;
: socket-fd ( domain type protocol -- fd )
socket dup io-error <fd> init-fd |dispose ;
: set-socket-option ( fd level opt -- )
[ handle-fd ] 2dip 1 <int> dup byte-length setsockopt io-error ;
@@ -83,15 +83,15 @@ M:: object establish-connection ( client-out remote -- )
] if* ; inline
M: object ((client)) ( addrspec -- fd )
protocol-family SOCK_STREAM socket-fd
[ protocol-family SOCK_STREAM ] [ protocol ] bi socket-fd
[ init-client-socket ] [ ?bind-client ] [ ] tri ;
! Server sockets - TCP and Unix domain
: init-server-socket ( fd -- )
SOL_SOCKET SO_REUSEADDR set-socket-option ;
: server-socket-fd ( addrspec type -- fd )
[ dup protocol-family ] dip socket-fd
[ dup protocol-family ] dip pick protocol socket-fd
[ init-server-socket ] keep
[ handle-fd swap make-sockaddr/size [ bind ] unix-system-call drop ] keep ;
@@ -41,8 +41,8 @@ M: win32-socket dispose* ( stream -- )
<win32-socket> |dispose add-completion ;
: open-socket ( addrspec type -- win32-socket )
[ protocol-family ] dip
0 f 0 WSASocket-flags WSASocket
[ drop protocol-family ] [ swap protocol ] 2bi
f 0 WSASocket-flags WSASocket
dup socket-error
opened-socket ;
@@ -52,6 +52,11 @@ STRUCT: group
{ gr_gid int }
{ gr_mem c-string* } ;
STRUCT: protoent
{ name c-string }
{ aliases void* }
{ proto int } ;
FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ;
FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ;
FUNCTION: int chdir ( c-string path ) ;
@@ -100,6 +105,7 @@ FUNCTION: void endgrent ( ) ;
FUNCTION: int gethostname ( c-string name, int len ) ;
FUNCTION: int getsockname ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: int getpeername ( int socket, sockaddr* address, socklen_t* address_len ) ;
FUNCTION: protoent* getprotobyname ( c-string name ) ;
FUNCTION: uid_t getuid ;
FUNCTION: uint htonl ( uint n ) ;
FUNCTION: ushort htons ( ushort n ) ;
@@ -126,6 +126,11 @@ STRUCT: hostent
{ length short }
{ addr-list void* } ;
STRUCT: protoent
{ name c-string }
{ aliases void* }
{ proto short } ;
STRUCT: addrinfo
{ flags int }
{ family int }
@@ -171,6 +176,8 @@ FUNCTION: int recv ( SOCKET s, c-string buf, int len, int flags ) ;
FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ;
FUNCTION: protoent* getprotobyname ( c-string name ) ;
TYPEDEF: uint SERVICETYPE
TYPEDEF: OVERLAPPED WSAOVERLAPPED
TYPEDEF: WSAOVERLAPPED* LPWSAOVERLAPPED
View
@@ -0,0 +1 @@
John Benediktsson
@@ -0,0 +1,8 @@
USING: ping tools.test ;
IN: ping.tests
[ t ] [ "localhost" alive? ] unit-test
[ t ] [ "127.0.0.1" alive? ] unit-test
[ f ] [ "0.0.0.0" alive? ] unit-test
View
@@ -0,0 +1,55 @@
! Copyright (C) 2010 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
USING: accessors byte-arrays calendar checksums
checksums.internet combinators combinators.smart continuations
destructors io.sockets io.sockets.icmp io.timeouts kernel pack
random sequences ;
IN: ping
<PRIVATE
TUPLE: echo type identifier sequence data ;
: <echo> ( sequence data -- echo )
[ 8 16 random-bits ] 2dip echo boa ;
: echo>byte-array ( echo -- byte-array )
[
[
[ type>> 0 0 ] ! code checksum
[ identifier>> ]
[ sequence>> ] tri
] output>array "CCSSS" pack-be
] [ data>> ] bi append [
internet checksum-bytes 2 4
] keep replace-slice ;
: byte-array>echo ( byte-array -- echo )
dup internet checksum-bytes B{ 0 0 } assert=
8 cut [
"CCSSS" unpack-be { 0 3 4 } swap nths first3
] dip echo boa ;
: send-ping ( addr datagram -- )
[ 0 { } <echo> echo>byte-array ] 2dip send ;
: recv-ping ( datagram -- echo )
receive drop 20 tail byte-array>echo ;
PRIVATE>
: ping ( host -- reply )
<icmp> resolve-host [ icmp4? ] filter random
f <icmp4> <datagram>
1 seconds over set-timeout
[ [ send-ping ] [ recv-ping ] bi ] with-disposal ;
: local-ping ( -- reply )
"127.0.0.1" ping ;
: alive? ( host -- ? )
[ ping drop t ] [ 2drop f ] recover ;
View
@@ -0,0 +1 @@
Uses ICMP to test the reachability of a network host.

0 comments on commit a58278d

Please sign in to comment.