{
	Snoop.pas

	Pakcet capture class component library version 1.0(2002.07.01)
	This class(component) runs on WinPCap environment.

	made by gilgil
	to contact with me : http://www.gilgil.co.kr
}

unit Snoop;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Pcap, Packet32, Winsock;


const
  //RFC1340
  PROTO_IP      =	$0800;
  PROTO_ARP     =	$0806;
  PROTO_XNS     =	$0600;
  PROTO_SNMP    =	$814C;
  PROTO_OLD_IPX =	$8137;
  PROTO_NOVELL  =	$8138;
  PROTO_IPNG    =	$86DD;

type
  ETHERNET_HDR = packed record
	Destination:     array[0..5] of UCHAR;
	Source:          array[0..5] of UCHAR;
	Protocol:        WORD;
  end;
  PETHERNET_HDR = ^ETHERNET_HDR;


const
  PROTO_TCP = 6;
  PROTO_UDP = 17;

type
  IP_RHDR = packed record
	Verlen:          UCHAR;
	Service:         UCHAR;
	Length:          WORD;
	Ident:           WORD;
	Flagoff:         WORD;
	TimeLive:        UCHAR;
	Protocol:        UCHAR;
	Checksum:        WORD;
	Source:          DWORD;
	Destination:     DWORD;
  end;
  PIP_RHDR = ^IP_RHDR;

  IPNG_RHDR = packed record
	VerPrio:         UCHAR;
	FlowLabel:       array[0..2] of UCHAR;
	Length:          WORD;
	NextHadr:        UCHAR;
	HopLimit:        UCHAR;
	Source:          array[0..15] of UCHAR;
	Destination:     array[0..15] of UCHAR;
  end;
  PIPNG_RHDR = ^IPNG_RHDR;

const
  TCP_FLAG_FIN =	$01;
  TCP_FLAG_SYN =	$02;
  TCP_FLAG_RST =	$04;
  TCP_FLAG_PSH =	$08;
  TCP_FLAG_ACK =	$10;
  TCP_FLAG_URG =	$20;

type
  // TCP Header, RFC793
  TCP_RHDR = packed record
	Source:          WORD; //Source Port
	Destination:     WORD; //Destination Port
	Seq:             DWORD;
	Ack:             DWORD;
	Off_Rsvd:        UCHAR;
	Rsvd_Flags:      UCHAR;
	Window:          WORD;
	Checksum:        WORD;
	UrgPoint:        WORD;
  end;
  PTCP_RHDR = ^TCP_RHDR;

