1
0
mirror of https://github.com/moparisthebest/Simba synced 2024-11-23 09:42:20 -05:00
Simba/Units/Synapse/pingsend.pas
2010-03-13 16:33:04 +01:00

721 lines
20 KiB
ObjectPascal

{==============================================================================|
| 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}
{$IFDEF UNICODE}
{$WARN IMPLICIT_STRING_CAST OFF}
{$WARN IMPLICIT_STRING_CAST_LOSS OFF}
{$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: Ansistring;
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: AnsiString): Word;
function Checksum6(Value: AnsiString): 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 = packed 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 = packed 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 = record
TTL: Byte;
TOS: Byte;
Flags: Byte;
OptionsSize: Byte;
OptionsData: PAnsiChar;
end;
PIP_OPTION_INFORMATION = ^TIP_OPTION_INFORMATION;
TICMP_ECHO_REPLY = 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 = 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: AnsiString): 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: AnsiString): 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: AnsiString;
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: Ansistring;
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,
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(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,
PAnsichar(FBuffer), length(FBuffer), @ipo, pAnsichar(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.