Did decide to *cough* close the dbconnection when done:
program netboss;
{$mode objfpc}{$H+}
uses
{$IFDEF UNIX}
{$IFDEF UseCThreads}
cthreads,
{$ENDIF}
{$ENDIF}
Classes,
SysUtils,
processutils,
{$ifdef unix}
opensshwrapper,
{$endif}
{$ifdef mswindows}
ClientSSH2,
{$endif}
sqldb,
IBConnection,
strutils;
{
Firebird database:
CREATE TABLE CONNECTIONS
(
ID INTEGER NOT NULL,
PROTOCOL VARCHAR(10),
LOCALHOST VARCHAR(255),
LOCALPORT VARCHAR(15) CHARACTER SET NONE,
REMOTEHOST VARCHAR(255),
REMOTEPORT VARCHAR(15) CHARACTER SET NONE,
WHENCONNECTED TIMESTAMP,
CONSTRAINT CONNECTIONS_PK_1 PRIMARY KEY (ID)
);
GRANT DELETE, INSERT, REFERENCES, SELECT, UPDATE
ON CONNECTIONS TO SYSDBA WITH GRANT OPTION;
SET TERM ^ ;
CREATE TRIGGER CONNECTIONS_ID_GEN FOR CONNECTIONS ACTIVE
BEFORE INSERT POSITION 0
AS BEGIN
IF (NEW.ID IS NULL OR NEW.ID = 0) THEN
NEW.ID = GEN_ID(connections_ID_Gen, 1);
END^
SET TERM ; ^
}
type
{ TWorkerClass }
TWorkerClass = class(TObject)
private
FDBServer: string;
FDBUser: string;
FDBPassword: string;
FDBDatabase: string;
FPrivateKeyFile: string;
//Private key for SSH communication. Assumes key is same for all devices...
FFSServerIP: string;
//Router IP address; should be user customisable
FFSServerPort: integer; //Port to use for ssh access
FFSServerUser: string; //Username for ssh/telnet access to local router
public
// Runs actual job; if TFTPTimer were used, Sender would be needed.
procedure TimerCalled(Sender: TObject);
constructor Create;
destructor Destroy; override;
end;
{ TWorkerClass }
constructor TWorkerClass.Create;
begin
try
//FFSServerHostType := htLinux; //our router is linux
// Userl customization - this file should be protected
// If you hit compile errors here, please copy confidential_sample.inc to confidential.inc
// and adjust contents to match your passwords etc
{$include confidential.inc}
// Try to find private key in application directory or ~/ssh/ or home folder
if FPrivateKeyFile='' then
raise Exception.Create('Private key file not specified. It is required.');
if not(FileExists(FPrivateKeyFile)) then
FPrivateKeyFile:=IncludeTrailingPathDelimiter(ExtractFilePath(ParamStr(0)))+ExtractFileName(FPrivateKeyFile);
if not(FileExists(FPrivateKeyFile)) then
FPrivateKeyFile:=IncludeTrailingPathDelimiter(ExpandFileName('~/.ssh'))+ExtractFileName(FPrivateKeyFile);
if not(FileExists(FPrivateKeyFile)) then
FPrivateKeyFile:=IncludeTrailingPathDelimiter(ExpandFileName('~'))+ExtractFileName(FPrivateKeyFile);
if (FPrivateKeyFile <> '') and (not fileexists(FPrivateKeyFile)) then
raise Exception.CreateFmt('Private key file %s not found. Aborting.',[FPrivateKeyFile]);
//todo: check permissions for private key are correct: go-rwx
except
on E: Exception do
begin
writeln('TWorkerClass.Create: error: exception '+E.Message);
halt(128);
end;
end;
end;
destructor TWorkerClass.Destroy;
begin
inherited Destroy;
end;
procedure TWorkerClass.TimerCalled(Sender: TObject);
var
{$ifdef mswindows}
SSHClient: TTelnetSSHClient;
{$else}
SSHClient: TOpenSSH;
{$endif}
DBConnection: TIBConnection;
InsertQuery: TSQLQuery;
NatOutput: TStringList;
NetstatOutput: TStringList; //output from netstat
LastErrorText: string;
Trans: TSQLTransaction;
WhenRun: TDateTime;
i: integer;
begin
NatOutput:=TStringList.Create;
NetstatOutput:=TStringList.Create;
DBConnection := TIBConnection.Create(nil);
Trans:=TSQLTransaction.Create(nil);
InsertQuery:=TSQLQuery.Create(nil);
{$ifdef mswindows}
SSHClient := TTelnetSSHClient.Create;
{$else}
SSHClient := TOpenSSH.Create;
{$endif}
try
try
SSHClient.HostName := FFSServerIP;
SSHClient.Port := IntToStr(FFSServerPort);
SSHClient.UserName := FFSServerUser;
SSHClient.Password := ''; //assume private key without key file
SSHClient.PrivateKeyFile := FPrivateKeyFile;
SSHClient.ProtocolType := ptSSH;
LastErrorText := SSHClient.Connect;
if not SSHClient.Connected then
raise Exception.CreateFmt('TimerCalled: error connecting: %s',[LastErrorText]);
// Run actual command
WhenRun := now;
// Connections directly to/from router: -t -u: tcp/udp; -W wide
NetstatOutput.Text := SSHClient.CommandResult('netstat -t -u -W');
// NAT connections via router; -x: extended hostname (i.e. wide)
NatOutput.Text := SSHCLient.CommandResult('netstat-nat -x');
// Assume we can run exit to logoff
// Note we do not wait for server to return; some broken
// telnet implementations just hang here
SSHClient.Command('exit');
// Manual pause to give remote side time to respond
Sleep(80);
// Logout+disconnect:
SSHClient.Disconnect;
except
on E: Exception do
begin
writeln('TimerCalled: Error connecting via SSH. Exception message: '+E.Message);
end;
end;
// Output results.
try
DBConnection.HostName := FDBServer;
DBConnection.DatabaseName := FDBDatabase;
DBConnection.UserName := FDBUser;
DBConnection.Password := FDBPassword;
DBConnection.Transaction:=Trans;
DBConnection.Connected:=true;
InsertQuery.DataBase:=DBConnection;
InsertQuery.SQL.Text:=
'insert into connections (protocol,localhost,localport,remotehost,'+
'remoteport,whenconnected) '+
'values (:protocol,:localhost,:localport,:remotehost,:remoteport,:'+
'whenconnected); ';
if not Trans.Active then
Trans.StartTransaction;
for i := 0 to NetstatOutput.Count - 1 do
begin
// filter out only netstat tcp/udp sockets
// 0 & 272 are receive q, send q, can be ignored
//tcp 0 272 router.intra.lan:38414 devsrver1.intra.lan:41792
if (copy(NetstatOutput[i],1,length('tcp'))='tcp') or
(copy(NetstatOutput[i],1,length('udp'))='udp') then
begin
InsertQuery.Params.ParamByName('whenconnected').AsDateTime:=WhenRun;
InsertQuery.Params.ParamByName('protocol').AsString:=ExtractWord(1,NetstatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('localhost').AsString:=ExtractWord(4,NetstatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('localport').AsString:=ExtractWord(5,NetstatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('remotehost').AsString:=ExtractWord(6,NetstatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('remoteport').AsString:=ExtractWord(7,NetstatOutput[i],[#9,' ',':']);
InsertQuery.ExecSQL;
end;
end;
for i := 0 to NatOutput.Count - 1 do
begin
// filter out header only use detail recors:
// tcp ahost.intra.lan:54796 seadl-cont.mail.com:imaps ESTABLISHED
if (copy(NatOutput[i],1,length('tcp'))='tcp') or
(copy(NatOutput[i],1,length('udp'))='udp') then
begin
InsertQuery.Params.ParamByName('whenconnected').AsDateTime:=WhenRun;
InsertQuery.Params.ParamByName('protocol').AsString:=ExtractWord(1,NatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('localhost').AsString:=ExtractWord(2,NatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('localport').AsString:=ExtractWord(3,NatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('remotehost').AsString:=ExtractWord(4,NatOutput[i],[#9,' ',':']);
InsertQuery.Params.ParamByName('remoteport').AsString:=ExtractWord(5,NatOutput[i],[#9,' ',':']);
InsertQuery.ExecSQL;
end;
end;
Trans.Commit;
DBConnection.Close;
except
on D: EIBDatabaseError do
begin
writeln('TimerCalled: Database problems. Database error code: ',D.GDSErrorCode,' message: '+D.Message);
end;
on E: Exception do
begin
writeln('TimerCalled: Database problems. Exception message: '+E.Message);
end;
end;
finally
NatOutput.Free;
NetstatOutput.Free;
InsertQuery.Free;
DBConnection.Free;
Trans.Free;
SSHClient.Free;
end;
end;
// Write output to console if debugging
// Deliberately called the same as the Lazarus equivalent
procedure Debugln(const Message: string);
begin
{$IFDEF DEBUG}
writeln(formatdatetime('hh:mm:ss',Now,[])+': '+Message);
{$ENDIF}
end;
var
Worker: TWorkerClass;
StartTime: TDateTime;
Interval: TDateTime;
begin
Interval:=EncodeTime(0,15,0,0); //quarter of an hour
Worker := TWorkerClass.Create;
try
while (True) do
begin
try
debugln('ready to call job');
Worker.TimerCalled(nil); //run job
debugln('job called');
StartTime:=now;
while (now-StartTime<Interval) do
begin
debugln('sleeping 20 seconds');
sleep(20000); //yield 20 seconds to other processes. Better way?
//handle sighup?
end;
except
on E: Exception do
begin
writeln('Main loop error: exception message: '+E.Message);
halt(129);
end;
end;
end;
finally
Worker.Free;
end;
end.
Edit... no difference, still an AV on my prod system...