packhdrs.pas

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

// Compare returns < 0 if Item1 is less than Item2, 0 if they are equal
// and > 0 if Item1 is greater than Item2.
begin
    result := CompareGTMem (Item1, Item2, TrafficIPCompLen) ;  // warning record must be packed
end ;

function CompareServTraffic (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 := CompareGTMem (Item1, Item2, ServiceCompLen) ;  // warning record must be packed
end ;

constructor TTrafficClass.Create(AOwner: TComponent);
begin
    SetLength (FTrafficInfo, InitialTrafficSize) ;
    FTrafficList := TFindList.Create ;
    FTrafficList.Sorted := true ;
    FTrafficList.Capacity := InitialTrafficSize ;
    FTotTraffic := 0 ;
    SetLength (FServiceInfo, 0) ;
    FServiceList := TFindList.Create ;
    FServiceList.Sorted := true ;
    FTotService := 0 ;
    FWSocket := TWSocket.Create (AOwner) ;
    FWSocket.OnDnsLookupDone := DoneLookup ;
    FLookupBusy := false ;
end;

destructor TTrafficClass.Destroy;
begin
    Clear ;
    SetLength (FTrafficInfo, 0) ;
    FreeAndNil (FTrafficList) ;
    SetLength (FServiceInfo, 0) ;
    FreeAndNil (FServiceList) ;
    FreeAndNil (FWSocket) ;
end;

procedure TTrafficClass.Clear ;
begin
    SetLength (FTrafficInfo, InitialTrafficSize) ;
    FTrafficList.Clear ;
    FTotTraffic := 0 ;
    SetLength (FServiceInfo, 0) ;
    FServiceList.Clear ;
    FTotService := 0 ;
end;

procedure TTrafficClass.Add (PacketInfo: TPacketInfo) ;
var
    NewTraffic: TTrafficInfo ;
    TrafficRec: PTrafficInfo ;
    recnr, I: integer ;
begin
    FillChar (NewTraffic, Sizeof(NewTraffic), 0) ;
    with NewTraffic, PacketInfo do
    begin
        if EtherProto <> PROTO_IP then exit ;
        if NOT (ProtoType in [IPPROTO_TCP, IPPROTO_UDP, IPPROTO_ICMP]) then exit ;
        PackType := ProtoType ;
        if SendFlag then
        begin
            AddrLoc := AddrSrc ;
            AddrRem := AddrDest ;
            ServPort := PortDest ;
            BytesSent := PacketLen ;
            PacksSent := 1 ;
        end
        else
        begin
            AddrLoc := AddrDest ;
            AddrRem := AddrSrc ;
            ServPort := PortSrc ;
            BytesRecv := PacketLen ;
            PacksRecv := 1 ;
        end ;
        if ProtoType = IPPROTO_ICMP then
        begin
            ServPort := IcmpType ;
            if ServPort = 0 then ServPort := 8 ;  // change echo-reply to echo (ie ping)
        end
        else 
        begin
            if (ServPort >= 1024) and (PortSrc < 1024) then
                ServPort := PortSrc
            else if (ServPort >= 1024) and (PortDest < 1024) then
                ServPort := PortDest
        end ;
        LastDT := PacketDT ;
    end ;

  // see if only got a record for this traffic, update it
    if FTrafficList.Find (@NewTraffic, CompareIPTraffic, recnr) then
    begin
        TrafficRec := FTrafficList [recnr] ;
        if NOT Assigned (TrafficRec) then exit ;  // sanity check
        if CompareMem (TrafficRec, @NewTraffic, TrafficIPCompLen) then // double check for correct record
        begin
            inc (TrafficRec^.BytesSent, NewTraffic.BytesSent) ;
            inc (TrafficRec^.PacksSent, NewTraffic.PacksSent) ;
            inc (TrafficRec^.BytesRecv, NewTraffic.BytesRecv) ;
            inc (TrafficRec^.PacksRecv, NewTraffic.PacksRecv) ;
            TrafficRec^.LastDT := NewTraffic.LastDT ;
            exit ;
        end ;
    end ;

  // otherwise add a new traffic record
    if Length (FTrafficInfo) <= FTotTraffic then
    begin
        SetLength (FTrafficInfo, FTotTraffic * 2) ;  // allocate more records in dynamic array
      // must rebuild pointer list since resized array may have moved in memory
        FTrafficList.Clear ;
        FTrafficList.Capacity := FTotTraffic * 2 ;
        for I := 0 to Pred (FTotTraffic) do FTrafficList.Add (@FTrafficInfo [I]) ;
        FTrafficList.Sort (CompareIPTraffic) ;
    end ;
    NewTraffic.FirstDT := NewTraffic.LastDT ;
    FTrafficInfo [FTotTraffic] := NewTraffic ;
    FTrafficList.AddSorted (@FTrafficInfo [FTotTraffic], CompareIPTraffic) ;
    inc (FTotTraffic) ;
    LookupHosts ; // start lookup of host names
end ;

function TTrafficClass.GetUnSortTraf (item: integer): PTrafficInfo ;
begin
    if item < FTotTraffic then
        result := @FTrafficInfo [item]
    else
        FillChar (result, Sizeof(result), 0) ;
end;

function TTrafficClass.GetSortedTraf (item: integer): PTrafficInfo ;
begin
    if item < FTotTraffic then
        result := FTrafficList [item]
    else
        FillChar (result, Sizeof(result), 0) ;
end;

function TTrafficClass.GetServNameEx (PackType, ServPort: word): string ;
begin
    if PackType = IPPROTO_TCP then
        result := Lowercase (GetServName (ServPort))
    else if PackType = IPPROTO_UDP then
        result := Lowercase (GetServName (ServPort))
    else if PackType = IPPROTO_ICMP then
        result := Lowercase (GetICMPType (ServPort))
    else
        result := GetEtherProtoName (PackType) ;
end ;

function TTrafficClass.GetFmtTrafStr (item: integer): string ;
var
    TrafficRec: PTrafficInfo ;
    disploc, disprem: string ;
begin
    result := '' ;
    if item >= FTotTraffic then exit ;
    TrafficRec := FTrafficList [item] ;
    if NOT Assigned (TrafficRec) then exit ;  // sanity check
    with TrafficRec^ do
    begin
        disploc := HostLoc ;
        disprem := HostRem ;
        if disploc = '' then disploc := IPToStr (AddrLoc) ;
        if disprem = '' then disprem :=  IPToStr (AddrRem) ;
        if ServName = '' then ServName := GetServNameEx (PackType, ServPort) ;
        result := Format (sTrafficMask, [disploc, disprem, ServName,
            IntToKbyte (BytesSent), '[' + IntToKbyte (PacksSent) + ']',
                IntToKbyte (BytesRecv), '[' + IntToKbyte (PacksRecv) + ']',
                                    TimeToStr (FirstDT), TimeToStr (LastDT)  ]) ;
    end ;
end;

procedure TTrafficClass.UpdateService ;
var
    I, recnr: integer ;
    NewService: TServiceInfo ;
    ServiceRec: PServiceInfo ;

   procedure RebuildList ;
   var
        J: integer ;
   begin
        FServiceList.Clear ;
        for J := 0 to Pred (FTotService) do FServiceList.Add (@FServiceInfo [J]) ;
        FServiceList.Sort (CompareServTraffic) ;
   end ;

begin
    FServiceList.Clear ;
    FTotService := 0 ;
    if FTotTraffic = 0 then
    begin
        SetLength (FServiceInfo, 0) ;
        exit ;
    end ;
    SetLength (FServiceInfo, InitialTrafficSize) ;
    FServiceList.Capacity := InitialTrafficSize ;

// add total record
    FillChar (NewService, Sizeof(NewService), 0) ;
    NewService.ServName := 'TOTALS' ;
    FServiceInfo [FTotService] := NewService ;
    FServiceList.Add (@FServiceInfo [FTotService]) ;
    FTotService := 1 ;
    for I := 0 to Pred (FTotTraffic) do
    begin
        FillChar (NewService, Sizeof(NewService), 0) ;
        NewService.ServPort := FTrafficInfo [I].ServPort ;
        NewService.PackType := FTrafficInfo [I].PackType ;
        NewService.ServName := FTrafficInfo [I].ServName ;
        NewService.BytesSent := FTrafficInfo [I].BytesSent ;
        NewService.BytesRecv := FTrafficInfo [I].BytesRecv ;
        NewService.PacksSent := FTrafficInfo [I].PacksSent ;
        NewService.PacksRecv := FTrafficInfo [I].PacksRecv ;
        NewService.TotalHosts := 1 ;

     // increment totals
        inc (FServiceInfo [0].BytesSent, NewService.BytesSent) ;
        inc (FServiceInfo [0].PacksSent, NewService.PacksSent) ;
        inc (FServiceInfo [0].BytesRecv, NewService.BytesRecv) ;
        inc (FServiceInfo [0].PacksRecv, NewService.PacksRecv) ;
        inc (FServiceInfo [0].TotalHosts) ;

    // see if updating existing record
        if FServiceList.Find (@NewService, CompareServTraffic, recnr) then
        begin
            ServiceRec := FServiceList [recnr] ;
            if NOT Assigned (ServiceRec) then continue ; // sanity check
            if CompareMem (ServiceRec, @NewService, ServiceCompLen) then // double check for correct record
            begin
                inc (ServiceRec^.BytesSent, NewService.BytesSent) ;
                inc (ServiceRec^.PacksSent, NewService.PacksSent) ;
                inc (ServiceRec^.BytesRecv, NewService.BytesRecv) ;
                inc (ServiceRec^.PacksRecv, NewService.PacksRecv) ;
                inc (ServiceRec^.TotalHosts) ;
                continue ;    // next record
            end ;
        end ;

      // otherwise add a new service record
        if Length (FServiceInfo) <= FTotService then
        begin
            SetLength (FServiceInfo, FTotService * 2) ;  // allocate more records in dynamic array
          // must rebuild pointer list since resized array may have moved in memory
            FServiceList.Clear ;
            FServiceList.Capacity := FTotService * 2 ;
            RebuildList ;
        end ;
        FServiceInfo [FTotService] := NewService ;
        FServiceList.AddSorted (@FServiceInfo [FTotService], CompareServTraffic) ;
        inc (FTotService) ;
    end ;
    SetLength (FServiceInfo, FTotService) ;
    RebuildList ;     // keep Delphi 2006 happy 
end ;

function TTrafficClass.GetSortedServ (item: integer): PServiceInfo ;
begin
    if item < FTotService then
        result := @FServiceInfo [item]
    else
        FillChar (result, Sizeof(result), 0) ;
end ;

function TTrafficClass.GetFmtServStr (item: integer): string ;
var
    ServiceRec: PServiceInfo ;
begin
    result := '' ;
    if item >= FTotService then exit ;
    if FServiceList [0] <> @FServiceInfo [0] then  // sanity check
    begin
        result := 'Dynamic Array Memory Error' ;
        exit ;
    end;
    ServiceRec := FServiceList [item] ;
    if NOT Assigned (ServiceRec) then exit ;  // sanity check
    with ServiceRec^ do
    begin
        if ServName = '' then ServName := GetServNameEx (PackType, ServPort) ;
        result := Format (sServiceMask, [ServName,  IntToKbyte (BytesSent), '[' +
            IntToKbyte (PacksSent) + ']', IntToKbyte (BytesRecv), '[' +
                        IntToKbyte (PacksRecv) + ']', IntToCStr (TotalHosts)]) ;
    end ;
end ;

// total all traffic records

function TTrafficClass.GetTotals: TServiceInfo ;
var
    I: integer ;
begin
    FillChar (result, Sizeof(result), 0) ;
    if FTotTraffic = 0 then exit ;
    for I := 0 to Pred (FTotTraffic) do
    begin
        inc (result.BytesSent, FTrafficInfo [I].BytesSent) ;
        inc (result.BytesRecv, FTrafficInfo [I].BytesRecv) ;
        inc (result.PacksSent, FTrafficInfo [I].PacksSent) ;
        inc (result.PacksRecv, FTrafficInfo [I].PacksRecv) ;
    end ;
end ;

// look for next DNS lookup that needs doing, keep count of failures to avoid too many

procedure TTrafficClass.NextLookup ;
begin
    if FTotTraffic = 0 then exit ;
    if (FLookupLoc >= 0) then
    begin
        while FLookupLoc < FTotTraffic do
        begin
            with FTrafficInfo [FLookupLoc] do
            begin
                if (HostLoc = '') and (LookupAttempts < MaxDnsLookupAttempts) then
                begin
                    if FLookupLoc > 0 then  // copy previous record if same address
                    begin
                        if (AddrLoc.S_addr = FTrafficInfo [Pred (FLookupLoc)].AddrLoc.S_addr) then
                            HostLoc := FTrafficInfo [Pred (FLookupLoc)].HostLoc ;
                    end ;
                    if (HostLoc = '') then
                    begin
                        inc (LookupAttempts) ;
                        FWSocket.ReverseDnsLookup (IPToStr (AddrLoc)) ;
                        exit ; // async lookup started
                    end ;
                end ;
            end ;
            inc (FLookupLoc) ;
        end ;
        FLookupLoc := - 1 ;
        FLookupRem := 0 ;
    end ;
    if (FLookupRem >= 0) then
    begin
        while FLookupRem < FTotTraffic do
        begin
            with FTrafficInfo [FLookupRem] do
            begin
                if (HostRem = '') and (LookupAttempts < MaxDnsLookupAttempts) then
                begin
                    inc (LookupAttempts) ;
                    FWSocket.ReverseDnsLookup (IPToStr (AddrRem)) ;
                    exit ; // async lookup started
                end ;
            end ;
            inc (FLookupRem) ;
        end ;
        FLookupRem := - 1 ;
    end ;
    FLookupBusy := false ;
end ;

procedure TTrafficClass.DoneLookup (Sender: TObject; Error: Word);
begin
    if FLookupLoc >= 0 then
    begin
        if Error = 0 then FTrafficInfo [FLookupLoc].HostLoc :=
                                                     Lowercase (FWSocket.DnsResult) ;
        inc (FLookupLoc) ;
    end
    else if FLookupRem >= 0 then
    begin
        if Error = 0 then FTrafficInfo [FLookupRem].HostRem :=
                                                    Lowercase (FWSocket.DnsResult) ;
        inc (FLookupRem) ;
    end ;
    NextLookup ;
end ;

procedure TTrafficClass.LookupHosts ;
begin
    if FLookupBusy then exit ;
    if FTotTraffic = 0 then exit ;
    FLookupLoc := 0 ;
    FLookupRem := -1;
    NextLookup ;
end ;

end.