Implementar LoadBalance no exemplo do Andreano Lanuse.

unit Main;

interface

uses
    Windows, Messages, SysUtils, Classes, Graphics, Controls, SvcMgr,
Dialogs,
    IdTCPServer, IdHTTPServer, IdCustomHTTPServer, IdContext, StdCtrls,
    IdBaseComponent, IdComponent, IdCustomTCPServer, DSHTTP, WideStrings,
    DbxDatasnap, DB, SqlExpr, DSService, DSTCPServerTransport,
    DbxSocketChannelNative, DSCommonServer, DSServer, DSHTTPCommon,
    Generics.Collections, DBClient, Forms;

type

    TServer = class
    private
      FcDriverName: String;
      FnPort: Integer;
      FcHostName: String;
      FoSessionId: TStringList;
      procedure SetDriverName(const Value: String);
      procedure SetHostName(const Value: String);
      procedure SetSetPort(const Value: Integer);
      procedure SetSessionId(const Value: TStringList);
    public
      function ConnectionCount: Integer;
      property DriverName     : String      read FcDriverName      write SetDriverName;
      property HostName       : String      read FcHostName        write SetHostName;
      property Port           : Integer     read FnPort            write SetSetPort;
      property SessionId      : TStringList read FoSessionId       write SetSessionId;

      constructor Create(lcDriverName, lcHostName: String; lnPort: Integer);
    end;

    TSystem = class
    private
      FcName: String;
      FbActive: Boolean;
      FoServerList: TList;
      procedure SetActive(const Value: Boolean);
      procedure SetName(const Value: String);
      function GetServer(Index: Integer): TServer;
      procedure DoFreeServerList;
    protected
      procedure DoLoadServer; virtual;
    public
      function ServerCount: Integer;
      function GetActiveServer: TServer;
      property Name  : String  read FcName   write SetName;
      property Active: Boolean read FbActive write SetActive;
      property Server[Index: Integer]: TServer read GetServer;

      constructor Create(lcName: String; lbActive: boolean);
      destructor Destroy; override;
    end;

    TUserFlag = class
    private
      FbActive: Boolean;
      FoSystem: TSystem;
      FoServer: TServer;
      procedure SetActive(const Value: Boolean);
      procedure SetSystem(const Value: TSystem);
      procedure SetServer(const Value: TServer);
    protected
    public
      property System: TSystem read FoSystem write SetSystem;
      property Server: TServer read FoServer write SetServer;
      property Active: Boolean read FbActive write SetActive;

      constructor Create(loSystem: TSystem; loServer: TServer);
    end;

    TDSHTTPServiceHelper = class Helper for TDSHTTPService
    private
      { private declarations }
    protected
      { protected declarations }
    public
      { public declarations }
      class var FoSystem: TSystem;
      class var FoServer: TServer;
    published
      { published declarations }
    end;

    TfrmMain = class(TForm)
      DSHTTPService: TDSHTTPService;
      DSHTTPSAManager: TDSHTTPServiceAuthenticationManager;
      Memo1: TMemo;
      procedure DSHTTPSAManagerHTTPAuthenticate(Sender: TObject; const Protocol,
        Context, User, Password: string; var valid: Boolean);
      procedure FormCreate(Sender: TObject);
      procedure FormDestroy(Sender: TObject);
    private
      FoSystemList: TList;
      procedure DoLoadSystem;
      function SystemByName(lcValue: String): TSystem;
      function CommandTypeToString(loCmdType: TDSHTTPCommandType): String;
      procedure Redirect(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);
      procedure OpenBackupSession(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);
      procedure CloseBackupSession(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);
      procedure WriteBackupSession(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);
      procedure ReadBackupSession(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);
      procedure ErrorWriteBackupSession(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);
      procedure ErrorReadBackupSession(Sender: TObject; Session: TDSTunnelSession; Content: TBytes;
        var Count: Integer);

      procedure LogBytes(SessionContent: TBytesStream; Buf: TBytes; Count: integer; Op: byte);
      function ReadLogBytes(SessionContent: TBytesStream; var Buf: TBytes; out Count: integer): byte;
      procedure RestoreSessionState(Session: TDSTunnelSession);

      procedure Initialize;
      procedure Finalize;


      procedure Log(lcValue: String);
    public

    end;

