TSQLConnection - zamraża aplikacje przy utracie połączenia

Aplikacja klienta łączy się z serwerem po przez komponent TSQLConnection - DataSnap. Klient wysyła zapytanie do serwera które to odbiera i zaczyna realizować i serwer zanim zwróci wynik do klienta przerywam połączenie "WAN" (Klient i Serwer jest na 2 różnych komputerach). W tym momencie aplikacja klienta "zamiera" nie zgłasza żadnego wyjątku nawet jeśli wznowie połączenie WAN to i tak program klienta "wisi" na dobre. Jedyny sposób to wymuszone zamkniecie aplikacji.

Czy jest jakiś sposób abym otrzymywał jakąkolwiek informację o tym że TSQLConnection utraciło połączenie z serwerem? Czy jedynym rozwiązaniem jest obsługa TSQLConnection z poziomu np. pobocznego wątku który to jeśli nie zwraca wyniku przez x - sekund to generuje wyjątek?

U wujka google jest wiele informacji o tym jak rozwiązać problem utraty połączenia klient-serwer ale tylko po stronie serwera.

Zamieszczam przykładowy program: po zalogowaniu klienta i kliknięciu przycisku "Wyślij żądanie" mamy 10 sekund na to aby przerwać połączenie co powoduje piękne zawieszenie aplikacji klienta.

www.lcdk.pl/lost.rar

PRZYKŁADOWE ROZWIĄZANIE PROBLEMU - Czy takie rozwiązanie jest dobre?

type
  TDatasnap = class(TTHread)
  private
    vResult : string;
    linker: TServerMethods1Client;
    SQLConnection : TSQLConnection;
  public
    property Result : string read vResult;
    constructor Create;
  protected
    procedure Execute; override;
  end;

type TTimeOut = class(tthread)
  private
    vRed : string;
    SQL : TdataSnap;
  public
    property Wynik : string read vRed;
    constructor Create;
  protected
    procedure Execute; override;
  end;

type
  TfrmMain = class(TForm)
    Button1: TButton;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

constructor TTimeOut.Create;
begin
  inherited Create(True);
  FreeOnTerminate := false;
end;

procedure TTimeOut.Execute;
var
  X : integer;
begin
  SQL := TDataSnap.Create;
  SQL.Resume;
  X := 0;
  Repeat
    inc(X);
    if SQL.Result <> '' then break;
    sleep(1000);
  Until x = 20;
  vRed := SQL.Result;
  SQL.Free;
  if x = 20 then raise Exception.Create('Timeout');
end;


constructor TDatasnap.Create;
begin
  inherited Create(True);
  FreeOnTerminate := False;
  SQLConnection := TSQLConnection.Create(nil);
  SQLConnection.DriverName := 'DataSnap';
  SQLConnection.LoginPrompt := False;
  SQLConnection.Params.Clear;
  SQLConnection.Params.Add('DriverUnit=Data.DBXDataSnap') ;
  SQLConnection.Params.Add('CommunicationProtocol=tcp/ip') ;
  SQLConnection.Params.Add('DatasnapContext=datasnap/') ;
  SQLConnection.Params.Add('DriverAssemblyLoader=Borland.Data.TDBXClientDriverLoader,Borland.Data.DbxClientDriver,Version=19.0.0.0,Culture=neutral,PublicKeyToken=91d62ebb5b0d1b1b');
  SQLConnection.Params.Add('DriverName=DataSnap') ;
  SQLConnection.Params.Add('HostName=192.168.1.101') ;
  SQLConnection.Params.Add('port=211');
  SQLConnection.Params.Values['DSAuthenticationUser'] := 'Wątek';
end;

procedure TDatasnap.Execute;
begin
  try
    SQLConnection.Open;
    linker := TServerMethods1Client.Create(SQLConnection.DBXConnection, true);
    vResult := linker.DlugaOperacja;
  finally
    linker.Free;
  end;
end;


procedure TfrmMain.Button1Click(Sender: TObject);
var
  watek : ttimeout;
begin
  watek := ttimeout.Create;
  watek.Execute;  //Zawiesza program na czas wykonania wątku
  showmessage(watek.Wynik);
  watek.Free;
end;

Opis działania:

Klikając Button1 uruchamiam wątek TimeOut który to uruchamia wątek kolejny TDataSnap który to łączy się z serwerem wysyła zapytanie i oczekuje wyniku od serwera. W tym samym czasie wątek TimeOut czeka na wynik 20 sekund jeśli TDataSnap nie zwróci w tym czasie wyniku to generuje wyjątek o przekroczonym czasie oczekiwania na odpowiedź z serwera. I dalej wyjątek musi zostać obsłużony w naszej aplikacji.

Czy takie podejście do problemu jest poprawne?

Chyba coś nie bardzo.

  watek := ttimeout.Create;
  watek.Execute;  //Zawiesza program na czas wykonania wątku

