{==============================================================================|
| Project : Ararat Synapse                                       | 004.000.002 |
|==============================================================================|
| Content: PING sender                                                         |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer                                        |
| All rights reserved.                                                         |
|                                                                              |
| Redistribution and use in source and binary forms, with or without           |
| modification, are permitted provided that the following conditions are met:  |
|                                                                              |
| Redistributions of source code must retain the above copyright notice, this  |
| list of conditions and the following disclaimer.                             |
|                                                                              |
| Redistributions in binary form must reproduce the above copyright notice,    |
| this list of conditions and the following disclaimer in the documentation    |
| and/or other materials provided with the distribution.                       |
|                                                                              |
| Neither the name of Lukas Gebauer nor the names of its contributors may      |
| be used to endorse or promote products derived from this software without    |
| specific prior written permission.                                           |
|                                                                              |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"  |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE    |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE   |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR  |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL       |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR   |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER   |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT           |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY    |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH  |
| DAMAGE.                                                                      |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010.                |
| All Rights Reserved.                                                         |
|==============================================================================|
| Contributor(s):                                                              |
|==============================================================================|
| History: see HISTORY.HTM from distribution package                           |
|          (Found at URL: http://www.ararat.cz/synapse/)                       |
|==============================================================================}

{:@abstract(ICMP PING implementation.)
Allows create PING and TRACEROUTE. Or you can diagnose your network.

This unit using IpHlpApi (on WinXP or higher) if available. Otherwise it trying
 to use RAW sockets.

Warning: For use of RAW sockets you must have some special rights on some
 systems. So, it working allways when you have administator/root rights.
 Otherwise you can have problems!

Note: This unit is NOT portable to .NET!
  Use native .NET classes for Ping instead.
}

{$IFDEF FPC}
  {$MODE DELPHI}
{$ENDIF}
{$Q-}
{$R-}
{$H+}

{$IFDEF CIL}
  Sorry, this unit is not for .NET!
{$ENDIF}
//old Delphi does not have MSWINDOWS define.
{$IFDEF WIN32}
  {$IFNDEF MSWINDOWS}
    {$DEFINE MSWINDOWS}
  {$ENDIF}
{$ENDIF}

unit pingsend;

interface

uses
  SysUtils,
  synsock, blcksock, synautil, synafpc, synaip
{$IFDEF MSWINDOWS}
  , windows
{$ENDIF}
  ;

const
  ICMP_ECHO = 8;
  ICMP_ECHOREPLY = 0;
  ICMP_UNREACH = 3;
  ICMP_TIME_EXCEEDED = 11;
//rfc-2292
  ICMP6_ECHO = 128;
  ICMP6_ECHOREPLY = 129;
  ICMP6_UNREACH = 1;
  ICMP6_TIME_EXCEEDED = 3;

type
  {:List of possible ICMP reply packet types.}
  TICMPError = (
    IE_NoError,
    IE_Other,
    IE_TTLExceed,
    IE_UnreachOther,
    IE_UnreachRoute,
    IE_UnreachAdmin,
    IE_UnreachAddr,
    IE_UnreachPort
    );

  {:@abstract(Implementation of ICMP PING and ICMPv6 PING.)}
  TPINGSend = class(TSynaClient)
  private
    FSock: TICMPBlockSocket;
    FBuffer: string;
    FSeq: Integer;
    FId: Integer;
    FPacketSize: Integer;
    FPingTime: Integer;
    FIcmpEcho: Byte;
    FIcmpEchoReply: Byte;
    FIcmpUnreach: Byte;
    FReplyFrom: string;
    FReplyType: byte;
    FReplyCode: byte;
    FReplyError: TICMPError;
    FReplyErrorDesc: string;
    FTTL: Byte;
    Fsin: TVarSin;
    function Checksum(Value: string): Word;
    function Checksum6(Value: string): Word;
    function ReadPacket: Boolean;
    procedure TranslateError;
    procedure TranslateErrorIpHlp(value: integer);
    function InternalPing(const Host: string): Boolean;
    function InternalPingIpHlp(const Host: string): Boolean;
    function IsHostIP6(const Host: string): Boolean;
    procedure GenErrorDesc;
  public
    {:Send ICMP ping to host and count @link(pingtime). If ping OK, result is
     @true.}
    function Ping(const Host: string): Boolean;
    constructor Create;
    destructor Destroy; override;
  published
    {:Size of PING packet. Default size is 32 bytes.}
    property PacketSize: Integer read FPacketSize Write FPacketSize;

    {:Time between request and reply.}
    property PingTime: Integer read FPingTime;

    {:From this address is sended reply for your PING request. It maybe not your
     requested destination, when some error occured!}
    property ReplyFrom: string read FReplyFrom;

    {:ICMP type of PING reply. Each protocol using another values! For IPv4 and
     IPv6 are used different values!}
    property ReplyType: byte read FReplyType;

    {:ICMP code of PING reply. Each protocol using another values! For IPv4 and
     IPv6 are used different values! For protocol independent value look to
     @link(ReplyError)}
    property ReplyCode: byte read FReplyCode;

    {:Return type of returned ICMP message. This value is independent on used
     protocol!}
    property ReplyError: TICMPError read FReplyError;

    {:Return human readable description of returned packet type.}
    property ReplyErrorDesc: string read FReplyErrorDesc;

    {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
    property Sock: TICMPBlockSocket read FSock;

    {:TTL value for ICMP query}
    property TTL: byte read FTTL write FTTL;
  end;

{:A very useful function and example of its use would be found in the TPINGSend
 object. Use it to ping to any host. If successful, returns the ping time in
 milliseconds.  Returns -1 if an error occurred.}
function PingHost(const Host: string): Integer;

{:A very useful function and example of its use would be found in the TPINGSend
 object. Use it to TraceRoute to any host.}
function TraceRouteHost(const Host: string): string;

implementation

type
  {:Record for ICMP ECHO packet header.}
  TIcmpEchoHeader = record
    i_type: Byte;
    i_code: Byte;
    i_checkSum: Word;
    i_Id: Word;
    i_seq: Word;
    TimeStamp: integer;
  end;

  {:record used internally by TPingSend for compute checksum of ICMPv6 packet
   pseudoheader.}
  TICMP6Packet = record
    in_source: TInAddr6;
    in_dest: TInAddr6;
    Length: integer;
    free0: Byte;
    free1: Byte;
    free2: Byte;
    proto: Byte;
  end;

{$IFDEF MSWINDOWS}
const
  DLLIcmpName = 'iphlpapi.dll';
type
  TIP_OPTION_INFORMATION = packed record
    TTL: Byte;
    TOS: Byte;
    Flags: Byte;
    OptionsSize: Byte;
    OptionsData: PChar;
  end;
  PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;

  TICMP_ECHO_REPLY = packed record
    Address: TInAddr;
    Status: integer;
    RoundTripTime: integer;
    DataSize: Word;
    Reserved: Word;
    Data: pointer;
    Options: TIP_OPTION_INFORMATION;
  end;
  PICMP_ECHO_REPLY = ^TICMP_ECHO_REPLY;

  TICMPV6_ECHO_REPLY = packed record
    Address: TSockAddrIn6;
    Status: integer;
    RoundTripTime: integer;
  end;
  PICMPV6_ECHO_REPLY = ^TICMPV6_ECHO_REPLY;

  TIcmpCreateFile = function: integer; stdcall;
  TIcmpCloseHandle = function(handle: integer): boolean; stdcall;
  TIcmpSendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
    ApcContext: pointer; DestinationAddress: TInAddr; RequestData: pointer;
    RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
    ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;
  TIcmp6CreateFile = function: integer; stdcall;
  TIcmp6SendEcho2 = function(handle: integer; Event: pointer; ApcRoutine: pointer;
    ApcContext: pointer; SourceAddress: PSockAddrIn6; DestinationAddress: PSockAddrIn6;
    RequestData: pointer; RequestSize: integer; RequestOptions: PIP_OPTION_INFORMATION;
    ReplyBuffer: pointer; ReplySize: integer; Timeout: Integer): integer; stdcall;

var
  IcmpDllHandle: TLibHandle = 0;
  IcmpHelper4: boolean = false;
  IcmpHelper6: boolean = false;
  IcmpCreateFile: TIcmpCreateFile = nil;
  IcmpCloseHandle: TIcmpCloseHandle = nil;
  IcmpSendEcho2: TIcmpSendEcho2 = nil;
  Icmp6CreateFile: TIcmp6CreateFile = nil;
  Icmp6SendEcho2: TIcmp6SendEcho2 = nil;
{$ENDIF}
{==============================================================================}

constructor TPINGSend.Create;
begin
  inherited Create;
  FSock := TICMPBlockSocket.Create;
  FSock.Owner := self;
  FTimeout := 5000;
  FPacketSize := 32;
  FSeq := 0;
  Randomize;
  FTTL := 128;
end;

destructor TPINGSend.Destroy;
begin
  FSock.Free;
  inherited Destroy;
end;

function TPINGSend.ReadPacket: Boolean;
begin
  FBuffer := FSock.RecvPacket(Ftimeout);
  Result := FSock.LastError = 0;
end;

procedure TPINGSend.GenErrorDesc;
begin
  case FReplyError of
    IE_NoError:
      FReplyErrorDesc := '';
    IE_Other:
      FReplyErrorDesc := 'Unknown error';
    IE_TTLExceed:
      FReplyErrorDesc := 'TTL Exceeded';
    IE_UnreachOther:
      FReplyErrorDesc := 'Unknown unreachable';
    IE_UnreachRoute:
      FReplyErrorDesc := 'No route to destination';
    IE_UnreachAdmin:
      FReplyErrorDesc := 'Administratively prohibited';
    IE_UnreachAddr:
      FReplyErrorDesc := 'Address unreachable';
    IE_UnreachPort:
      FReplyErrorDesc := 'Port unreachable';
  end;
end;

function TPINGSend.IsHostIP6(const Host: string): Boolean;
var
  f: integer;
begin
  f := AF_UNSPEC;
  if IsIp(Host) then
    f := AF_INET
  else
    if IsIp6(Host) then
      f := AF_INET6;
  synsock.SetVarSin(Fsin, host, '0', f,
    IPPROTO_UDP, SOCK_DGRAM, Fsock.PreferIP4);
  result := Fsin.sin_family = AF_INET6;
end;

function TPINGSend.Ping(const Host: string): Boolean;
var
  b: boolean;
begin
  FPingTime := -1;
  FReplyFrom := '';
  FReplyType := 0;
  FReplyCode := 0;
  FReplyError := IE_Other;
  GenErrorDesc;
  FBuffer := StringOfChar(#55, SizeOf(TICMPEchoHeader) + FPacketSize);
{$IFDEF MSWINDOWS}
  b := IsHostIP6(host);
  if not(b) and IcmpHelper4 then
    result := InternalPingIpHlp(host)
  else
    if b and IcmpHelper6 then
      result := InternalPingIpHlp(host)
    else
      result := InternalPing(host);
{$ELSE}
   result := InternalPing(host);
{$ENDIF}
end;

function TPINGSend.InternalPing(const Host: string): Boolean;
var
  IPHeadPtr: ^TIPHeader;
  IpHdrLen: Integer;
  IcmpEchoHeaderPtr: ^TICMPEchoHeader;
  t: Boolean;
  x: cardinal;
  IcmpReqHead: string;
begin
  Result := False;
  FSock.TTL := FTTL;
  FSock.Bind(FIPInterface, cAnyPort);
  FSock.Connect(Host, '0');
  if FSock.LastError <> 0 then
    Exit;
  FSock.SizeRecvBuffer := 60 * 1024;
  if FSock.IP6used then
  begin
    FIcmpEcho := ICMP6_ECHO;
    FIcmpEchoReply := ICMP6_ECHOREPLY;
    FIcmpUnreach := ICMP6_UNREACH;
  end
  else
  begin
    FIcmpEcho := ICMP_ECHO;
    FIcmpEchoReply := ICMP_ECHOREPLY;
    FIcmpUnreach := ICMP_UNREACH;
  end;
  IcmpEchoHeaderPtr := Pointer(FBuffer);
  with IcmpEchoHeaderPtr^ do
  begin
    i_type := FIcmpEcho;
    i_code := 0;
    i_CheckSum := 0;
    FId := System.Random(32767);
    i_Id := FId;
    TimeStamp := GetTick;
    Inc(FSeq);
    i_Seq := FSeq;
    if fSock.IP6used then
      i_CheckSum := CheckSum6(FBuffer)
    else
      i_CheckSum := CheckSum(FBuffer);
  end;
  FSock.SendString(FBuffer);
  // remember first 8 bytes of ICMP packet
  IcmpReqHead := Copy(FBuffer, 1, 8);
  x := GetTick;
  repeat
    t := ReadPacket;
    if not t then
      break;
    if fSock.IP6used then
    begin
{$IFNDEF MSWINDOWS}
      IcmpEchoHeaderPtr := Pointer(FBuffer);
{$ELSE}
//WinXP SP1 with networking update doing this think by another way ;-O
//      FBuffer := StringOfChar(#0, 4) + FBuffer;
      IcmpEchoHeaderPtr := Pointer(FBuffer);
//      IcmpEchoHeaderPtr^.i_type := FIcmpEchoReply;
{$ENDIF}
    end
    else
    begin
      IPHeadPtr := Pointer(FBuffer);
      IpHdrLen := (IPHeadPtr^.VerLen and $0F) * 4;
      IcmpEchoHeaderPtr := @FBuffer[IpHdrLen + 1];
    end;
  //check for timeout
    if TickDelta(x, GetTick) > FTimeout then
    begin
      t := false;
      Break;
    end;
  //it discard sometimes possible 'echoes' of previosly sended packet
  //or other unwanted ICMP packets...
  until (IcmpEchoHeaderPtr^.i_type <> FIcmpEcho)
    and ((IcmpEchoHeaderPtr^.i_id = FId)
    or (Pos(IcmpReqHead, FBuffer) > 0));
  if t then
    begin
      FPingTime := TickDelta(x, GetTick);
      FReplyFrom := FSock.GetRemoteSinIP;
      FReplyType := IcmpEchoHeaderPtr^.i_type;
      FReplyCode := IcmpEchoHeaderPtr^.i_code;
      TranslateError;
      Result := True;
    end;
end;

function TPINGSend.Checksum(Value: string): Word;
var
  CkSum: integer;
  Num, Remain: Integer;
  n, i: Integer;
begin
  Num := Length(Value) div 2;
  Remain := Length(Value) mod 2;
  CkSum := 0;
  i := 1;
  for n := 0 to Num - 1 do
  begin
    CkSum := CkSum + Synsock.HtoNs(DecodeInt(Value, i));
    inc(i, 2);
  end;
  if Remain <> 0 then
    CkSum := CkSum + Ord(Value[Length(Value)]);
  CkSum := (CkSum shr 16) + (CkSum and $FFFF);
  CkSum := CkSum + (CkSum shr 16);
  Result := Word(not CkSum);
end;

function TPINGSend.Checksum6(Value: string): Word;
const
  IOC_OUT = $40000000;
  IOC_IN = $80000000;
  IOC_INOUT = (IOC_IN or IOC_OUT);
  IOC_WS2 = $08000000;
  SIO_ROUTING_INTERFACE_QUERY = 20 or IOC_WS2 or IOC_INOUT;
var
  ICMP6Ptr: ^TICMP6Packet;
  s: string;
  b: integer;
  ip6: TSockAddrIn6;
  x: integer;
begin
  Result := 0;
{$IFDEF MSWINDOWS}
  s := StringOfChar(#0, SizeOf(TICMP6Packet)) + Value;
  ICMP6Ptr := Pointer(s);
  x := synsock.WSAIoctl(FSock.Socket, SIO_ROUTING_INTERFACE_QUERY,
    @FSock.RemoteSin, SizeOf(FSock.RemoteSin),
    @ip6, SizeOf(ip6), @b, nil, nil);
  if x <> -1 then
    ICMP6Ptr^.in_dest := ip6.sin6_addr
  else
    ICMP6Ptr^.in_dest := FSock.LocalSin.sin6_addr;
  ICMP6Ptr^.in_source := FSock.RemoteSin.sin6_addr;
  ICMP6Ptr^.Length := synsock.htonl(Length(Value));
  ICMP6Ptr^.proto := IPPROTO_ICMPV6;
  Result := Checksum(s);
{$ENDIF}
end;

procedure TPINGSend.TranslateError;
begin
  if fSock.IP6used then
  begin
    case FReplyType of
      ICMP6_ECHOREPLY:
        FReplyError := IE_NoError;
      ICMP6_TIME_EXCEEDED:
        FReplyError := IE_TTLExceed;
      ICMP6_UNREACH:
        case FReplyCode of
          0:
            FReplyError := IE_UnreachRoute;
          3:
            FReplyError := IE_UnreachAddr;
          4:
            FReplyError := IE_UnreachPort;
          1:
            FReplyError := IE_UnreachAdmin;
        else
          FReplyError := IE_UnreachOther;
        end;
    else
      FReplyError := IE_Other;
    end;
  end
  else
  begin
    case FReplyType of
      ICMP_ECHOREPLY:
        FReplyError := IE_NoError;
      ICMP_TIME_EXCEEDED:
        FReplyError := IE_TTLExceed;
      ICMP_UNREACH:
        case FReplyCode of
          0:
            FReplyError := IE_UnreachRoute;
          1:
            FReplyError := IE_UnreachAddr;
          3:
            FReplyError := IE_UnreachPort;
          13:
            FReplyError := IE_UnreachAdmin;
        else
          FReplyError := IE_UnreachOther;
        end;
    else
      FReplyError := IE_Other;
    end;
  end;
  GenErrorDesc;
end;

procedure TPINGSend.TranslateErrorIpHlp(value: integer);
begin
  case value of
    11000, 0:
      FReplyError := IE_NoError;
    11013:
      FReplyError := IE_TTLExceed;
    11002:
      FReplyError := IE_UnreachRoute;
    11003:
      FReplyError := IE_UnreachAddr;
    11005:
      FReplyError := IE_UnreachPort;
    11004:
      FReplyError := IE_UnreachAdmin;
  else
    FReplyError := IE_Other;
  end;
  GenErrorDesc;
end;

function TPINGSend.InternalPingIpHlp(const Host: string): Boolean;
{$IFDEF MSWINDOWS}
var
  PingIp6: boolean;
  PingHandle: integer;
  r: integer;
  ipo: TIP_OPTION_INFORMATION;
  RBuff: string;
  ip4reply: PICMP_ECHO_REPLY;
  ip6reply: PICMPV6_ECHO_REPLY;
  ip6: TSockAddrIn6;
begin
  Result := False;
  PingIp6 := Fsin.sin_family = AF_INET6;
  if pingIp6 then
    PingHandle := Icmp6CreateFile
  else
    PingHandle := IcmpCreateFile;
  if PingHandle <> -1 then
  begin
    try
      ipo.TTL := FTTL;
      ipo.TOS := 0;
      ipo.Flags := 0;
      ipo.OptionsSize := 0;
      ipo.OptionsData := nil;
      setlength(RBuff, 4096);
      if pingIp6 then
      begin
        FillChar(ip6, sizeof(ip6), 0);
        r := Icmp6SendEcho2(PingHandle, nil, nil, nil, @ip6, @Fsin,
          Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
        if r > 0 then
        begin
          RBuff := #0 + #0 + RBuff;
          ip6reply := PICMPV6_ECHO_REPLY(pointer(RBuff));
          FPingTime := ip6reply^.RoundTripTime;
          ip6reply^.Address.sin6_family := AF_INET6;
          FReplyFrom := GetSinIp(TVarSin(ip6reply^.Address));
          TranslateErrorIpHlp(ip6reply^.Status);
          Result := True;
        end;
      end
      else
      begin
        r := IcmpSendEcho2(PingHandle, nil, nil, nil, Fsin.sin_addr,
          Pchar(FBuffer), length(FBuffer), @ipo, pchar(RBuff), length(RBuff), FTimeout);
        if r > 0 then
        begin
          ip4reply := PICMP_ECHO_REPLY(pointer(RBuff));
          FPingTime := ip4reply^.RoundTripTime;
          FReplyFrom := IpToStr(swapbytes(ip4reply^.Address.S_addr));
          TranslateErrorIpHlp(ip4reply^.Status);
          Result := True;
        end;
      end
    finally
      IcmpCloseHandle(PingHandle);
    end;
  end;
end;
{$ELSE}
begin
  result := false;
end;
{$ENDIF}

{==============================================================================}

function PingHost(const Host: string): Integer;
begin
  with TPINGSend.Create do
  try
    Result := -1;
    if Ping(Host) then
      if ReplyError = IE_NoError then
        Result := PingTime;
  finally
    Free;
  end;
end;

function TraceRouteHost(const Host: string): string;
var
  Ping: TPingSend;
  ttl : byte;
begin
  Result := '';
  Ping := TPINGSend.Create;
  try
    ttl := 1;
    repeat
      ping.TTL := ttl;
      inc(ttl);
      if ttl > 30 then
        Break;
      if not ping.Ping(Host) then
      begin
        Result := Result + cAnyHost+ ' Timeout' + CRLF;
        continue;
      end;
      if (ping.ReplyError <> IE_NoError)
        and (ping.ReplyError <> IE_TTLExceed) then
      begin
        Result := Result + Ping.ReplyFrom + ' ' + Ping.ReplyErrorDesc + CRLF;
        break;
      end;
      Result := Result + Ping.ReplyFrom + ' ' + IntToStr(Ping.PingTime) + CRLF;
    until ping.ReplyError = IE_NoError;
  finally
    Ping.Free;
  end;
end;

{$IFDEF MSWINDOWS}
initialization
begin
  IcmpHelper4 := false;
  IcmpHelper6 := false;
  IcmpDllHandle := LoadLibrary(DLLIcmpName);
  if IcmpDllHandle <> 0 then
  begin
    IcmpCreateFile := GetProcAddress(IcmpDLLHandle, 'IcmpCreateFile');
    IcmpCloseHandle := GetProcAddress(IcmpDLLHandle, 'IcmpCloseHandle');
    IcmpSendEcho2 := GetProcAddress(IcmpDLLHandle, 'IcmpSendEcho2');
    Icmp6CreateFile := GetProcAddress(IcmpDLLHandle, 'Icmp6CreateFile');
    Icmp6SendEcho2 := GetProcAddress(IcmpDLLHandle, 'Icmp6SendEcho2');
    IcmpHelper4 := assigned(IcmpCreateFile)
      and assigned(IcmpCloseHandle)
      and assigned(IcmpSendEcho2);
    IcmpHelper6 := assigned(Icmp6CreateFile)
      and assigned(Icmp6SendEcho2);
  end;
end;

finalization
begin
  FreeLibrary(IcmpDllHandle);
end;
{$ENDIF}

end.