FireDAC DataSnap Connection Pool

First use these units as follows. Of course, also need some other units

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16


uses
  SysUtils, Classes,
  DB,Variants, Windows, Math,
  System.IniFiles,
  SynCommons,
  IPPeerClient,
  FireDAC.Comp.Client,
  FireDAC.Phys.DS,
  FireDAC.Comp.UI,
  FireDAC.Phys.Intf,
  FireDAC.Stan.Util,
  FireDAC.Stan.Def,
  FireDAC.Stan.Pool ,
  FireDAC.Stan.Error,
  FireDAC.Stan.Intf,
  Datasnap.DSHTTPLayer;

then we need a record to read configs, you can implement it as you like

 1
 2
 3
 4
 5
 6
 7
 8
 9
10


  TDSPoolConfig = record
    CleanupTimeout: string;
    ExpireTimeout: string;
    MaximumItems: string;
    Server: string;
    Port: string;
    DSUserName, DSPassword: string;
    IsHttpClient:Boolean;
    procedure ReadConfig;
  end;

ok, now come the pool

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24


TDSConnectionPool = class(TComponent)
  const
    POOL_DEFNAME = 'POOL';
  private
    DSLink: TFDPhysDSDriverLink;
    WaitCursor:TFDGUIxWaitCursor;
    fIsReConn: Boolean;
    Config:TDSPoolConfig;
    function GetCount: Integer;
    procedure LiftUp;
    procedure ShutDown;
    procedure OnError(ASender, AInitiator: TObject; var AException: Exception);
    procedure OnRecover(ASender, AInitiator: TObject;AException: Exception; var AAction: TFDPhysConnectionRecoverAction);
    procedure OnRestored(ASender:TObject);
    procedure OnLost(ASender:TObject);
  public
    constructor Create; overload;
    destructor Destroy; override;
    function Lock: TFDConnection;
    procedure WriteParams;
    property Count:Integer read GetCount;
    // if true the connection is not active
    property IsReConn:Boolean read fIsReConn write fIsReConn;
  end;

my implementation

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140


constructor TDSConnectionPool.Create;
begin
  DSLink := TFDPhysDSDriverLink.Create(self);
  WaitCursor := TFDGUIxWaitCursor.Create(self);
  Config.ReadConfig;
  LiftUp;
end;

destructor TDSConnectionPool.Destroy;
begin
  ShutDown;
  FDFreeAndNil(DSLink);
  FDFreeAndNil(WaitCursor);
  inherited;
end;

function TDSConnectionPool.Lock: TFDConnection;
begin
  Result := TFDConnection.Create(nil);
  Result.ConnectionDefName := POOL_DEFNAME;
  // make some different actions for main thread and other thread
  if GetCurrentThreadID = MainThreadID then
  begin
    Result.OnRecover := OnRecover;
    Result.OnRestored := OnRestored;
  end
  else
  begin
    Result.OnRecover := OnRecoverIgnore;
    Result.OnRestored := OnRestored;
  end;
end;

function TDSConnectionPool.GetCount: Integer;
begin
  Result := FDManager.ConnectionCount;
end;

procedure TDSConnectionPool.LiftUp;
var
  oParams: TStrings;
begin
  oParams := TStringList.Create;
  oParams.Add('DriverID=DS');
  oParams.Add('Server='+ Config.Server);
  oParams.Add('Port='+  Config.Port);
  oParams.Add('Pooled='+  'True');
  oParams.Add('POOL_CleanupTimeout='+  Config.CleanupTimeout);
  oParams.Add('POOL_ExpireTimeout='+  Config.ExpireTimeout);
  oParams.Add('POOL_MaximumItems='+  Config.MaximumItems);
  // also can support http protocol
  if Config.IsHttpClient then
    oParams.Add('Protocol='+  'http')
  else
    oParams.Add('Protocol='+  'tcp/ip');

  //oParams.Add('LoginTimeout='+'2000');
  //oParams.Add('CommunicationTimeout='+'2000');
  oParams.Add('User_Name='+  Config.DSUserName);
  oParams.Add('Password='+  Config.DSPassword);

//  FDManager.ResourceOptions.AutoReconnect := True;
  FDManager.AddConnectionDef(POOL_DEFNAME, 'DS', oParams);
  FreeAndNil(oParams);

  FDManager.Active := True;
end;

// may be used to write out params to file for debug
procedure TDSConnectionPool.WriteParams;
begin
 FileFromString(RecordSaveJSON(Config,TypeInfo(TDSPoolConfig)),
   ExtractFilePath(ParamStr(0))+'ConnParam.connection',True);
end;

procedure TDSConnectionPool.ShutDown;
begin
  FDManager.CloseConnectionDef(POOL_DEFNAME);
  FDManager.Close;
end;

procedure TDSConnectionPool.OnError(ASender, AInitiator: TObject;
  var AException: Exception);
begin
  // log error
end;

procedure TDSConnectionPool.OnRecover(ASender, AInitiator: TObject;
  AException: Exception; var AAction: TFDPhysConnectionRecoverAction);
begin
  IsReConn := True;

  // set global flag
  if ReConnectionCount = 0 then
  begin
    ReConnectionCount := ReConnectionCount + 1;
  end
  else
  begin
    ReConnectionCount := ReConnectionCount + 1;
  end;
  AAction := faFail; // if set to faRetry, this event will be triggered many times
end;

procedure TDSConnectionPool.OnRestored(ASender: TObject);
begin
  IsReConn := False;
  // set global flag
  if ReConnectionCount > 0 then
  begin
    ReConnectionCount := 0;
  end
  else
  begin
    ReConnectionCount := 0;
  end;
end;

procedure TDSConnectionPool.OnLost(ASender: TObject);
begin
  // notify to handle connection lost. only when faRetry
end;

procedure TDSConnectionPool.OnRecoverIgnore(ASender, AInitiator: TObject;
  AException: Exception; var AAction: TFDPhysConnectionRecoverAction);
begin
  // can do something different here when get connection in a thread

  IsReConn := True;
  // set global flag
  if ReConnectionCount = 0 then
  begin
    ReConnectionCount := ReConnectionCount + 1;
  end
  else
  begin
    ReConnectionCount := ReConnectionCount + 1;
  end;
  AAction := faFail;
end;