Hi there,
I could succesfully make a connection to my server made with RemoteDB.
However I see that the connection remains active even after my client disconnect.
On the client side I call the IBConnection.Disconnect to make sure.
I see on my server that the added Module is destroyed.
But what I understood is that the TDBConnectionFactory that is passed when adding the module calls my anonymous procedure to make the database connection (elevatedb) and there is nothing when there is a need to destroy it. It makes the objects created for elevatedb connection remain in memory.
The time out is not making difference. I am monitoring the sessions on elevatedb and they remain there forever. When i execute FServer,Free everything gets closed.
So, how to control the database.close and release the class from memory (elevatedb classes) ?
Main code:
unit MainForm;
interface
uses
edbcomps,
yashar.yService,
Nahar.RemoteDB.ServerModule,
RemoteDB.Drivers.Base,
RemoteDB.Drivers.ElevateDB,
RemoteDB.Server.Module,
RemoteDB.Drivers.Interfaces,
Sparkle.HttpSys.Server,
Sparkle.HttpSys.Config,
Winapi.ActiveX,
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls,
CoolTrayIcon, Vcl.Menus, Vcl.ExtCtrls;
const
ServerUrl = 'http://localhost:2001/nahar';
type
TMemoHelper = class helper for TMemo
Private
function GetLineNo : integer;
procedure SetLineNo(NewLineNo : integer);
public
property LineNo : integer Read GetLineNo Write SetLineNo;
end;
TFormMain = class(TForm)
pnl1: TPanel;
lbl1: TLabel;
pmTray: TPopupMenu;
Abrir1: TMenuItem;
N1: TMenuItem;
Sair1: TMenuItem;
CoolTrayIcon: TCoolTrayIcon;
pnl3: TPanel;
pgcMain: TPageControl;
tsStatus: TTabSheet;
mmoLog: TMemo;
pnl2: TPanel;
btn1: TButton;
btnStart: TButton;
btnStop: TButton;
edtServerUrl: TEdit;
lbl2: TLabel;
btn2: TButton;
cbDetails: TCheckBox;
procedure btn1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure Abrir1Click(Sender: TObject);
procedure Sair1Click(Sender: TObject);
procedure btnStartClick(Sender: TObject);
procedure btnStopClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btn2Click(Sender: TObject);
private
FServer: THttpSysServer;
procedure WMTimer(var Message: TMessage);
function CreateIDBConnection(ADatabase: string): IDBConnection;
function CreateElevateDBConnection(ADatabase: string): TEDBDatabase;
procedure TestUrlReserved(AUrl: string);
public
procedure Log(AMessage: string; ADetail: boolean);
procedure StartServer;
procedure StopServer;
end;
var
FormMain: TFormMain;
implementation
{$R *.dfm}
procedure TFormMain.Abrir1Click(Sender: TObject);
begin
CoolTrayIcon.ShowMainForm;
end;
procedure TFormMain.btn1Click(Sender: TObject);
begin
CoolTrayIcon.HideMainForm;
end;
procedure TFormMain.btn2Click(Sender: TObject);
begin
mmoLog.Clear;
end;
procedure TFormMain.btnStartClick(Sender: TObject);
begin
StartServer;
btnStart.Enabled := false;
btnStop.Enabled := true;
end;
procedure TFormMain.btnStopClick(Sender: TObject);
begin
StopServer;
btnStart.Enabled := true;
btnStop.Enabled := false;
end;
procedure TFormMain.TestUrlReserved(AUrl: string);
var
Config: THttpSysServerConfig;
begin
Config := THttpSysServerConfig.Create;
try
if not Config.IsUrlReserved(AUrl) then
Config.ReserveUrl(AUrl);
finally
Config.Free;
end;
end;
procedure TFormMain.FormCreate(Sender: TObject);
begin
CoolTrayIcon.HideMainForm;
SetTimer(Handle, 1, 1000, nil);
edtServerUrl.Text := ServerUrl;
CoInitializeEx(nil, COINIT_MULTITHREADED);
TestUrlReserved(ServerURL + '/standard');
TestUrlReserved(ServerURL + '/global');
if yIsService then
StartServer;
end;
procedure TFormMain.FormDestroy(Sender: TObject);
begin
StopServer;
end;
procedure TFormMain.Log(AMessage: string; ADetail: boolean);
begin
if ADetail and not cbDetails.Checked then
exit;
mmoLog.Lines.Add(DateTimeToStr(now)+' : '+AMessage);
if mmoLog.Lines.Count > 1000 then
begin
mmoLog.Lines.Delete(0);
mmoLog.LineNo := mmoLog.Lines.Count - 1;
end;
end;
procedure TFormMain.Sair1Click(Sender: TObject);
begin
Application.Terminate;
end;
procedure TFormMain.WMTimer(var Message: TMessage);
begin
KillTimer(Handle, 1);
CoolTrayIcon.HideMainForm;
end;
function TFormMain.CreateElevateDBConnection(ADatabase: string): TEDBDatabase;
var
FEDBDatabase: TEDBDatabase;
FEDBSession: TEDBSession;
begin
// session ---------------------
FEDBSession := TEDBSession.Create(nil);
FEDBSession.KeepConnections := true;
FEDBSession.Name := 'NaharSRV';
FEDBSession.AutoSessionName := True; //required for threading
FEDBSession.LoginUser := 'Administrator';
FEDBSession.LoginPassword := 'EDBDefault';
FEDBSession.SessionDescription := '['+ADatabase+']';
FEDBSession.SessionType := stRemote;
FEDBSession.RemoteHost := 'localhost';
FEDBSession.RemotePort := 12010;
// database ---------------------
FEDBDatabase := TEDBDatabase.Create(nil);
FEDBDatabase.Database := ADatabase;
FEDBDatabase.DatabaseName := ADatabase;
FEDBDatabase.SessionName := FEDBSession.SessionName;
FEDBSession.Open;
result := FEDBDatabase;
end;
function TFormMain.CreateIDBConnection(ADatabase: string): IDBConnection;
begin
Result := TElevateDBConnectionAdapter.Create(CreateElevateDBConnection(ADatabase), true);
end;
procedure TFormMain.StartServer;
begin
FServer := THttpSysServer.Create;
try
FServer.AddModule(TNaharRemoteDBModule.Create(ServerURL+'/standard', TDBConnectionFactory.Create(
function: IDBConnection
begin
Result := CreateIDBConnection('standard');
Log('Nova Conexão: standard', false);
end),
procedure(AMessage: string; ADetail: boolean)
begin
Log(AMessage, ADetail);
end
));
FServer.AddModule(TNaharRemoteDBModule.Create(ServerURL+'/global', TDBConnectionFactory.Create(
function: IDBConnection
begin
Result := CreateIDBConnection('global');
Log('Nova Conexão: global', false);
end),
procedure(AMessage: string; ADetail: boolean)
begin
Log(AMessage, ADetail);
end
));
FServer.Start;
Log('Server Started', false);
except
FreeAndNil(FServer);
raise;
end;
end;
procedure TFormMain.StopServer;
begin
if FServer.IsRunning then
FServer.Stop;
FreeAndNil(FServer);
Log('Server Stopped', false);
end;
{ TMemoHelper }
function TMemoHelper.GetLineNo: integer;
begin
Result := Perform(EM_LINEFROMCHAR,SelStart,0)
end;
procedure TMemoHelper.SetLineNo(NewLineNo: integer);
begin
if NewLineNo < 0 then NewLineNo:=0;
if NewLineNo > Lines.Count then NewLineNo:=Lines.Count;
SelStart := Perform(EM_LINEINDEX,NewLineNo,0);
Perform(EM_SCROLLCARET, NewLineNo,0); // Should LinePos be NewLineNo ?? //
end;
end.
I have subclassed teh TRemoreDBModule trying to get more info and control, but there are not much:
unit Nahar.RemoteDB.ServerModule;
interface
uses
Sparkle.HttpServer.Module,
Sparkle.HttpServer.Context,
RemoteDB.Server.Module,
RemoteDB.Drivers.Interfaces,
System.SysUtils;
type
TMainLogProcedure = reference to procedure(AMessage: string; ADetails: boolean);
TNaharRemoteDBModule = class(TRemoteDBModule)
private
FLog: TMainLogProcedure;
procedure Log(AMessage: string; ADetail: boolean);
public
procedure ProcessRequest(const Context: THttpServerContext); override;
constructor Create(const ABaseUrl: string; AFactory: IDBConnectionFactory; ALog: TMainLogProcedure); reintroduce;
destructor Destroy; override;
end;
implementation
{ TNaharRemoteDBModule }
constructor TNaharRemoteDBModule.Create(const ABaseUrl: string; AFactory: IDBConnectionFactory; ALog: TMainLogProcedure);
begin
inherited Create(ABaseUrl, AFactory);
FLog:= ALog;
end;
destructor TNaharRemoteDBModule.Destroy;
begin
FLog('Finalizando Conexão: '+BaseUri.OriginalUri, false);
inherited;
end;
procedure TNaharRemoteDBModule.Log(AMessage: string; ADetail: boolean);
begin
if Assigned(FLog) then
FLog(AMessage, ADetail);
end;
procedure TNaharRemoteDBModule.ProcessRequest(const Context: THttpServerContext);
begin
inherited;
Log(Context.Request.Uri.OriginalUri, true);
end;
end.