254 lines
8.1 KiB
Plaintext
254 lines
8.1 KiB
Plaintext
unit MagentaMonsock;
|
|
|
|
{ Magenta Systems Internet Packet Monitoring Components
|
|
|
|
Magenta Systems Monitor Socket ICS Component.
|
|
Updated by Angus Robertson, Magenta Systems Ltd, England, v1.4 26th November 2018
|
|
delphi@magsys.co.uk, https://www.magsys.co.uk/delphi/
|
|
Copyright Magenta Systems Ltd
|
|
|
|
TMonitorSocket needs WSocket from Fran?is PIETTE internet component suite V8
|
|
http://www.overbyte.eu/
|
|
|
|
Note this component uses RAW sockets, which are only available in Windows 2000
|
|
and later, and only for administrator level users.
|
|
|
|
Also note Windows 2000 SP4 and Windows XP SP2 appear to ignore most sent packets,
|
|
but Windows 2003 SP1 correctly captures all (or most) sent packets.
|
|
|
|
Microsoft is also restricting the use of RAW sockets in recent service packs,
|
|
XP SP2 stops raw sockets being used to send data but receive still works.
|
|
|
|
8 Aug 2008 - 1.2 - updated to support ICS V6 and V7, and Delphi 2009
|
|
|
|
26 Nov 2018 - 1.4 - no changes, testing with ICS V8
|
|
|
|
}
|
|
|
|
interface
|
|
|
|
uses
|
|
Windows, Messages, Classes, SysUtils, Winsock,
|
|
OverbyteIcsWSocket,
|
|
MagentaPackhdrs, MagClasses, Magsubs1 ;
|
|
|
|
type
|
|
|
|
|
|
TMonitorSocket = class(TCustomWSocket)
|
|
protected
|
|
FAddrMask: string ;
|
|
FIgnoreIPList: TFindList ;
|
|
FInAddr: TInAddr ;
|
|
FInAddrMask: TInAddr ;
|
|
FIgnoreData: boolean ;
|
|
FIgnoreLAN: boolean ;
|
|
FTotRecvBytes: int64 ;
|
|
FTotSendBytes: int64 ;
|
|
FTotRecvPackets: integer ;
|
|
FTotSendPackets: integer ;
|
|
FOnPacketEvent: TPacketEvent;
|
|
procedure MonDataAvailable (Sender: TObject; ErrCode: Word) ;
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure StartMonitor;
|
|
procedure StopMonitor;
|
|
procedure SetIgnoreIP (IPAddr: string) ;
|
|
procedure ClearIgnoreIP ;
|
|
protected
|
|
published
|
|
property Addr ;
|
|
property AddrMask: string read FAddrMask
|
|
write FAddrMask ;
|
|
property IgnoreData: boolean read FIgnoreData
|
|
write FIgnoreData ;
|
|
property IgnoreLAN: boolean read FIgnoreLAN
|
|
write FIgnoreLAN ;
|
|
property TotRecvBytes: int64 read FTotRecvBytes ;
|
|
property TotSendBytes: int64 read FTotSendBytes ;
|
|
property TotRecvPackets: integer read FTotRecvPackets ;
|
|
property TotSendPackets: integer read FTotSendPackets ;
|
|
property OnDataAvailable ;
|
|
property OnPacketEvent: TPacketEvent read FOnPacketEvent
|
|
write FOnPacketEvent;
|
|
end;
|
|
|
|
implementation
|
|
|
|
procedure Register;
|
|
begin
|
|
RegisterComponents('FPiette', [TMonitorSocket]) ;
|
|
end ;
|
|
|
|
constructor TMonitorSocket.Create(AOwner: TComponent);
|
|
begin
|
|
ReqVerHigh := 2 ;
|
|
ReqVerLow := 2 ;
|
|
FIgnoreData := false ;
|
|
FIgnoreIPList := TFindList.Create ;
|
|
FIgnoreIPList.Sorted := true ;
|
|
inherited Create(AOwner);
|
|
onDataAvailable := MonDataAvailable ;
|
|
end ;
|
|
|
|
destructor TMonitorSocket.Destroy;
|
|
begin
|
|
FreeAndNil (FIgnoreIPList) ;
|
|
inherited Destroy;
|
|
end ;
|
|
|
|
// called by TFindList for sort and find comparison of file records
|
|
|
|
function CompareFNext (Item1, Item2: Pointer): Integer;
|
|
// Compare returns < 0 if Item1 is less than Item2, 0 if they are equal
|
|
// and > 0 if Item1 is greater than Item2.
|
|
begin
|
|
result := 0 ;
|
|
if longword (Item1) > longword (Item2) then result := 1 ;
|
|
if longword (Item1) < longword (Item2) then result := -1 ;
|
|
end ;
|
|
|
|
procedure TMonitorSocket.SetIgnoreIP (IPAddr: string) ;
|
|
var
|
|
InIPAddr: TInAddr ;
|
|
begin
|
|
if NOT Str2IP (IPAddr, InIPAddr) then exit ;
|
|
FIgnoreIPList.AddSorted (Pointer (InIPAddr.S_addr), @CompareFNext) ;
|
|
end ;
|
|
|
|
procedure TMonitorSocket.ClearIgnoreIP ;
|
|
begin
|
|
FIgnoreIPList.Clear ;
|
|
end ;
|
|
|
|
procedure TMonitorSocket.MonDataAvailable (Sender: TObject; ErrCode: Word) ;
|
|
var
|
|
hdrlen, iploc: integer ;
|
|
packetbuff: array [0..2000] of PAnsiChar ;
|
|
iphdr: PHdrIP;
|
|
tcphdr: PHdrTCP;
|
|
udphdr: PHdrUDP;
|
|
PacketInfo: TPacketInfo ; // the data we return in the event
|
|
|
|
procedure GetDataByOffset (offset: integer) ;
|
|
var
|
|
datastart: PAnsiChar ;
|
|
begin
|
|
datastart := PAnsiChar (PAnsiChar (iphdr) + offset) ;
|
|
with PacketInfo do
|
|
begin
|
|
if ntohs (iphdr.tot_len) < Sizeof (packetbuff) then
|
|
DataLen := ntohs (iphdr.tot_len) - offset
|
|
else
|
|
DataLen := Sizeof (packetbuff) - offset;
|
|
if DataLen = 0 then exit ;
|
|
if FIgnoreData then exit ;
|
|
SetLength (DataBuf, DataLen) ; // ANSI string
|
|
Move (datastart^, DataBuf [1], DataLen) ;
|
|
end ;
|
|
end;
|
|
|
|
begin
|
|
FillChar (PacketInfo, Sizeof(PacketInfo), 0) ;
|
|
with PacketInfo do
|
|
begin
|
|
PacketLen := Receive (@packetbuff [0], SizeOf (packetbuff)) ;
|
|
if PacketLen <= 0 then exit ;
|
|
inc (PacketLen, OFFSET_IP) ; // add 14-byte ethernet header length
|
|
EtherProto := PROTO_IP ; // socket only returns IP
|
|
iphdr := PHdrIP (@packetbuff); // IP header is start of raw packet
|
|
AddrSrc := iphdr.saddr ; // 32-bit IP addresses
|
|
AddrDest := iphdr.daddr ;
|
|
SendFlag := (FInAddr.S_addr = AddrSrc.S_addr) ; // did we sent this packet
|
|
ProtoType := iphdr.protocol ; // TCP, UDP, ICMP
|
|
PacketDT := NowPC ; // time using performance counter
|
|
|
|
// check if either IP is in the ignore list
|
|
if FIgnoreIPList.Count > 0 then
|
|
begin
|
|
iploc := -1 ;
|
|
if FIgnoreIPList.Find (Pointer (AddrSrc.S_addr), @CompareFNext, iploc) then exit ;
|
|
if FIgnoreIPList.Find (Pointer (AddrDest.S_addr), @CompareFNext, iploc) then exit ;
|
|
end ;
|
|
|
|
// check if both IP on the same subnet as the LAN mask, if so ignore
|
|
if (FInAddrMask.S_addr <> 0) and FIgnoreLAN then
|
|
begin
|
|
if (AddrSrc.S_addr AND FInAddrMask.S_addr) =
|
|
(AddrDest.S_addr AND FInAddrMask.S_addr) then exit ;
|
|
if AddrDest.S_addr = 0 then exit ;
|
|
end ;
|
|
|
|
// increment global traffic counters
|
|
if SendFlag then
|
|
begin
|
|
inc (FTotSendBytes, packetlen) ;
|
|
inc (FTotSendPackets) ;
|
|
end
|
|
else
|
|
begin
|
|
inc (FTotRecvBytes, packetlen) ;
|
|
inc (FTotRecvPackets) ;
|
|
end ;
|
|
|
|
// check protocol and find ports and data
|
|
if Assigned (FOnPacketEvent) then
|
|
begin
|
|
DataBuf := '' ;
|
|
hdrlen := GetIHlen (iphdr^) ;
|
|
if ProtoType = IPPROTO_ICMP then
|
|
begin
|
|
IcmpType := PByte (PAnsiChar (iphdr) + hdrlen)^ ;
|
|
GetDataByOffset (hdrlen) ;
|
|
end
|
|
else
|
|
begin
|
|
if ProtoType = IPPROTO_TCP then
|
|
begin
|
|
tcphdr := PHdrTCP (PAnsiChar (iphdr) + hdrlen) ;
|
|
PortSrc := ntohs (tcphdr.source) ;
|
|
PortDest := ntohs (tcphdr.dest) ;
|
|
TcpFlags := ntohs (tcphdr.flags) ;
|
|
GetDataByOffset (hdrlen + GetTHdoff (tcphdr^)) ;
|
|
end;
|
|
if ProtoType = IPPROTO_UDP then
|
|
begin
|
|
udphdr := PHdrUDP (PAnsiChar (iphdr) + hdrlen) ;
|
|
PortSrc := ntohs (udphdr.src_port) ;
|
|
PortDest := ntohs (udphdr.dst_port) ;
|
|
GetDataByOffset (hdrlen + Sizeof (THdrUDP));
|
|
end;
|
|
end;
|
|
end ;
|
|
FOnPacketEvent (Self, PacketInfo) ;
|
|
end ;
|
|
end ;
|
|
|
|
procedure TMonitorSocket.StartMonitor;
|
|
begin
|
|
FInAddr := StrToIP (Addr) ; // keep 32-bit listen IP address
|
|
FAddrMask := Trim (FAddrMask) ;
|
|
if Length(FAddrMask) = 0 then
|
|
FInAddrMask.S_addr := 0
|
|
else
|
|
FInAddrMask := StrToIP (FAddrMask) ; // and IP mask
|
|
FTotRecvBytes := 0 ;
|
|
FTotSendBytes := 0 ;
|
|
FTotRecvPackets := 0 ;
|
|
FTotSendPackets := 0 ;
|
|
Port := '0' ; // all ports
|
|
Proto := 'raw_ip' ;
|
|
PerfFreqAligned := false ; // force performance counter clock to align with system clock
|
|
ComponentOptions := [wsoSIO_RCVALL] ; // receive all packets on this address
|
|
Listen ;
|
|
end ;
|
|
|
|
procedure TMonitorSocket.StopMonitor;
|
|
begin
|
|
Close ;
|
|
end ;
|
|
|
|
|
|
end.
|