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().

basis/io/sockets/icmp/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

basis/io/sockets/icmp/icmp-docs.factor

@@ -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"
+

basis/io/sockets/icmp/icmp-tests.factor

@@ -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

basis/io/sockets/icmp/icmp.factor

@@ -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 ;

basis/io/sockets/icmp/summary.txt

@@ -0,0 +1 @@
+Support for ICMP.

basis/io/sockets/sockets.factor

@@ -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 )

basis/io/sockets/unix/unix.factor

@@ -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 ;
 

basis/io/sockets/windows/windows.factor

@@ -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 ;
 

basis/unix/ffi/ffi.factor

@@ -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 ) ;

basis/windows/winsock/winsock.factor

@@ -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

extra/ping/authors.txt

@@ -0,0 +1 @@
+John Benediktsson

extra/ping/ping-tests.factor

@@ -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

extra/ping/ping.factor

@@ -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 ;
+
+

extra/ping/summary.txt

@@ -0,0 +1 @@
+Uses ICMP to test the reachability of a network host.