/pliant/util/network/ping.pli
1	# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
2	#
3	# This program is free software; you can redistribute it and/or
4	# modify it under the terms of the GNU General Public License version 2
5	# as published by the Free Software Foundation.
6	#
7	# This program is distributed in the hope that it will be useful,
8	# but WITHOUT ANY WARRANTY; without even the implied warranty of
9	# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
10	# GNU General Public License for more details.
11	#
12	# You should have received a copy of the GNU General Public License
13	# version 2 along with this program; if not, write to the Free Software
14	# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
15
16	module "/pliant/language/unsafe.pli"
17	module "/pliant/language/os.pli"
18	module "/pliant/language/os/socket.pli"
19	module "/pliant/language/stream.pli"
20
21
22	constant verbose false
23
24
25	constant os_ICMP_ECHO 8
26	constant os_ICMP_ECHOREPLY 0
27
28	type os_icmphdr
29	field uInt8 type code
30	field uInt16_hi checksum
31	field uInt16_hi id
32	field uInt16_hi sequence
33
34	function in_checksum buf size -> sum
35	arg Address buf ; arg Int size sum
36	sum := 0
37	var Int offset := 0
38	while offset+2<=size
39	sum += (buf translate Byte offset) map uInt16_hi
40	offset += 2
41	if offset<size
42	sum += (buf translate Byte offset) map uInt8
43	sum := sum\2^16+sum%2^16
44	sum += sum\2^16
45	sum := .not. sum
46
47	gvar Sem icmp_sem
48	gvar uInt icmp_counter := 0
49
50	function net_ping hostname message timeout -> status
51	arg Str hostname ; arg Str message ; arg Float timeout ; arg ExtendedStatus status
52	var Str ip := dns_query_prototype hostname dns_query_function
53	if (ip parse (var Int i1) "." (var Int i2) "." (var Int i3) "." (var Int i4))
54	var uInt ipaddress := (cast i1 uInt)*256^3 + (cast i2 uInt)*256^2 + (cast i3 uInt)*256 + (cast i4 uInt)
55	else
56	return failure:"Failed to parse IP address"
57	var Int s := os_socket os_AF_INET os_SOCK_RAW 1
58	if s<0
59	# not 'root' under Unix, try TCP connection to HTTP port instead
60	(var Stream tcp) open "tcp://"+ip+"/client/80" "timeout "+string:timeout in+out+safe
61	return (shunt tcp=success success failure:"Failed to open TCP port 80")
62
63	var Int reserved := 512+message:len
64	var Address buf := memory_allocate reserved null
65	var Int size := os_icmphdr:size+message:len
66	memory_copy message:characters (buf translate os_icmphdr 1) message:len
67
68	var Pointer:os_icmphdr icp :> buf map os_icmphdr
69	icp type := os_ICMP_ECHO
70	icp code := 0
71	icp checksum := 0
72	icmp_sem request
73	var Int sequence := icmp_counter .and. 0FFFFh ; icmp_counter := icmp_counter .+. 1
74	icmp_sem release
75	icp sequence := sequence
76	var Int id := os_getpid .and. 0FFFFh
77	icp id := id
78	icp checksum := in_checksum buf size
79
80	var os_sockaddr_in addr
81	addr sin_family := os_AF_INET
82	addr sin_port := 0
83	addr sin_addr := ipaddress
84
85	var Int err := os_sendto s buf size 0 addr os_sockaddr_in:size
86	if err<>size
87	memory_free buf
88	return (failure "Failed to send ("+string:err+")")
89
90	if verbose
91	var DateTime start := datetime
92
93	var DateTime start := datetime ; var CBool first := true
94	part wait_for_reply
95	var Float t := shunt first timeout timeout-(datetime:seconds-start:seconds)
96	if (not first and t<0.001) or (os_socket_wait s 1 t)=failure
97	status := failure "No reply"
98	leave wait_for_reply
99	first := false
100	var Int len := os_sockaddr_in size
101	var Int size := os_recvfrom s buf reserved 0 addr len
102	if size<1
103	restart wait_for_reply
104	var Int hl := (buf map uInt8)%16*4
105	if size<hl+os_icmphdr:size
106	restart wait_for_reply
107	var Pointer:os_icmphdr icp :> (buf translate Byte hl) map os_icmphdr
108	if icp:type<>os_ICMP_ECHOREPLY or icp:id<>id or icp:sequence<>sequence
109	restart wait_for_reply
110	(var Str answer) set (addressof:icp translate os_icmphdr 1) size-hl-os_icmphdr:size false
111	status := shunt answer=message success failure:"Corrupted answer"
112
113	os_close s
114	memory_free buf
115	if verbose and status=success
116	console hostname " is alive (" (cast (datetime:seconds-start:seconds)*1000 Int) " ms)" eol
117
118	function net_ping hostname -> status
119	arg Str hostname ; arg ExtendedStatus status
120	var Str message := "Pliant ping test on "+string:datetime
121	for (var Int i) 0 4
122	status := net_ping hostname "Pliant ping utility." (min 2^i 4)
123	if status=success
124	return
125
126
127	export net_ping