Patch title: Release 85 bulk changes
Abstract:
File: /pliant/util/network/ping.pli
Key:
    Removed line
    Added line
# Copyright  Hubert Tonneau  hubert.tonneau@pliant.cx
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License version 2
# as published by the Free Software Foundation.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# version 2 along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

module "/pliant/language/unsafe.pli"
module "/pliant/language/os.pli"
module "/pliant/language/os/socket.pli"
module "/pliant/language/stream.pli"


constant verbose false


constant os_ICMP_ECHO 8
constant os_ICMP_ECHOREPLY 0

type os_icmphdr
  field uInt8 type code
  field uInt16_hi checksum
  field uInt16_hi id
  field uInt16_hi sequence

function in_checksum buf size -> sum
  arg Address buf ; arg Int size sum
  sum := 0
  var Int offset := 0
  while offset+2<=size
    sum += (buf translate Byte offset) map uInt16_hi
    offset += 2
  if offset<size
    sum += (buf translate Byte offset) map uInt8
  sum := sum\2^16+sum%2^16
  sum += sum\2^16
  sum := .not. sum

gvar Sem icmp_sem
gvar uInt icmp_counter := 0

function net_ping hostname message timeout -> status
  arg Str hostname ; arg Str message ; arg Float timeout ; arg Status status
  arg Str hostname ; arg Str message ; arg Float timeout ; arg ExtendedStatus status
  var Str ip := dns_query_prototype hostname dns_query_function
  if (ip parse (var Int i1) "." (var Int i2) "." (var Int i3) "." (var Int i4))
    var uInt ipaddress := (cast i1 uInt)*256^3 + (cast i2 uInt)*256^2 + (cast i3 uInt)*256 + (cast i4 uInt)
  else
    return failure
    return failure:"Failed to parse IP address"
  var Int s := os_socket os_AF_INET os_SOCK_RAW 1
  if s<0
    # not 'root' under Unix, try TCP connection to HTTP port instead
    (var Stream tcp) open "tcp://"+ip+"/client/80" in+out+safe
    return (shunt tcp=success success failure)
    return (shunt tcp=success success failure:"Failed to open TCP port 80")
  
  var Int reserved := 512+message:len
  var Address buf := memory_allocate reserved null
  var Int size := os_icmphdr:size+message:len
  memory_copy message:characters (buf translate os_icmphdr 1) message:len

  var Pointer:os_icmphdr icp :> buf map os_icmphdr
  icp type := os_ICMP_ECHO
  icp code := 0
  icp checksum := 0
  icmp_sem request
  var Int sequence := icmp_counter .and. 0FFFFh ; icmp_counter := icmp_counter .+. 1
  icmp_sem release
  icp sequence := sequence
  var Int id := os_getpid .and. 0FFFFh
  icp id := id
  icp checksum := in_checksum buf size

  var os_sockaddr_in addr
  addr sin_family := os_AF_INET
  addr sin_port := 0
  addr sin_addr := ipaddress

  if (os_sendto s buf size 0 addr os_sockaddr_in:size)<>size 
  var Int err := os_sendto s buf size 0 addr os_sockaddr_in:size
  if err<>size 
    memory_free buf
    return failure
    return (failure "Failed to send ("+string:err+")")

  if verbose
    var DateTime start := datetime
    
  var DateTime start := datetime ; var CBool first := true
  part wait_for_reply
    var Float t := shunt first timeout timeout-(datetime:seconds-start:seconds)
    if (not first and t<0.001) or (os_socket_wait s 1 t)=failure
      status := failure
      status := failure "No reply"
      leave wait_for_reply
    first := false
    var Int len := os_sockaddr_in size
    var Int size := os_recvfrom s buf reserved 0 addr len
    if size<1
      restart wait_for_reply
    var Int hl := (buf map uInt8)%16*4
    if size<hl+os_icmphdr:size
      restart wait_for_reply
    var Pointer:os_icmphdr icp :> (buf translate Byte hl) map os_icmphdr
    if icp:type<>os_ICMP_ECHOREPLY or icp:id<>id or icp:sequence<>sequence
      restart wait_for_reply
    (var Str answer) set (addressof:icp translate os_icmphdr 1) size-hl-os_icmphdr:size false
    status := shunt answer=message success failure
    status := shunt answer=message success failure:"Corrupted answer"

  os_close s
  memory_free buf
  if verbose and status=success
    console hostname " is alive (" (cast (datetime:seconds-start:seconds)*1000 Int) " ms)" eol

function net_ping hostname -> status
  arg Str hostname ; arg Status status
  arg Str hostname ; arg ExtendedStatus status
  var Str message := "Pliant ping test on "+string:datetime
  for (var Int i) 0 4
    status := net_ping hostname "Pliant ping utility." (min 2^i 4)
    if status=success
      return


export net_ping