var
    frmMain: TfrmMain;



implementation

{$R *.DFM}

uses DBXCommon;

function SortByConnectionCount(Item1, Item2: Pointer): Integer;
begin
    Result := CompareText(IntToStr(TServer(Item1).ConnectionCount),
      IntToStr(TServer(Item2).ConnectionCount));
end;

procedure TfrmMain.CloseBackupSession(Sender: TObject; Session:
TDSTunnelSession;
    Content: TBytes; var Count: Integer);
var
    loSessionContent: TBytesStream;
    lnIndex: Integer;
    loUserFlag: TUserFlag;
begin
    loSessionContent := TBytesStream(Session.UserPointer);

    if TUserFlag(Session.UserFlag) <> nil
    then begin
           loUserFlag:= TUserFlag(Session.UserFlag);
           lnIndex   := loUserFlag.Server.SessionId.IndexOf(Session.SessionId);
           if lnIndex >= 0
           then loUserFlag.Server.SessionId.Delete(lnIndex);
           FreeAndNil(loUserFlag);
         end;

    if loSessionContent <> nil
    then begin
           loSessionContent.Free;
           Session.UserPointer := nil;
         end;
end;

function TfrmMain.CommandTypeToString(loCmdType: TDSHTTPCommandType):
String;
begin
    case loCmdType of
      hcUnknown: Result:= 'UNKWON';
      hcOther: Result  := 'OTHER';
      hcGET: Result    := 'GET';
      hcPOST: Result   := 'POST';
      hcDELETE: Result := 'DELETE';
      hcPUT: Result    := 'PUT';
    end;
end;

procedure TfrmMain.DoLoadSystem;
var
    loCds: TClientDataSet;
    FoSystem: TSystem;
begin
    try
      loCds := TClientDataSet.Create(nil);
      loCds.LoadFromFile(ExtractFilePath(ParamStr(0)) + 'Out\System.txt');
      loCds.Open;
    except
      begin
        if loCds <> nil
        then FreeAndNil(loCds);

        raise Exception.Create('Erro ao tentar acessar System.txt!');
      end;
    end;

    try
      while not loCds.Eof do
      begin
        FoSystem := TSystem.Create(loCds.FieldByName('Name').AsString,
          loCds.FieldByName('Active').AsBoolean);

        FoSystemList.Add(FoSystem);
        loCds.Next;
      end;
     finally
       FreeAndNil(loCds);
    end;
end;

procedure TfrmMain.DSHTTPSAManagerHTTPAuthenticate(Sender: TObject;
const Protocol,
    Context, User, Password: string; var valid: Boolean);
var
    loSystem: TSystem;
    loServer: TServer;
begin
    loSystem := SystemByName(User);

    if loSystem = nil
    then begin
           valid := false;
           raise Exception.Create('Sistema invalido: ' + User);
         end;

    loServer := loSystem.GetActiveServer;

    if loServer = nil
    then begin
           valid := false;
           raise Exception.Create('Nenhum Servidor Ativo no momento!');
         end;

    DSHTTPService.DSHostname:= loServer.HostName;
    DSHTTPService.DSPort    := loServer.Port;

    TDSHTTPService(Sender).FoSystem:= loSystem;
    TDSHTTPService(Sender).FoServer:= loServer;

    valid := true;
end;

procedure TfrmMain.ErrorReadBackupSession(Sender: TObject; Session:
TDSTunnelSession;
    Content: TBytes; var Count: Integer);
begin
    if TUserFlag(Session.UserFlag).Active
    then begin
           Redirect(Sender, Session, Content, Count);
           Session.UserPointer := Pointer(TBytesStream.Create());
           Count := Session.Read(Content, 0, Count);
         end;
end;

procedure TfrmMain.ErrorWriteBackupSession(Sender: TObject;
    Session: TDSTunnelSession; Content: TBytes; var Count: Integer);
