/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^+ (cast i2 uInt)*256^+ (cast i3 uInt)*256 + (cast i4 uInt) 
 55    else 
 56      return failure:"Failed to parse IP address" 
 57    var Int := 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 buf size 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 := shunt first timeout timeout-(datetime:seconds-start:seconds) 
 96      if (not first and t<0.001) or (os_socket_wait 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 buf reserved 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^4) 
 123      if status=success 
 124        return 
 125   
 126   
 127  export net_ping