type
  // UDP Header
  UDP_RHDR = packed record
	Source:          WORD;
	Destination:     WORD;
	Length:          WORD;
	Checksum:        WORD;
  end;
  PUDP_RHDR = ^UDP_RHDR;

  // Pseudo Header for evaluating TCP/UDP Checksum
  PSU_RHDR = packed record
	Source:          DWORD;
	Destination:     DWORD;
	Zero:            UCHAR;
	Protocol:        UCHAR;
	Length:          WORD;
  end;
  PPSU_RHDR = ^PSU_RHDR;

  TCustomSnoop = class;
  // Thread that listens to selected Netadapter
  TSnoopThread = class(TThread)
  private
	FSnoop: TCustomSnoop;
  public
	ReadTimes: integer;
	constructor Create(Snoop: TCustomSnoop); // gilgil temp
	destructor Destroy; override; // gilgil temp
	procedure Execute; override; // gilgil temp
  end;

  TOnCaptureEvent = procedure (Sender: TObject; Header: PETHERNET_HDR; Data: PChar) of object;
  TOnCaptureIPEvent = procedure (Sender: TObject; IPHeader: PIP_RHDR; Data: PChar) of object;
  TOnCaptureTCPEvent = procedure (Sender: TObject; IPHeader: PIP_RHDR; TCPHeader: PTCP_RHDR; Data: PChar) of object;
  TOnCaptureUDPEvent = procedure (Sender: TObject; IPHeader: PIP_RHDR; UDPHeader: PUDP_RHDR; Data: PChar) of object;
  TOnCaptureSimpleTCPEvent = procedure (Sender: TObject; IPHeader: PIP_RHDR; TCPHeader: PTCP_RHDR; Data: PChar; Length: Integer) of object;
  TOnCaptureSimpleUDPEvent = procedure (Sender: TObject; IPHeader: PIP_RHDR; UDPHeader: PUDP_RHDR; Data: PChar; Length: Integer) of object;

  TCustomSnoop = class(TComponent)
  private
   // used internally
	FActive: Boolean; // Flag indicating snooping activity
	FThread : TSnoopThread; // The listening thread
	FPCap : PPcap; // Handle to the pcapdriver
	FAdapterNames: TStringList;
	procedure GetAdapterNames(AdapterNames: TStringList); // gilgil temp
	procedure ThreadTerminate(Sender:TObject); // gilgil temp

  private
	// property
	FAdapterIndex: Integer;
	FAdapterName: String;
	FThreadSafe: Boolean;

	FOnCapture: TOnCaptureEvent;
	procedure SetAdapterIndex(Value: Integer); //// gilgil temp
	procedure SetAdapterName(Value: String); //// gilgil temp

  private
	// for Synchronize OnCapture
	ThreadSafeHeader: PETHERNET_HDR;
	ThreadSafeData: PChar;
	procedure ThreadSafeOnCapture;

  public
	constructor Create(AOwner: TComponent); override;
	destructor Destroy; override;
	procedure Open;
	procedure Close;

  public
	property AdapterNames: TStringList read FAdapterNames;

  published
	property AdapterIndex: Integer read FAdapterIndex write SetAdapterIndex;
	property AdapterName: String read FAdapterName write SetAdapterName;
	property ThreadSafe: Boolean read FThreadSafe write FThreadSafe;

  end;

  TSnoop = class (TCustomSnoop)
  published
	property OnCapture : TOnCaptureEvent read FOnCapture write FOnCapture;
  end;
  
  TCustomSnoopIP = class(TCustomSnoop)
  private
	// used internally
	procedure FOnMyCapture(Sender: TObject; Header: PETHERNET_HDR; Data: PChar);
  private
	// property
	FOnCaptureIP: TOnCaptureIPEvent;
  public
	constructor Create(AOwner: TComponent); override;
  end;

  TSnoopIP = class (TCustomSnoopIP)
  published
	property OnCaptureIP: TOnCaptureIPEvent read FOnCaptureIP write FOnCaptureIP;
  end;

  TCustomSnoopTCP = class(TCustomSnoopIP)
  private
	// used internally
	procedure FOnMyCaptureIP(Sender: TObject; IPHeader: PIP_RHDR; Data: PChar);
  private
	// property
	FOnCaptureTCP: TOnCaptureTCPEvent;
  public
	constructor Create(AOwner: TComponent); override;
  end;

  TSnoopTCP = class(TCustomSnoopTCP)
  published
	property OnCaptureTCP: TOnCaptureTCPEvent read FOnCaptureTCP write FOnCaptureTCP;
  end;

  TCustomSnoopUDP = class(TCustomSnoopIP)
  private
	// used internally
	procedure FOnMyCaptureIP(Sender: TObject; IPHeader: PIP_RHDR; Data: PChar);
  private
	// property
	FOnCaptureUDP: TOnCaptureUDPEvent;
  public
	constructor Create(AOwner: TComponent); override;
  end;

  TSnoopUDP = class(TCustomSnoopUDP)
  published
	property OnCaptureUDP: TOnCaptureUDPEvent read FOnCaptureUDP write FOnCaptureUDP;
  end;

  TCustomSnoopSimpleTCP = class(TCustomSnoopTCP)
  private
	// used internally
	procedure FOnMyCaptureTCP(Sender: TObject; IPHeader: PIP_RHDR; TCPHeader: PTCP_RHDR; Data: PChar);
  private
	// property
	FOnCaptureSimpleTCP: TOnCaptureSimpleTCPEvent;
  public
	public constructor Create(AOwner: TComponent); override;
  end;

  TSnoopSimpleTCP = class(TCustomSnoopSimpleTCP)
  published
	property OnCaptureSimpleTCP: TOnCaptureSimpleTCPEvent read FOnCaptureSimpleTCP write FOnCaptureSimpleTCP;
  end;

  TCustomSnoopSimpleUDP = class(TCustomSnoopUDP)
  private
	// used internally
	procedure FOnMyCaptureUDP(Sender: TObject; IPHeader: PIP_RHDR; UDPHeader: PUDP_RHDR; Data: PChar);
  private
	// property
		FOnCaptureSimpleUDP: TOnCaptureSimpleUDPEvent;
  public
	public constructor Create(AOwner: TComponent); override;
  end;

  TSnoopSimpleUDP = class(TCustomSnoopSimpleUDP)
  published
	property OnCaptureSimpleUDP: TOnCaptureSimpleUDPEvent read FOnCaptureSimpleUDP write FOnCaptureSimpleUDP;
  end;

function Mac2Str(Mac: PChar): String;
function IP2Str(IP: DWORD): String;

procedure Register;

implementation

procedure Register;
begin
	RegisterComponents('Snoop', [TSnoop, TSnoopIP, TSnoopTCP, TSnoopUDP, TSnoopSimpleTCP, TSnoopSimpleUDP]);
end;