begin
    if TUserFlag(Session.UserFlag).Active
    then begin
           Redirect(Sender, Session, Content, Count);
           Session.UserPointer := Pointer(TBytesStream.Create());
           Count := Session.Write(Content, 0, Count);
         end;
end;

procedure TfrmMain.Finalize;
var
    lnCont: Integer;
begin
    for lnCont := FoSystemList.Count - 1 downto 0 do
    begin
      FoSystemList[lnCont] := nil;
    end;
    FreeAndNil(FoSystemList);
    DSHTTPService.Active := false;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
    Initialize;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
    Finalize;
end;

procedure TfrmMain.Initialize;
begin
    DSHTTPService.HttpServer.TunnelService.OnErrorOpenSession := Redirect;
    DSHTTPService.HttpServer.TunnelService.OnErrorWriteSession:= ErrorWriteBackupSession;
    DSHTTPService.HttpServer.TunnelService.OnErrorReadSession := ErrorReadBackupSession;
    DSHTTPService.HttpServer.TunnelService.OnOpenSession      := OpenBackupSession;
    DSHTTPService.HttpServer.TunnelService.OnWriteSession     := WriteBackupSession;
    DSHTTPService.HttpServer.TunnelService.OnReadSession      := ReadBackupSession;
    DSHTTPService.HttpServer.TunnelService.OnCloseSession     := CloseBackupSession;

    DSHTTPService.Active := true;

    FoSystemList := TList.Create;
    DoLoadSystem;
end;

procedure TfrmMain.Log(lcValue: String);
begin
    Memo1.Lines.Add(lcValue);
end;

procedure TfrmMain.LogBytes(SessionContent: TBytesStream; Buf: TBytes;
    Count: integer; Op: byte);
var
    loHeader: TBytes;
begin
    SetLength(loHeader, 5);
    loHeader[0] := Op;
    loHeader[1] := (Count shr 24) and 255;
    loHeader[2] := (Count shr 16) and 255;
    loHeader[3] := (Count shr 8) and 255;
    loHeader[4] := Count and 255;

    SessionContent.Write(loHeader[0], 5);
    SessionContent.Write(Buf[0], Count);
end;

procedure TfrmMain.OpenBackupSession(Sender: TObject; Session:
TDSTunnelSession;
    Content: TBytes; var Count: Integer);
var
    loUserFlag: TUserFlag;
begin
    TDSHttpService(Sender).FoServer.SessionId.Add(Session.SessionId);

    if Session.UserFlag = 0
    then begin
           loUserFlag := TUserFlag.Create(TDSHttpService(Sender).FoSystem,
             TDSHttpService(Sender).FoServer);
           Session.UserFlag := Integer(loUserFlag);
         end
    else begin
           TUserFlag(Session.UserFlag).System := TDSHttpService(Sender).FoSystem;
           TUserFlag(Session.UserFlag).Server := TDSHttpService(Sender).FoServer;
         end;

    if TUserFlag(Session.UserFlag).Active
    then Session.UserPointer := Pointer(TBytesStream.Create());
end;

procedure TfrmMain.ReadBackupSession(Sender: TObject; Session:
TDSTunnelSession;
    Content: TBytes; var Count: Integer);
var
    loSessionContent: TBytesStream;
begin
    if TUserFlag(Session.UserFlag).Active
    then begin
           loSessionContent := TBytesStream(Session.UserPointer);
           LogBytes(loSessionContent, Content, Count, 2);
         end;
end;

function TfrmMain.ReadLogBytes(SessionContent: TBytesStream; var Buf:
TBytes;
    out Count: integer): byte;
var
    loHeader: TBytes;
begin
    if SessionContent.Position < SessionContent.Size
    then begin
           SetLength(loHeader, 5);

           SessionContent.Read(loHeader[0], 5);
           Result := loHeader[0];

           Count := loHeader[1];
           Count := (Count shl 8) or loHeader[2];
           Count := (Count shl 8) or loHeader[3];
           Count := (Count shl 8) or loHeader[4];
           SetLength(Buf, Count);
           SessionContent.Read(Buf[0], Count);
         end
    else Result := 0;
end;

procedure TfrmMain.Redirect(Sender: TObject; Session: TDSTunnelSession;
    Content: TBytes; var Count: Integer);
