BSOne.SFC/Tocsg.Module/SocketMon/ThdSocketMon.pas

{*******************************************************}
{                                                       }
{       ThdSocketMon                                    }
{                                                       }
{       Copyright (C) 2022 kku                          }
{                                                       }
{*******************************************************}

unit ThdSocketMon;

interface

uses
  Tocsg.Thread, System.SysUtils, System.Classes, MagentaMonsock,
  MagentaPackhdrs, Winapi.Windows, Winapi.Messages, IPHelper,
  System.Generics.Collections;

const
  WM_SOCKETMON_NOTIFICATION = WM_USER + 5811;

type
  PConnInfo = ^TConnInfo;
  TDicConnInfo = class(TDictionary<String, PConnInfo>)
  protected
    procedure ValueNotify(const Value: PConnInfo; Action: TCollectionNotification); override;
  end;

  PSocketMonEnt = ^TSocketMonEnt;
  TSocketMonEnt = record
    PacketInfo: TPacketInfo;
    ConnInfo: TConnInfo;
  end;
  TSocketMonEntQueue = TQueue<PSocketMonEnt>;

  TThdSocketMon = class(TTgThread)
  private
    hRcvHwnd_: HWND;
    sMonIp_: String;
    MonSock_: TMonitorSocket;

    DcTcp_,
    DcUdp_: TDicConnInfo;

    qEnts_: TSocketMonEntQueue;

    procedure OnEntNotify(Sender: TObject; const Item: PSocketMonEnt; Action: TCollectionNotification);
    procedure PacketEvent(Sender: TObject; PacketInfo: TPacketInfo);
  protected
    procedure Execute; override;
  public
    Constructor Create(hRcvHwnd: HWND; sMonIp: String);
    Destructor Destroy; override;

    function GetSocketMonEnt: PSocketMonEnt;
  end;

implementation

uses
  magsubs1, Winapi.WinSock, Tocsg.Exception;

const
  sPacketLine = '%-12s %-4s %4d  %-20s > %-20s %-12s %4d %s' ;
//               01:02:03:004 UDP   109  192.168.1.201:161    > 192.168.1.109:1040   snmp           81 [0O    ]
  sHeaderLine = 'Time         Prot Plen  Source IP:Port         Dest IP:Port         Service      Dlen Packet Data' ;

{ TDicConnInfo }

procedure TDicConnInfo.ValueNotify(const Value: PConnInfo; Action: TCollectionNotification);
begin
  if Action = cnRemoved then
    Dispose(Value);
end;

{ TThdSocketMon }

Constructor TThdSocketMon.Create(hRcvHwnd: HWND; sMonIp: String);
begin
  Inherited Create;
  hRcvHwnd_ := hRcvHwnd;
  sMonIp_ := sMonIp;

  qEnts_ := TSocketMonEntQueue.Create;

  DcTcp_:= TDicConnInfo.Create;
  DcUdp_ := TDicConnInfo.Create;

  MonSock_ := TMonitorSocket.Create(nil);
  MonSock_.Addr := sMonIp;
  MonSock_.AddrMask := '255.255.255.0';
  MonSock_.OnPacketEvent := PacketEvent;
end;

Destructor TThdSocketMon.Destroy;
begin
  MonSock_.StopMonitor;
  Inherited;
  FreeAndNil(MonSock_);
  FreeAndNil(DcUdp_);
  FreeAndNil(DcTcp_);
  qEnts_.OnNotify := OnEntNotify;
  FreeAndNil(qEnts_);
end;

procedure TThdSocketMon.OnEntNotify(Sender: TObject; const Item: PSocketMonEnt; Action: TCollectionNotification);
begin
  if Action = cnRemoved then
    Dispose(Item);
end;

procedure TThdSocketMon.PacketEvent(Sender: TObject; PacketInfo: TPacketInfo);
var
//  srcip, destip, S, S2: string ;
  sRemotePort,
  sRemoteIPort: String;
  pEnt: PSocketMonEnt;
  pCInfo: PConnInfo;
begin
  if Terminated or GetWorkStop then
    exit;

  if PacketInfo.EtherProto = PROTO_IP then
  begin
    case PacketInfo.ProtoType of
      IPPROTO_TCP,
      IPPROTO_UDP :
      begin
        New(pEnt);
        ZeroMemory(pEnt, SizeOf(TSocketMonEnt));
        pEnt.PacketInfo := PacketInfo;
        sRemoteIPort := Format('%s:%d', [IPToStr(pEnt.PacketInfo.AddrDest), pEnt.PacketInfo.PortDest]);
        sRemotePort := IntToStr(pEnt.PacketInfo.PortDest); // for UDP

        pCInfo := nil;
        Lock;
        try
          if (PacketInfo.ProtoType = IPPROTO_TCP) and
             DcTcp_.ContainsKey(sRemoteIPort) then
            pCInfo := DcTcp_[sRemoteIPort]
          else
          if (PacketInfo.ProtoType = IPPROTO_UDP) and
                  DcUdp_.ContainsKey(sRemotePort) then
            pCInfo := DcUdp_[sRemotePort];
        finally
          Unlock;
        end;

        if pCInfo <> nil then
          pEnt.ConnInfo := pCInfo^;

        Lock;
        try
          qEnts_.Enqueue(pEnt);
        finally
          Unlock;
        end;
      end;
    end;
  end;