procedure CaptureCB(User:Pointer; const Header:Ppcap_pkthdr; const Data:PChar);
var
	Snoop: TCustomSnoop;
begin
	Snoop := TCustomSnoop(User);
	if not Snoop.FActive then exit;
	if Assigned(Snoop.FOnCapture) then
	begin
		if Snoop.FThreadSafe then
		begin
			Snoop.ThreadSafeHeader := PETHERNET_HDR(Data);
			Snoop.ThreadSafeData := PChar(DWORD(Data) + sizeof(ETHERNET_HDR));
			Snoop.FThread.Synchronize(Snoop.ThreadSafeOnCapture);
		end else
			Snoop.FOnCapture(Snoop, PETHERNET_HDR(Data), PChar(DWORD(Data) + sizeof(ETHERNET_HDR)));
	end;
end;

constructor TSnoopThread.Create(Snoop: TCustomSnoop);
begin
	ReadTimes := 0;
	FSnoop := Snoop;
	PacketSetReadTimeout(FSnoop.FPCap.Adapter,100);
	inherited Create(TRUE);
end;

destructor TSnoopThread.Destroy;
begin
	inherited;
end;

procedure TSnoopThread.Execute;
begin
	if FSnoop = nil then
		exit;
	while not Terminated do
	begin
		Pcap_Read(FSnoop.FPCap, 0, CaptureCB, Pointer(FSnoop));
	end;
end;

procedure TCustomSnoop.GetAdapterNames(AdapterNames: TStringList); // gilgil temp
var
	ErrStr: String;
begin
	AdapterNames.Capacity:= 10;
	AdapterNames.Sorted:= false;
	AdapterNames.CommaText := PCap.Pcap_getAdapternames(',', ErrStr);
	// gilgil temp 2002.07.01
	// ErrStr를 처리해 주어야 한다.
	if AdapterNames.CommaText = '' then
	begin
		if not (csDesigning in ComponentState) then
			Exception.Create('No Adpaters');
	end;
end;

procedure TCustomSnoop.ThreadTerminate(Sender:TObject);
begin
	FActive := false;
end;

procedure TCustomSnoop.SetAdapterIndex(Value: Integer);
begin
	if Value = FAdapterIndex then
		exit;
	if (Value < 0) or (Value >= FAdapterNames.Count) then
	begin
		FAdapterIndex := -1;
		FAdapterName := '';
	end else
	begin
		FAdapterIndex := Value;
		FAdapterName := FAdapterNames[Value];
	end;
end;

procedure TCustomSnoop.SetAdapterName(Value: String); //// gilgil temp
var
	i: Integer;
begin
	if Value = FAdapterName then
		exit;
	for i := 0 to FAdapterNames.Count -1 do
	begin
		if Value = FAdapterNames[i] then
		begin
			FAdapterIndex := i;
			FAdapterName := FAdapterNames[i];
			exit;
		end;
	end;
	FAdapterIndex := -1;
	FAdapterName := '';
end;

procedure TCustomSnoop.ThreadSafeOnCapture;
begin
	FOnCapture(Self, ThreadSafeHeader, ThreadSafeData);
end;

constructor TCustomSnoop.Create(AOwner: TComponent);
begin
	inherited;
	FActive := false;
	FThreadSafe := true;
	FThread := nil;
	FPCap := nil;
	FAdapterNames := TStringList.Create;
	GetAdapterNames(FAdapterNames);
	FAdapterIndex := -1;
	FAdapterName := '';
end;

destructor TCustomSnoop.Destroy;
begin
	Close;
	if FAdapterNames <> nil then
	begin
		FAdapterNames.Free;
		FAdapterNames := nil;
	end;
	inherited;
end;

procedure TCustomSnoop.Open;
var
	ErrStr: String;
begin
	// Check if Snooping is active
	if FActive or (FPCap <> nil) then
		exit;

	// Open Driver and NetAdapter
	FPCap := Pcap.pcap_open_live(PChar(FAdapterName),
		DEFAULT_SNAPLEN,TRUE,100, ErrStr);
	if FPCap = nil then exit;
	// Start Snoop Read Thread
	FThread := TSnoopThread.Create(Self);
	Fthread.ReadTimes := 10;
	Fthread.OnTerminate := ThreadTerminate;
	Fthread.FreeOnTerminate := false;
	Fthread.Resume;
	FActive := true;
end;

procedure TCustomSnoop.Close;
begin
	if (not FActive) then
		exit;
	if FThread = nil then
	begin
		Exception.Create('No thread to stop');
		exit;
	end;

	FActive := false;
	// Stop Snooping Thread
	FThread.Terminate;
	FThread.WaitFor;
	FThread.Free;
	FThread := nil;

	// Release Driver Handle
	Pcap_Close(FPCap);