Dlaczego nie watek.Resume; skoro startujesz wątek suspended? w ten sposób zawieszasz program przez wykonanie Metody Execute z głównego wątku i wątki w taki sposób nie mają sensu - równie dobrze możesz sobie klasę ttimeout dziedziczyć po TObject.

Fakt to już chyba zmęczenie poniżej poprawiony mój tok myślenia :)

type
  TDatasnap = class(TTHread)
  private
    vResult : string;
    linker: TServerMethods1Client;
    SQLConnection : TSQLConnection;
  public
    property Result : string read vResult;
    constructor Create;
  protected
    procedure Execute; override;
  end;

type
  TfrmMain = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    function DataSnap: String;

    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

constructor TDatasnap.Create;
begin
  inherited Create(True);
  FreeOnTerminate := False;
  SQLConnection := TSQLConnection.Create(nil);
  SQLConnection.DriverName := 'DataSnap';
  SQLConnection.LoginPrompt := False;
  SQLConnection.Params.Clear;
  SQLConnection.Params.Add('DriverUnit=Data.DBXDataSnap') ;
  SQLConnection.Params.Add('CommunicationProtocol=tcp/ip') ;
  SQLConnection.Params.Add('DatasnapContext=datasnap/') ;
  SQLConnection.Params.Add('DriverAssemblyLoader=Borland.Data.TDBXClientDriverLoader,Borland.Data.DbxClientDriver,Version=19.0.0.0,Culture=neutral,PublicKeyToken=91d62ebb5b0d1b1b');
  SQLConnection.Params.Add('DriverName=DataSnap') ;
  SQLConnection.Params.Add('HostName=192.168.1.101') ;
  SQLConnection.Params.Add('port=211');
  SQLConnection.Params.Values['DSAuthenticationUser'] := 'Wątek';
end;

procedure TDatasnap.Execute;
begin
  try
    SQLConnection.Open;
    linker := TServerMethods1Client.Create(SQLConnection.DBXConnection, true);
    vResult := linker.DlugaOperacja;
  finally
    linker.Free;
  end;
end;

function TfrmMain.DataSnap: String;
var
  X : integer;
  SQL : TDataSnap;
begin
  SQL := TDataSnap.Create;
  SQL.Resume;
  X := 0;
  Repeat
    inc(X);
    if SQL.Result <> '' then break;
    sleep(1000);
  Until x = 20;
  Result := SQL.Result;
  SQL.Free;
  if x = 20 then raise Exception.Create('Timeout');
end;

procedure TfrmMain.Button1Click(Sender: TObject);
begin
  showmessage(DataSnap);
end;

Nie używałem nigdy DataSnap.
Domyślam się, że próbowałeś dodać parametr Params.Values['ConnectTimeout'] := '3000'; ? Ponoć jest z tym jakiś problem, ale wolę się upewnić, że próbowałeś.
Co do kodu obawiam się jeszcze, że SQL.Free; i tak nie zadziała jeśli będzie wątek zawieszony - zwolnienie wątku odbędzie się tylko gdy Metoda Execute wykona się w całości poprawnie, żeby to sprawdzić możesz dodać obsługę zdarzenia OnTerminate. Tutaj będzie chyba konieczne zabicie wątku po upływie timeout'a funkcją TerminateThread(SQL.ThreadId);.

Tak o tym wiem. Chciałem przedstawić tylko ideę jak otrzymywać wyjątek Timeout. A jest duży problem z tym i różnie sobie z tym radzą. Ja zamierzam przebudować komponent tSQLConnection tak aby dodać przynajmniej zdarzenie onLostConnection;

Dlaczego nie wykonuję mi się procedura Destroy w TDataSnap?

unit RClient;

interface

uses
  Winapi.Windows, System.SysUtils, System.Classes, Data.DB, Data.SqlExpr, Metody, Dialogs;

type
  TDataSnap = class(TTHread)
  private
    hEvent: THandle;
    vResult: string;
    linker: TServerMethods1Client;
    SQLConnection: TSQLConnection;
  public
    property Result: string read vResult;
    property SQL: TSQLConnection read SQLConnection write SQLConnection;
    constructor Create(var hDataSnap: THandle);
    destructor Destroy;
    procedure Awake;
  protected
    procedure Execute; override;
  end;

  TTimeOut = procedure(Sender: TObject; var VisibleException: boolean) of object;

type
  TRafloClient = class(TComponent)
  private
    hDataSnap : THandle;
    fTimeOut: TTimeOut;
    SQL: TDataSnap;
    fTime: Integer;
    fAdress: string;
    fPort: string;
    fUserName: string;
    fPassword: string;
    procedure CreateConnection(var SQL: TDataSnap);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function GetTest: String;
    procedure Connect;
    procedure Disconnect;
  published
    property Adress: string read fAdress write fAdress;
    property Port: string read fPort write fPort;
    property UserName: string read fUserName write fUserName;
    property Password: string read fPassword write fPassword;
    property TimeOut: Integer read fTime write fTime default 10000;
    property OnTimeOut: TTimeOut read fTimeOut write fTimeOut;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Raflo Component', [TRafloClient]);