var
    DBXProperties: TDBXDatasnapProperties;
    lcMsg: String;
    loServer: TServer;
    loSystem: TSystem;
begin
    if Sender is Exception
    then lcMsg := Exception(Sender).Message;

    loServer := TUserFlag(Session.UserFlag).System.GetActiveServer;

    if loServer <> nil
    then begin
           DBXProperties                                     := TDBXDatasnapProperties.Create(nil);
           DBXProperties.Values[TDBXPropertyNames.DriverName]:= loServer.DriverName;
           DBXProperties.Values[TDBXPropertyNames.HostName]  := loServer.HostName;
           DBXProperties.Values[TDBXPropertyNames.Port]      := IntToStr(loServer.Port);
           TDSHTTPService(Sender).FoServer := loServer;
         end
    else begin
           TUserFlag(Session.UserFlag).Active := false;
           raise Exception.Create('Nenhum Servidor ativo no momento!');
         end;

    try
      loSystem:= TUserFlag(Session.UserFlag).System;
      try
        Session.Reopen(DBXProperties);
        RestoreSessionState(Session);
        CloseBackupSession(Sender, Session, Content, Count);
        loServer.SessionId.Add(Session.SessionId);
        Session.UserFlag := Integer(TUserFlag.Create(loSystem, loServer));
      except
        raise Exception.Create('Erro ao tentar reabrir sessão');
      end;
    finally
      FreeAndNil(DBXProperties);
    end;
end;

procedure TfrmMain.RestoreSessionState(Session: TDSTunnelSession);
var
    loSessionContent: TBytesStream;
    loBuf: TBytes;
    lnCount: Integer;
    loOp: Byte;
begin
    loSessionContent         := TBytesStream(Session.UserPointer);
    loSessionContent.Position:= 0;
    repeat
      loOp:= ReadLogBytes(loSessionContent, loBuf, lnCount);
      case loOp of
        2: //read
        begin
          Session.Read(loBuf, 0, lnCount);
        end;
        1: // write
        begin
          Session.Write(loBuf, 0, lnCount);
        end;
      end;
    until loOp = 0;
end;

function TfrmMain.SystemByName(lcValue: String): TSystem;
var
    lnCount: Integer;
begin
    Result := nil;
    for lnCount := 0 to FoSystemList.Count - 1 do
      if UpperCase(lcValue) = UpperCase(FoSystemList[lnCount].Name)
      then begin
             Result := FoSystemList[lnCount];
             Break;
           end;
end;

procedure TfrmMain.WriteBackupSession(Sender: TObject; Session:
TDSTunnelSession;
    Content: TBytes; var Count: Integer);
var
    SessionContent: TBytesStream;
begin
    if TUserFlag(Session.UserFlag).Active
    then begin
           SessionContent := TBytesStream(Session.UserPointer);
           LogBytes(SessionContent, Content, Count, 1);
         end;
end;

{ TServer }

function TServer.ConnectionCount: Integer;
begin
    Result:= FoSessionId.Count;
end;

constructor TServer.Create(lcDriverName, lcHostName: String; lnPort:
Integer);
begin
    inherited Create;

    DriverName:= lcDriverName;
    HostName  := lcHostName;
    Port      := lnPort;
    SessionId := TStringList.Create;
end;

procedure TServer.SetDriverName(const Value: String);
begin
    if Value = ''
    then raise Exception.Create('A propriedade DriverName não pode ser nulo!');

    FcDriverName := Value;
end;

procedure TServer.SetHostName(const Value: String);
begin
    if Value = ''
    then raise Exception.Create('A propriedade HostName não pode ser nulo!');

    FcHostName := Value;
end;

procedure TServer.SetSessionId(const Value: TStringList);
begin
    FoSessionId := Value;
end;

procedure TServer.SetSetPort(const Value: Integer);
begin
    if Value = 0
    then raise Exception.Create('A propriedade Port não pode ser igual á 0!');

    FnPort := Value;
end;

{ TSystem }