end;

procedure TCustomSnoopIP.FOnMyCapture(Sender: TObject; Header: PETHERNET_HDR; Data: PChar);
begin
	if Assigned(FOnCaptureIP) then
	begin
		if ntohs(Header.Protocol) <> PROTO_IP then exit;
		FOnCaptureIP(Self, PIP_RHDR(Data), PChar(DWORD(Data) + sizeof(IP_RHDR)));
	end;
end;

constructor TCustomSnoopIP.Create(AOwner: TComponent);
begin
	inherited;
	FOnCapture := FOnMyCapture;
end;

procedure TCustomSnoopTCP.FOnMyCaptureIP(Sender: TObject; IPHeader: PIP_RHDR; Data: PChar);
begin
	if Assigned(FOnCaptureTCP) then
	begin
		if IPHeader.Protocol <> PROTO_TCP then exit;
		FOnCaptureTCP(Self, IPHeader, PTCP_RHDR(Data), PChar(DWORD(Data) + sizeof(IP_RHDR)));
	end;
end;

constructor TCustomSnoopTCP.Create(AOwner: TComponent);
begin
	inherited;
	FOnCaptureIP := FOnMyCaptureIP;
end;

procedure TCustomSnoopUDP.FOnMyCaptureIP(Sender: TObject; IPHeader: PIP_RHDR; Data: PChar);
begin
	if Assigned(FOnCaptureUDP) then
	begin
		if IPHeader.Protocol <> PROTO_UDP then
			exit;
		FOnCaptureUDP(Self, IPHeader, PUDP_RHDR(Data), PChar(DWORD(Data) + sizeof(IP_RHDR)));
	end;
end;

constructor TCustomSnoopUDP.Create(AOwner: TComponent);
begin
	inherited;
	FOnCaptureIP := FOnMyCaptureIP;
end;

procedure TCustomSnoopSimpleTCP.FOnMyCaptureTCP(Sender: TObject; IPHeader: PIP_RHDR; TCPHeader: PTCP_RHDR; Data: PChar);
var
	Length: Integer;
	TCPHeaderLength: Integer;
begin
	if Assigned(FOnCaptureSimpleTCP) then
	begin
		Length := ntohs(IPHeader.Length);
		TCPHeaderLength := ((TCPHeader.Off_Rsvd and $F0) shr 4) * sizeof(DWORD);
		dec(Length, sizeof(IP_RHDR) + TCPHeaderLength);
		if Length > 0 then
		begin
			Data := PChar(TCPHeader);
			inc(Data, TCPHeaderLength);
			FOnCaptureSimpleTCP(Self, IPHeader, TCPHeader, Data, Length);
		end;
	end;
end;

constructor TCustomSnoopSimpleTCP.Create(AOwner: TComponent);
begin
	inherited;
	FOnCaptureTCP := FOnMyCaptureTCP;
end;

procedure TCustomSnoopSimpleUDP.FOnMyCaptureUDP(Sender: TObject; IPHeader: PIP_RHDR; UDPHeader: PUDP_RHDR; Data: PChar);
var
	Length: Integer;
begin
	if Assigned(FOnCaptureSimpleUDP) then
	begin
		Length := ntohs(IPHeader.Length);
		dec(Length, sizeof(IP_RHDR) + sizeof(UDP_RHDR));
		FOnCaptureSimpleUDP(Self, IPHeader, UDPHeader, Data, Length);
	end;
end;

constructor TCustomSnoopSimpleUDP.Create(AOwner: TComponent);
begin
	inherited;
	FOnCaptureUDP := FOnMyCaptureUDP;
end;

function Mac2Str(Mac: PChar): String;
var
	ch1, ch2: Byte;
	i: Integer;
begin
	Result := '';
	for i := 0 to 5 do
	begin
		ch1 := Byte(Mac[i]) and $f0;
		ch1 := ch1 shr 4;
		if ch1 > 9 then
			ch1 := ch1 + Ord('A') - 10
		else
			ch1 := ch1 + Ord('0');
		ch2 := Byte(Mac[i]) and $0f;
		if ch2 > 9 then
			ch2 := ch2 + Ord('A') - 10
		else
			ch2 := ch2 + Ord('0');
		Result := Result + Chr(ch1) + Chr(ch2);
		if i = 2 then
			Result := Result + '-';
	end;
end;

function IP2Str(IP: DWORD): String;
begin
	Result := Format('%d.%d.%d.%d', [
		(IP and $ff000000) shr 24,
		(IP and $00ff0000) shr 16,
		(IP and $0000ff00) shr 8,
		(IP and $000000ff) shr 0
	]);
end;

end.