//  with PacketInfo do
//  begin
////      if (NOT FullData.Checked) and (DataLen > 96) then SetLength (DataBuf, 96) ;
//      S2 := '[' + String (DataBuf) + ']' ;
//      StringRemCntls (S2) ;
//      if EtherProto = PROTO_IP then
//      begin
//          srcip := IPToStr (AddrSrc) + ':' + IntToStr (PortSrc);   // convert 32-bit IP address into dotted ASCII
//          destip := IPToStr (AddrDest) + ':' + IntToStr (PortDest) ;
//          if ProtoType = IPPROTO_ICMP then
//              S := Format (sPacketLine, [TimeToZStr (PacketDT),
//                  GetIPProtoName (ProtoType), PacketLen,
//                      srcip , destip, Lowercase (GetICMPType (IcmpType)), DataLen, S2])
//          else
//          begin
//              if DataLen = 0 then S2 := GetFlags (TcpFlags) ;
//              S := Format (sPacketLine, [TimeToZStr (PacketDT),
//                  GetIPProtoName (ProtoType), PacketLen, srcip, destip,
//                      Lowercase (GetServiceNameEx (PortSrc, PortDest)), DataLen, S2]) ;
//          end ;
//      end
//      else
//      begin
//          S := Format (sPacketLine, [TimeToZStr (PacketDT),
//              GetEtherProtoName (EtherProto), PacketLen,
//                         MacToStr (EtherSrc), MacToStr (EtherDest), '', DataLen, S2]) ;
//      end ;
//      if hRcvHwnd_ <> 0 then
//        SendMessage(hRcvHwnd_, WM_SOCKETMON_NOTIFICATION, 0, NativeInt(S));
////      LogWin.Lines.Add (S) ;
//  end ;
end;

function TThdSocketMon.GetSocketMonEnt: PSocketMonEnt;
begin
  Lock;
  try
    if qEnts_.Count > 0 then
      Result := qEnts_.Dequeue
    else
      Result := nil;
  finally
    Unlock;
  end;
end;

procedure TThdSocketMon.Execute;
var
  ConnRows: TConnRows;
  nResult, i, nCnt: Integer;
  pEnt: PConnInfo;
  sIPort: String;
begin
  try
    MonSock_.StartMonitor;
  except
    on E: Exception do
    begin
      nLastError_ := 1;
      ETgException.TraceException(Self, E, 'Fail .. StartMonitor()');
    end;
  end;

  while not Terminated and not GetWorkStop do
  begin
    try
      Lock;
      try
        DcTcp_.Clear;
        DcUdp_.Clear;

        nResult := IpHlpTCPTable(ConnRows, AF_UNSPEC);
        if nResult = NO_ERROR then
        begin
          nCnt := Length(ConnRows);
          for i := 0 to nCnt - 1 do
          begin
            if ConnRows[i].RemotePort = 443 then
              ConnRows[i].RemotePort := ConnRows[i].RemotePort + 0;
            sIPort := Format('%s:%d', [ConnRows[i].RemoteAddr, ConnRows[i].RemotePort]);
            if DcTcp_.ContainsKey(sIPort) then
            begin
              if (ConnRows[i].ProcName <> '') then
                DcTcp_[sIPort]^ := ConnRows[i];
            end else begin
              New(pEnt);
              pEnt^ := ConnRows[i];
              DcTcp_.Add(sIPort, pEnt);
            end;
          end;
        end;

        nResult := IpHlpUDPTable(ConnRows, AF_UNSPEC);
        if nResult = NO_ERROR then
        begin
          nCnt := Length(ConnRows);
          for i := 0 to nCnt - 1 do
          begin
            sIPort := IntToStr(ConnRows[i].LocalPort);// Format('%s:%d', [ConnRows[i].RemoteAddr, ConnRows[i].RemotePort]);
            if DcUdp_.ContainsKey(sIPort) then
            begin
              if (ConnRows[i].ProcName <> '') then
                DcUdp_[sIPort]^ := ConnRows[i];
            end else begin
              New(pEnt);
              pEnt^ := ConnRows[i];
              DcUdp_.Add(sIPort, pEnt);
            end;
          end;
        end;
      finally
        Unlock;
      end;
      Sleep(2000);
    except
      on E: Exception do
        ETgException.TraceException(Self, E, 'Fail .. Execute()');
    end;
  end;
end;

end.