constructor TSystem.Create(lcName: String; lbActive: boolean);
begin
    inherited Create;

    if lcName = ''
    then raise Exception.Create('A propriedade Name não pode ser nula!');

    Name        := lcName;
    Active      := lbActive;
    FoServerList:= TList.Create;

    DoLoadServer;
end;

destructor TSystem.Destroy;
begin
    DoFreeServerList;
    inherited;
end;

procedure TSystem.DoFreeServerList;
var
    lnCont: Integer;
begin
    for lnCont := ServerCount - 1 downto 0 do
    begin
      FoServerList[lnCont] := nil;
    end;
    FreeAndNil(FoServerList);
end;

procedure TSystem.DoLoadServer;
var
    loCds: TClientDataSet;
    FoServer: TServer;
begin
    try
      loCds := TClientDataSet.Create(nil);
      loCds.Close;
      loCds.LoadFromFile(ExtractFilePath(ParamStr(0)) + 'Out\Server.txt');
      loCds.Open;
    except
      begin
        if loCds <> nil
        then FreeAndNil(loCds);

        raise Exception.Create('Erro ao tentar acessar Server.txt!');
      end;
    end;

    try
      while not loCds.Eof do
      begin
        if UpperCase(Name) = UpperCase(loCds.FieldByName('SystemName').AsString)
        then begin
               FoServer := TServer.Create(loCds.FieldByName('DriverName').AsString,
                 loCds.FieldByName('HostName').AsString, loCds.FieldByName('Port').AsInteger);

               FoServerList.Add(FoServer);
             end;
        loCds.Next;
      end;
     finally
       FreeAndNil(loCds);
    end;
end;

function TSystem.GetActiveServer: TServer;
    function ActiveConnection(lcDriverName, lcHostName, lcPort: String):
boolean;
    var
       loSQLConn: TSQLConnection;
    begin
      loSQLConn := TSQLConnection.Create(nil);
      try
        loSQLConn.Connected                := false;
        loSQLConn.DriverName               := lcDriverName;
        loSQLConn.Params.Values['HostName']:= lcHostName;
        loSQLConn.Params.Values['Port']    := lcPort;
        try
          loSQLConn.Connected:= true;
          if loSQLConn.Connected
          then Result:= true
          else Result:= false;
        except
          Result:= false;
        end;
      finally
        if loSQLConn <> nil
        then FreeAndNil(loSQLConn)
      end;
    end;
var
    lnCount: Integer;
begin
    TList(FoServerList).Sort(@SortByConnectionCount);

    Result := nil;
    for lnCount := 0 to ServerCount - 1 do
    begin
      if ActiveConnection(Trim(Server[lnCount].DriverName),
          Trim(Server[lnCount].HostName), Trim(IntToStr(Server[lnCount].Port)))
      then begin
             Result := Server[lnCount];
             Break;
           end;
    end;
end;

function TSystem.GetServer(Index: Integer): TServer;
begin
    if Index < 0
    then raise Exception.Create('Índice ' + IntToStr(Index) + ' fora da lista');

    if Index > (FoServerList.Count - 1)
    then raise Exception.Create('Índice ' + IntToStr(Index) + ' fora da lista');

    Result := FoServerList.Items[Index] as TServer;
end;

function TSystem.ServerCount: Integer;
begin
    Result := FoServerList.Count;
end;

procedure TSystem.SetActive(const Value: Boolean);
begin
    FbActive := Value;
end;

procedure TSystem.SetName(const Value: String);
begin
    FcName := Value;
end;

{ TUserFlag }

constructor TUserFlag.Create(loSystem: TSystem; loServer: TServer);
begin
    System:= loSystem;
    Server:= loServer;
    Active:= true;
end;

procedure TUserFlag.SetActive(const Value: Boolean);
begin
    FbActive := Value;
end;

procedure TUserFlag.SetServer(const Value: TServer);
begin
    if Value = nil
    then raise Exception.Create('A propriedade Server não pode ser nula!');

    FoServer := Value;
end;

procedure TUserFlag.SetSystem(const Value: TSystem);
begin
    if Value = nil
    then raise Exception.Create('A propriedade System não pode ser nula!');

    FoSystem := Value;
end;

end.