end;

constructor TDataSnap.Create(var hDataSnap: THandle);
begin
  inherited Create(False);
  hEvent := CreateEvent(nil, False, False, nil);
  if hEvent = 0 then
    raise Exception.Create('Unable to create hEvent in TDataSnap');
  hDataSnap := Handle;
  FreeOnTerminate := True;
  SQLConnection := TSQLConnection.Create(nil);
  SQLConnection.DriverName := 'DataSnap';
  SQLConnection.LoginPrompt := False;
  SQLConnection.Params.Clear;
  SQLConnection.Params.Add('DriverUnit=Data.DBXDataSnap');
  SQLConnection.Params.Add('CommunicationProtocol=tcp/ip');
  SQLConnection.Params.Add('DatasnapContext=datasnap/');
  SQLConnection.Params.Add
    ('DriverAssemblyLoader=Borland.Data.TDBXClientDriverLoader,Borland.Data.DbxClientDriver,Version=19.0.0.0,Culture=neutral,PublicKeyToken=91d62ebb5b0d1b1b');
  SQLConnection.Params.Add('DriverName=DataSnap');
  SQLConnection.Params.Add('HostName=localhost');
  SQLConnection.Params.Add('port=211');
  SQLConnection.Params.Add('DSAuthenticationUser=');
  SQLConnection.Params.Add('DSAuthenticationPassword=');
end;

procedure TDataSnap.Awake;
begin
  PulseEvent(hEvent);
end;

destructor TDataSnap.Destroy;
begin
  try
    SQLConnection.Close;
  finally
    SQLConnection.Free;
  end;
  CloseHandle(hEvent);
  inherited Destroy;
end;

procedure TDataSnap.Execute;
begin
  while not Terminated do
  begin
    WaitForSingleObject(hEvent, INFINITE);
    if Terminated then
        Exit;
    vResult := 'Wynik';
  end;
end;

constructor TRafloClient.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  CreateConnection(SQL);
  fTime := 10000;
end;

destructor TRafloClient.Destroy;
var
  lpCreationTime: _FileTime;
  lpExitTime: _FileTime;
  lpKarnelTime: _FileTime;
  lpUserTime: _FileTime;
begin
  { Sprawdź czy wątek istnieje / jest uruchomiony }
  if GetThreadTimes(hDataSnap, lpCreationTime, lpExitTime, lpKarnelTime, lpUserTime) then
  begin
    SQL.Terminate;
    SQL.Awake;
    { Jeśli czas na zamkniecie wątku minął zabij go gwałtownie }
    If WaitForSingleObject(hDataSnap, 5000) = WAIT_TIMEOUT then
      TerminateThread(hDataSnap, 0);
  end;
  inherited Destroy;
end;

procedure TRafloClient.CreateConnection(var SQL: TDataSnap);
begin
  SQL := TDataSnap.Create(hDataSnap);
  SQL.SQL.Params.Values['HostName'] := fAdress;
  SQL.SQL.Params.Values['Port'] := fPort;
  SQL.SQL.Params.Values['DSAuthenticationUser'] := fUserName;
  SQL.SQL.Params.Values['DSAuthenticationPassword'] := fPassword;
end;

function TRafloClient.GetTest;
var
  X: Integer;
  CzyRaise: boolean;
begin
  CzyRaise := True;
  SQL.Awake;
  X := 0;
  Repeat
    inc(X);
    if SQL.Result <> '' then
      break;
    sleep(100);
  Until X >= fTime div 100;
  if X >= fTime div 100 then
    if assigned(OnTimeOut) then
      OnTimeOut(Self, CzyRaise);
  Result := SQL.Result;
end;

end.

override?

To była pierwsza rzecz jaką chiałęm zrobić ale jeśli dopiszę override do Destroy to kompilator wywala błąd: "Method 'Destroy' not found in base class".

Przykładowa (działająca) klasa dziedzicząca po TThread jak u ciebie:

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    procedure Button1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

  TTest = class (TThread)
    constructor Create;
    destructor Destroy; override;
    procedure Execute; override;
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

{ TTest }

constructor TTest.Create;
begin
  inherited Create(false);
  FreeOnTerminate := false;
end;

destructor TTest.Destroy;
begin
  Beep;
  inherited Destroy;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Test: TTest;
begin
  Test := TTest.Create;
  Test.Free;
end;

procedure TTest.Execute;
begin
  inherited;

end;

end.

Dziwne dopiero przeinstalowanie delphi pomogło.

Ale jedna rzecz w którą nie mogę uwierzyć to to że datasnap jest mocno rozwinięta w XE a nadal TSQLConnection nie obsługuje Timeout. Używam Delphi Xe5.

Niewierze w to że nie ma prostszego rozwiązania na mój problem. Nie uwierzę w to także że Embarcadero po tylu latach nie naprawiło tego błędu, że jedno głupie wypięcie kabelka od internetu zawiesza całą aplikację lub wątek.