--- /dev/null
+John Benediktsson
--- /dev/null
+
+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"
+
--- /dev/null
+
+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
--- /dev/null
+! 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 ;
--- /dev/null
+Support for ICMP.
UNION: ?string string POSTPONE: f ;
+GENERIC: protocol ( addrspec -- n )
+
GENERIC: protocol-family ( addrspec -- af )
GENERIC: sockaddr-size ( addrspec -- n )
M: local present path>> "Unix domain socket: " prepend ;
+M: local protocol drop 0 ;
+
SLOT: port
TUPLE: ipv4 { host ?string read-only } ;
M: inet4 present
[ host>> ] [ port>> number>string ] bi ":" glue ;
+M: inet4 protocol drop 0 ;
+
TUPLE: ipv6 { host ?string read-only } ;
C: <ipv6> ipv6
M: inet6 present
[ host>> ] [ port>> number>string ] bi ":" glue ;
+M: inet6 protocol drop 0 ;
+
<PRIVATE
GENERIC: (get-local-address) ( handle remote -- sockaddr )
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 ;
] 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
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 ;
<win32-socket> |dispose add-completion ;\r
\r
: open-socket ( addrspec type -- win32-socket )\r
- [ protocol-family ] dip\r
- 0 f 0 WSASocket-flags WSASocket\r
+ [ drop protocol-family ] [ swap protocol ] 2bi\r
+ f 0 WSASocket-flags WSASocket\r
dup socket-error\r
opened-socket ;\r
\r
{ 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 ) ;
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 ) ;
{ length short }
{ addr-list void* } ;
+STRUCT: protoent
+ { name c-string }
+ { aliases void* }
+ { proto short } ;
+
STRUCT: addrinfo
{ flags int }
{ family int }
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
--- /dev/null
+John Benediktsson
--- /dev/null
+
+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
--- /dev/null
+! 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 ;
+
+
--- /dev/null
+Uses ICMP to test the reachability of a network host.
projects / factor.git / commitdiff