unit SvcMain;
{$O-}
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Menus, ActnList, ComCtrls, SvcMgr, WinSock, ShellApi,psApi;
const
WM_IBCONSVCICON = WM_USER + 1;
ANY_SIZE = 512;
CONFIG_FILE = '
IBConnections.cfg';
{ Specifies the state of the TCP connection }
MIB_TCP_STATE_CLOSED = 1;
MIB_TCP_STATE_LISTEN = 2;
MIB_TCP_STATE_SYN_SENT = 3;
MIB_TCP_STATE_SYN_RCVD = 4;
MIB_TCP_STATE_ESTAB = 5;
MIB_TCP_STATE_FIN_WAIT1 = 6;
MIB_TCP_STATE_FIN_WAIT2 = 7;
MIB_TCP_STATE_CLOSE_WAIT = 8;
MIB_TCP_STATE_CLOSING = 9;
MIB_TCP_STATE_LAST_ACK = 10;
MIB_TCP_STATE_TIME_WAIT = 11;
MIB_TCP_STATE_DELETE_TCB = 12;
type
TIBConForm =
class(TForm)
ActionList: TActionList;
actStart: TAction;
actStop: TAction;
actPause: TAction;
actContinue: TAction;
PopupMenu: TPopupMenu;
actOpen: TAction;
piOpen: TMenuItem;
actExit: TAction;
N2: TMenuItem;
piExit: TMenuItem;
N1: TMenuItem;
piStart: TMenuItem;
piStop: TMenuItem;
piPause: TMenuItem;
piContinue: TMenuItem;
StatusBar: TStatusBar;
ListView: TListView;
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure FormDestroy(Sender: TObject);
procedure ListViewColumnClick(Sender: TObject; Column: TListColumn);
procedure ListViewCompare(Sender: TObject; Item1, Item2: TListItem;
Data: Integer;
var Compare: Integer);
procedure actStartExecute(Sender: TObject);
procedure actStopExecute(Sender: TObject);
procedure actPauseExecute(Sender: TObject);
procedure actContinueExecute(Sender: TObject);
procedure actOpenExecute(Sender: TObject);
procedure actExitExecute(Sender: TObject);
private
{ Private declarations }
FFromApp: Boolean;
FAscending: Boolean;
FSortCol: Integer;
FNotifyIconData: TNotifyIconData;
procedure UpdateStatus;
function GetProcessMemorySize(ProcessID: Integer):
String;
protected
procedure WMIBConSvcIcon(
var Message: TMessage);
message WM_IBCONSVCICON;
public
{ Public declarations }
procedure Initialize(FromApp: Boolean);
end;
TIBConService =
class(TService)
protected
procedure Start(Sender: TService;
var Started: Boolean);
procedure Stop(Sender: TService;
var Stopped: Boolean);
procedure Pause(Sender: TService;
var Paused: Boolean);
procedure Continue(Sender: TService;
var Continued: Boolean);
public
function GetServiceController: TServiceController;
override;
constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0);
override;
end;
PMibTcpRow = ^TMibTcpRow;
TMibTcpRow =
packed record
dwState: DWORD;
dwLocalAddr: DWORD;
dwLocalPort: DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
dwOwningPid: DWORD;
end;
PMibTcpTable = ^TMibTcpTable;
TMibTcpTable =
packed record
dwNumEntries: DWORD;
table:
array[0..ANY_SIZE - 1]
of TMibTcpRow;
end;
PIBConRow = ^TIBConRow;
TIBConRow =
packed record
dwState: DWORD;
dwRemoteAddr: DWORD;
dwRemotePort: DWORD;
HostName:
string;
dtConnect: TDateTime;
dtDisconnect: TDateTime;
MemSize :
String
end;
PIBConTable = ^TIBConTable;
TIBConTable =
packed record
dwNumEntries: DWORD;
table:
array[0..ANY_SIZE - 1]
of TIBConRow;
end;
TIBConThread =
class(TThread)
private
FIBConTable: TIBConTable;
FCurRow: PIBConRow;
protected
procedure Execute;
override;
procedure AddConnect;
procedure RemoveConnect;
end;
TIBFindThread =
class(TThread)
protected
procedure Execute;
override;
end;
resourcestring
SApplicationName = '
InterBase Connections';
SServiceName = '
InterBaseConnections';
SFmtStr = '
%s (%s)'#9'
%s'#13#10#9'
%s: IP Address - %s, HostName - %s'#13#10#13#10#13#10;
SDTFmtStr = '
ddd mmm dd hh:nn:ss yyyy';
SFmtSingleStr = '
%-15s%-255s%-19s%-19s'#13#10;
SDTFmtSingleStr = '
mm/dd/yyyy hh:nn:ss';
SStatusLine = '
%d current connections';
const
TCP_TABLE_OWNER_PID_ALL = 5;
AF_INET = 2;
type
TCP_TABLE_CLASS = Integer;
ULONG = Longword;
function GetExtendedTcpTable(pTcpTable: Pointer; dwSize: PDWORD; bOrder: BOOL;
lAf: ULONG; TableClass: TCP_TABLE_CLASS; Reserved: ULONG): DWord;
stdcall;
external '
iphlpapi.dll'
name '
GetExtendedTcpTable';
// TCP Table + PID
var
IBConForm: TIBConForm;
IBConService: TIBConService;
IBConThread: TIBConThread;
IBFindThread: TIBFindThread;
IBPort, TimeOut: DWORD;
LogFile:
string;
SingleLine: Boolean;
ComputerName:
array[0..MAX_COMPUTERNAME_LENGTH]
of Char;
implementation
{$R *.DFM}
function FormatIP(Value: DWORD):
string;
begin
Result := Format('
%d.%d.%d.%d', [Value
and $FF,
(Value
shr 8)
and $FF,
(Value
shr 16)
and $FF,
(Value
shr 24)
and $FF]);
end;
{ TIBConForm }
procedure TIBConForm.FormCreate(Sender: TObject);
var
ConfigList: TStrings;
StartupDir:
string;
dwSize: DWORD;
WSAData: TWSAData;
begin
ConfigList := TStringList.Create;
with ConfigList
do
try
StartupDir := Copy(ParamStr(0), 1, LastDelimiter('
\', ParamStr(0)));
try
LoadFromFile(StartupDir + CONFIG_FILE);
except
on E:
Exception do
begin
MessageBox(0, PChar(E.
Message), PChar(SApplicationName), MB_OK
or MB_ICONERROR);
Halt;
end;
end;
IBPort := StrToInt(Values['
Port']);
LogFile := Values['
LogFile'];
TimeOut := StrToInt(Values['
TimeOut']);
SingleLine := StrToBool(Values['
SingleLine']);
finally
Free;
end;
Caption := SApplicationName;
with FNotifyIconData
do
begin
cbSize := SizeOf(FNotifyIconData);
Wnd :=
Handle;
uID := $EF;
uFlags := NIF_MESSAGE
or NIF_ICON
or NIF_TIP;
uCallbackMessage := WM_IBCONSVCICON;
hIcon := Forms.Application.Icon.Handle;
StrPCopy(szTip, SApplicationName);
end;
Shell_NotifyIcon(NIM_ADD, @FNotifyIconData);
FSortCol := -1;
UpdateStatus;
dwSize := SizeOf(ComputerName);
GetComputerName(ComputerName, dwSize);
SetThreadLocale($0409);
GetFormatSettings;
WSAStartup($0101, WSAData);
SetPriorityClass(GetCurrentProcess, IDLE_PRIORITY_CLASS);
end;
procedure TIBConForm.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
Hide;
Action := caNone;
end;
procedure TIBConForm.FormDestroy(Sender: TObject);
begin
Shell_NotifyIcon(NIM_DELETE, @FNotifyIconData);
WSACleanup;
end;
procedure TIBConForm.ListViewColumnClick(Sender: TObject;
Column: TListColumn);
begin
if FSortCol <> Column.
Index then
FAscending := True;
ListView.CustomSort(
nil, Column.
Index - 1);
FAscending :=
not FAscending;
FSortCol := Column.
Index;
end;
procedure TIBConForm.ListViewCompare(Sender: TObject; Item1,
Item2: TListItem; Data: Integer;
var Compare: Integer);
function AlignIP(
const IPAddress:
string):
string;
var
A:
array[0..3]
of string[4];
ip:
string;
i: Integer;
begin
Result := '
';
ip := IPAddress;
for i := 0
to High(A)
do
begin
if Pos('
.',
ip) > 0
then
A[i] := Copy(
ip, 1, Pos('
.',
ip) - 1)
else
A[i] :=
ip;
Delete(
ip, 1, Pos('
.',
ip));
end;
Result := Format('
%3s.%3s.%3s.%3s', [A[0], A[1], A[2], A[3]]);
end;
var
SortFlag: Integer;
begin
if FAscending
then SortFlag := 1
else SortFlag := -1;
if Data = -1
then
Compare := SortFlag * AnsiCompareText(AlignIP(Item1.Caption),
AlignIP(Item2.Caption))
else
Compare := SortFlag * AnsiCompareText(Item1.SubItems[Data],
Item2.SubItems[Data]);
end;
procedure TIBConForm.actStartExecute(Sender: TObject);
begin
IBConThread := TIBConThread.Create(False);
IBFindThread := TIBFindThread.Create(False);
if FFromApp
then
begin
actStart.Enabled :=
not actStart.Enabled;
actStop.Enabled := True;
actPause.Enabled := True;
actContinue.Enabled := False;
end;
end;
procedure TIBConForm.actStopExecute(Sender: TObject);
begin
IBConThread.Terminate;
IBFindThread.Terminate;
if FFromApp
then
begin
actStop.Enabled :=
not actStop.Enabled;
actStart.Enabled := True;
actPause.Enabled := False;
actContinue.Enabled := False;
ListView.Items.Clear;
UpdateStatus;
end;
end;
procedure TIBConForm.actPauseExecute(Sender: TObject);
begin
IBConThread.Suspend;
IBFindThread.Suspend;
if FFromApp
then
begin
actPause.Enabled :=
not actPause.Enabled;
actContinue.Enabled := True;
end;
end;
procedure TIBConForm.actContinueExecute(Sender: TObject);
begin
IBConThread.Resume;
IBFindThread.Resume;
if FFromApp
then
begin
actContinue.Enabled :=
not actContinue.Enabled;
actPause.Enabled := True;
end;
end;
procedure TIBConForm.actOpenExecute(Sender: TObject);
begin
Show;
ShowWindow(Forms.Application.Handle, SW_HIDE);
end;
procedure TIBConForm.actExitExecute(Sender: TObject);
begin
Forms.Application.Terminate;
end;
procedure TIBConForm.UpdateStatus;
begin
StatusBar.SimpleText := Format(SStatusLine,[ListView.Items.Count]);
end;
procedure TIBConForm.WMIBConSvcIcon(
var Message: TMessage);
var
pt: TPoint;
begin
case Message.LParam
of
WM_RBUTTONUP:
if not Visible
then
begin
SetForegroundWindow(
Handle);
GetCursorPos(pt);
PopupMenu.Popup(pt.x, pt.y);
end
else
SetForegroundWindow(
Handle);
WM_LBUTTONDBLCLK:
if Visible
then
SetForegroundWindow(
Handle)
else
actOpen.Execute;
end;
end;
procedure TIBConForm.Initialize(FromApp: Boolean);
begin
FFromApp := FromApp;
if FromApp
then
actStart.Execute
else
begin
N1.Visible := False;
actStart.Visible := False;
actStop.Visible := False;
actPause.Visible := False;
actContinue.Visible := False;
N2.Visible := False;
actExit.Visible := False;
end;
end;
{ TIBConService }
procedure ServiceController(CtrlCode: DWord);
stdcall;
begin
IBConService.Controller(CtrlCode);
end;
function TIBConService.GetServiceController: TServiceController;
begin
Result := ServiceController;
end;
constructor TIBConService.CreateNew(AOwner: TComponent; Dummy: Integer);
begin
inherited CreateNew(AOwner, Dummy);
Interactive := True;
DisplayName := SApplicationName;
Name := SServiceName;
StartType := stManual;
OnStart := Start;
OnStop := Stop;
OnPause := Pause;
OnContinue := Continue;
end;
procedure TIBConService.Start(Sender: TService;
var Started: Boolean);
begin
IBConForm.actStart.Execute;
Started := True;
end;
procedure TIBConService.Stop(Sender: TService;
var Stopped: Boolean);
begin
IBConForm.actStop.Execute;
PostMessage(IBConForm.Handle, WM_QUIT, 0, 0);
Stopped := True;
end;
procedure TIBConService.Pause(Sender: TService;
var Paused: Boolean);
begin
IBConForm.actPause.Execute;
Paused := True;
end;
procedure TIBConService.Continue(Sender: TService;
var Continued: Boolean);
begin
IBConForm.actContinue.Execute;
Continued := True;
end;
{ TIBConThread }
procedure TIBConThread.Execute;
var
TcpTable: TMibTcpTable;
HostEnt: PHostEnt;
dwSize, dwResult, i, j: DWORD;
NewConnect: Boolean;
FileHandle: Integer;
LogStr:
string;
begin
while not Terminated
do
begin
dwSize := SizeOf(TMibTcpTable);
FillChar(TcpTable, dwSize, 0);
dwResult := GetExtendedTcpTable(@TcpTable, @dwSize, True, AF_INET, TCP_TABLE_OWNER_PID_ALL, 0);
if dwResult <> NO_ERROR
then Continue;
with TcpTable
do
for i := dwNumEntries - 1
downto 0
do
if not ((table[i].dwState = MIB_TCP_STATE_ESTAB)
and
(htons(table[i].dwLocalPort) = IBPort))
then
begin
FillChar(table[i], SizeOf(TMibTcpRow), 0);
Dec(dwNumEntries);
end;
with FIBConTable
do
if dwNumEntries <> 0
then
for i := 0
to High(table)
do
if table[i].dwState <> 0
then table[i].dwState := MIB_TCP_STATE_CLOSED;
with TcpTable
do
if dwNumEntries <> 0
then
for i := 0
to High(table)
do
if table[i].dwState <> 0
then
begin
NewConnect := True;
for j := 0
to High(FIBConTable.table)
do
if table[i].dwRemotePort = FIBConTable.table[j].dwRemotePort
then
begin
NewConnect := False;
FIBConTable.table[j].dwState := table[i].dwState;
Break;
end;
if NewConnect
then
for j := 0
to High(FIBConTable.table)
do
if FIBConTable.table[j].dwState = 0
then
begin
Inc(FIBConTable.dwNumEntries);
FIBConTable.table[j].dwState := table[i].dwState;
FIBConTable.table[j].dwRemoteAddr := table[i].dwRemoteAddr;
FIBConTable.table[j].dwRemotePort := table[i].dwRemotePort;
FIBConTable.table[j].MemSize := IBConForm.GetProcessMemorySize(table[i].dwowningPid);
HostEnt := gethostbyaddr(@table[i].dwRemoteAddr, 4, PF_INET);
if Assigned(HostEnt)
then
FIBConTable.table[j].HostName := HostEnt^.h_name
else
FIBConTable.table[j].HostName := '
(Unknown)';
FIBConTable.table[j].dtConnect := Now;
if not SingleLine
then
begin
FileHandle := FileOpen(LogFile, fmOpenReadWrite
or fmShareDenyNone);
if FileHandle <> -1
then
begin
LogStr := Format(SFmtStr, [ComputerName, SApplicationName,
FormatDateTime(SDTFmtStr, FIBConTable.table[j].dtConnect),
'
Connect', FormatIP(FIBConTable.table[j].dwRemoteAddr),
FIBConTable.table[j].HostName]);
FileSeek(FileHandle, 0, 2);
FileWrite(FileHandle, PChar(LogStr)^, Length(LogStr));
FileClose(FileHandle);
end;
end;
FCurRow := @FIBConTable.table[j];
Synchronize(AddConnect);
Break;
end;
end;
with FIBConTable
do
if dwNumEntries <> 0
then
for i := 0
to High(table)
do
if table[i].dwState = MIB_TCP_STATE_CLOSED
then
begin
Dec(dwNumEntries);
table[i].dtDisconnect := Now;
FileHandle := FileOpen(LogFile, fmOpenReadWrite
or fmShareDenyNone);
if FileHandle <> -1
then
begin
if SingleLine
then
LogStr := Format(SFmtSingleStr, [FormatIP(table[i].dwRemoteAddr), table[i].HostName,
FormatDateTime(SDTFmtSingleStr, table[i].dtConnect),
FormatDateTime(SDTFmtSingleStr, table[i].dtDisconnect)])
else
LogStr := Format(SFmtStr, [ComputerName, SApplicationName,
FormatDateTime(SDTFmtStr, table[i].dtDisconnect),
'
Disconnect', FormatIP(table[i].dwRemoteAddr),
table[i].HostName]);
FileSeek(FileHandle, 0, 2);
FileWrite(FileHandle, PChar(LogStr)^, Length(LogStr));
FileClose(FileHandle);
end;
FCurRow := @table[i];
Synchronize(RemoveConnect);
FillChar(table[i], SizeOf(TIBConRow), 0);
end;
Sleep(TimeOut);
end;
end;
procedure TIBConThread.AddConnect;
begin
with IBConForm
do
begin
with ListView.Items.Add
do
begin
Caption := FormatIP(FCurRow^.dwRemoteAddr);
SubItems.Add(FCurRow^.HostName);
SubItems.Add(FormatDateTime(SDTFmtStr, FCurRow^.dtConnect));
SubItems.Add(FCurRow^.MemSize);
Data := FCurRow;
end;
UpdateStatus;
end;
end;
procedure TIBConThread.RemoveConnect;
var
Item: TListItem;
begin
with IBConForm
do
begin
Item := ListView.FindData(0, FCurRow, True, False);
if Assigned(Item)
then Item.Free;
UpdateStatus;
end;
end;
{ TIBFindThread }
procedure TIBFindThread.Execute;
begin
{ while not Terminated do
begin
if FindWindow('FB_Server', 'Firebird Server') = 0 then begin
if not IBConThread.Suspended then
IBConThread.Suspend
end
else if IBConThread.Suspended then
IBConThread.Resume;
Sleep(13000);
end; }
end;
function TIBConForm.GetProcessMemorySize(ProcessID: Integer):
String;
var
Process: THandle;
MemInfo: TProcessMemoryCounters;
begin
Process := OpenProcess(PROCESS_QUERY_INFORMATION, False, ProcessID);
if (GetProcessMemoryInfo(Process, @MemInfo, SizeOf(MemInfo)))
then
Result := IntToStr(MemInfo.WorkingSetSize
div 1024) + '
KB'
else
Result := '
';
end;
end.