monpcap.pas

Magenta Systems Internet Packet Monitoring Components are a set of Delphi components designed to cap

begin
    if NOT Str2IP (IPAddr, InIPAddr) then exit ;
    FIgnoreIPList.AddSorted (Pointer (InIPAddr.S_addr), @CompareFNext) ; 
end ;

procedure TMonitorPcap.ClearIgnoreIP ;
begin
    FIgnoreIPList.Clear ;
end ;

// convert seconds since 1 Jan 1970 (UNIX time stamp) to proper Delphi stuff
// and micro seconds 

function UnixStamptoDT (stamp: TunixTimeVal): TDateTime ;
begin
    result := ((stamp.tv_Sec / SecsPerDay) + 25569) +
                                    ((stamp.tv_uSec / 1000000) / SecsPerDay) ;
end ;

procedure TMonitorPcap.MonDataAvailable (const Header: Ppcap_pkthdr ; const PackPtr: Pchar) ;
var
    hdrlen, iploc: integer ;
    ethernethdr: PHdrEthernet ;
    iphdr: PHdrIP;
    tcphdr: PHdrTCP;
    udphdr: PHdrUDP;
    PacketInfo: TPacketInfo ;  // the data we return in the event

    procedure GetDataByOffset (offset: integer) ;
    var
        datastart: PChar ;
    begin
        datastart := PChar (PChar (iphdr) + offset) ;
        with PacketInfo do
        begin
            if ntohs (iphdr.tot_len) < (Header.Len - OFFSET_IP) then
                DataLen := ntohs (iphdr.tot_len) - offset
            else
                DataLen := Header.Len - OFFSET_IP - offset;
            if DataLen = 0 then exit ;
            if FIgnoreData then exit ;
            SetLength (DataBuf, DataLen) ;
            Move (datastart^, DataBuf [1], DataLen) ;
        end ;
    end;

begin
    FillChar (PacketInfo, Sizeof(PacketInfo), 0) ;
    with PacketInfo do
    begin
        PacketLen := Header.Len ;
        if PacketLen <= 0 then exit ;
        ethernethdr := PHdrEthernet (PackPtr) ;
        EtherProto := ntohs (ethernethdr.protocol) ;
        EtherSrc := ethernethdr.smac ;
        EtherDest := ethernethdr.dmac ;
        SendFlag := CompareMem (@EtherSrc, @FAdapterMac, SizeOf (TMacAddr)) ;
        PacketDT := UnixStamptoDT (Header.ts) + FLocalBiasUTC ; // Unix time stamp correct to local time

     // internet layer IP, lots to check
        if EtherProto = PROTO_IP then
        begin
            iphdr := PHdrIP (Pchar (PackPtr) + OFFSET_IP) ;  // IP header is past ethernet header
            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

          // 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 (PChar (iphdr) + hdrlen)^ ;
                    GetDataByOffset (hdrlen) ;
                end
                else
                begin
                    if ProtoType = IPPROTO_TCP then
                    begin
                        tcphdr := PHdrTCP (PChar(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 (PChar (iphdr) + hdrlen) ;
                        PortSrc := ntohs (udphdr.src_port) ;
                        PortDest := ntohs (udphdr.dst_port) ;
                        GetDataByOffset (hdrlen + Sizeof (THdrUDP));
                    end;
                end;
                FOnPacketEvent (Self, PacketInfo) ;
            end ;
        end
        else

     // otherwise ARP or something more obscure
        begin
         //   if FIgnoreLAN then exit ;
            if FIgnoreNonIP then exit ;
            if SendFlag then
            begin
                inc (FTotSendBytes, packetlen) ;
                inc (FTotSendPackets) ;
            end
            else
            begin
                inc (FTotRecvBytes, packetlen) ;
                inc (FTotRecvPackets) ;
            end ;
            if Assigned (FOnPacketEvent) then
            begin
                DataLen := PacketLen - OFFSET_IP ;
                if DataLen <= 0 then exit ;
                SetLength (DataBuf, DataLen) ;
                Move (Pchar (Pchar (PackPtr) + OFFSET_IP)^, DataBuf [1], DataLen) ;
                FOnPacketEvent (Self, PacketInfo) ;
            end ;
        end ;

    end ;
end ;

procedure TMonitorPcap.StartMonitor;
var
    snaplen, mins: integer ;
begin
    if (FAdapterNameList.Count = 0) or (FMonAdapter = '') then
    begin
        FLastError := 'No Adaptors Found to Monitor' ;
        exit;
    end;
    if FConnected or (FPcapHandle <> nil) then
    begin
        FLastError := 'PCap Driver Already Running' ;
        exit;
    end;
    FAddr := Trim (FAddr) ;
    FInAddr := StrToIP (FAddr) ;  // 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 ;
    mins := GetLocalBiasUTC ;
    if mins < 0 then          // reverse minutes, -60 for GMT summer time 
        mins := Abs (mins)
    else
        mins := 0 - mins ;
    FLocalBiasUTC := mins  / (60.0 * 24.0) ;  // keep local time bias

  // open winpcap driver for specific adaptor
    FConnected := false ;
    if FIgnoreData then
        snaplen := DEFAULT_SNAPLEN
    else
        snaplen := 2000 ;
    FPcapHandle := pcap_open_live (PChar (FMonAdapter), snaplen,
                                                        FPromiscuous, 100, FLastError) ;
    if FPcapHandle = nil then exit;
//    Pcap_SetMinToCopy (FPcapHandle, 20000) ;  not sure if this is beneficial
    FAdapterMac := Pcap_GetMacAddress (FPcapHandle, FLastError) ;

  // Start Snoop Read Thread
    FPcapThread := TPcapThread.Create (true) ;
    FPcapThread.FMonitorPcap := Self ;
    FPcapThread.OnTerminate := ThreadTerminate ;
    FPcapThread.FreeOnTerminate := false;
    FPcapThread.Resume;
    FConnected := true;
end ;

procedure  TMonitorPcap.StopMonitor;
begin
    FConnected := false ;

  // stop thread
    if Assigned (FPcapThread) then
    begin
        FPcapThread.Terminate ;
        FPcapThread.WaitFor ;
        FPcapThread.Free ;
        FPcapThread := nil ;
    end ;
    if Assigned (FPcapHandle) then
    begin
        Pcap_Close (FPcapHandle) ;
        FPcapHandle := Nil ;
    end ;
end ;


end.