Closing Connection

BIZ TMS RemoteDB
1

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.

2

Calling Disconnect from the client doesn't destroy the database in the server. It just disconnects the client database. You must destroy the TRemoteDBDatabae instance in the client, then it will effectively destroy the server side instance.

3

Wagner


As you can see in my code posted, I have subclassed the TRemoteDBDatabase to add some Message Log and breakpoints.

The problem is when to destroy the Module, I understand now that the timeout certainly was added for this reason, but I never see it happen.

When I stop the server, following your example (FServer.Free) it really destroy the Modules and the connections to the database are closed.

But I wanted to make that more dynamically, Since I place to have A LOT of connections and I cannot just let wait for timeouts. I wanted to have some kind of signaling from the client that the connection is finishing and then force the destruction of the Module.

Is there such a thing? (disconnection command that free the module)

Why timeout is not happening? (I am not changing the default 5 min that is defined on the code)


I am using XE6 update 1 VCL framework for the server

4

Actually destroying the module does not close the database. And I am not checking this right now, but seems to me a memory leak, who is freeing the ElevateDB objects created? I pass them to the Module on the anonymous proc,but there nothing freeing it.


So, I believe I need to take the control of these components, but to free them I need to know when the Module is freed.
5

Eduardo, I gave you wrong information, although this doesn't change much. Let me summarize:


1. Calling Disconnect from the client DOES destroy the respective database instance in the server.
2. The timeout is checked whenever there is a new request to the server. So, any expired instances are destroyed in the next request, and not in a specified point in time (we are investigating to change that, but worried about performance)
3. Your code seems to have a memory leak. According to your code, when the module is destroyed, it will destroy the TEDBDatabase component. But you are also creating an TEDBSession component in each connection that is never destroyed. So you must make sure that when TEDBDatabase is destroyed, the session is destroyed as well. You can do this in two ways:
a) create TEDBSession owned by TEDBDatabase (so when database is destroyed, session is destroyed as well)
b) create both components owned by another component (could by any component, for example, a data module) and pass such owner component when calling TElevateDBConnectionAdapter.Create method, so that will be destroyed when connection is discarded (which in turn will destroy both components). This technique is described here: http://tmssoftware.com/business/remotedb/doc/web/idbconnectionfactory.htm (look at the final part of the topic).
6

Wagner,


I used your direction and it worked. I made a wrapper around the database component and used it to keep objects needed to control the session and release the objects when destroyed.

It made the process of disconnecting works, made many tests and is working as expected. Thank you.

One question, is there a way to send a session text from the client to the remotedb module? I want to identify to the database who is really connected. It is pretty common to have such kind of session description to help manage the database connections.

Thanks

Eduardo
7
There is an unofficial way (subject to change in future versions):

Uses RemoteDB.Server.Wrappers, RemoteDB.Server.Module, Sparkle.HttpServer.Context

on client side, you can send custom headers this way:


type
  THackRemoteDBDatabase = class(TRemoteDBDatabase)
  end;

THackRemoteDBDatabase(RemoteDBDatabase1).OnRequestSending := procedure(Sender: TObject; Request: THttpRequest)
  begin
    Request.Headers.SetValue('custom-header', 'somevalue');
  end;



on server side, you can retrieve custom headers this way:

type
  THackRemoteDBModule = class(TRemoteDBModule)
  end;

  THackRemoteDBModule(Module).OnDBRetrieved := procedure(DB: TRemoteDatabase; C: THttpServerContext)
    var
      Value: string;
    begin
      Value := C.Request.Headers.Get('custom-header');
    end;