(******************************************************)
(*                                                    *)
(*            EldoS SecureBlackbox Library            *)
(*                                                    *)
(*      Copyright (c) 2002-2007 EldoS Corporation     *)
(*           http://www.secureblackbox.com            *)
(*                                                    *)
(******************************************************)

unit SBIndyServerIOHandler10;

interface

// Please uncomment the following conditional define if you are using
// Indy 10.1.1 or higher
{$define INDY1011}

uses
  SBIndyIOHandler10, Classes, IdSSL, SBUtils, SBClient, IdAntiFreezeBase,
  IdStack, IdGlobalProtocols, IdStackConsts, IdGlobal, SBConstants, SBX509,
  SBCustomCertStorage, SBServer, SBSessionPool, IdThread, IdScheduler,
  IdIOHandler, IdSocketHandle, IdYarn, SBSSLConstants, SBSSLCommon;

type

  TElClientServerIndySSLIOHandlerSocket = class;

  TSBIndyIOHandlerCertificateValidateEvent = procedure(Sender: TObject;
    X509Certificate: TElX509Certificate; IOHandler: TElClientServerIndySSLIOHandlerSocket;
    var Validate: boolean) of object;

  TElClientServerIndySSLIOHandlerSocket = class(TElClientIndySSLIOHandlerSocket)
  private
    function GetClientAuthentication : boolean;
    function GetServerCertStorage : TElMemoryCertStorage;
    function GetSessionPool : TElSessionPool;
    procedure HandleCertificateValidate(Sender: TObject; X509Certificate:
        TElX509Certificate; var Validate: boolean);
    //procedure HandleCiphersNegotiated(Sender : TObject);
    //procedure HandleError(Sender : TObject; ErrorCode: integer; Fatal: boolean;
    //    Remote : boolean);
    procedure SetClientAuthentication(Value : boolean);
    procedure SetServerCertStorage(Value : TElMemoryCertStorage);
    procedure SetSessionPool(Value : TElSessionPool);
    //procedure HandleCiphersNegotiated(Sender: TObject);
    //procedure HandleError(Sender: TObject; ErrorCode: integer; Fatal,
    //  Remote: boolean);
  protected
    FSecureServer : TElSecureServer;
    procedure DoSSLEstablished; override;
    function GetCipherSuite : TSBCipherSuite; override;
    function GetVersion : TSBVersion; override;
    function GetAuthenticationLevel : TSBAuthenticationLevel;
    function GetCompressionAlgorithm: TSBSSLCompressionAlgorithm; override;
    function GetForceCertificateChain : boolean;
    procedure InitComponent; override;
    procedure OnSecureServerCloseConnection(Sender : TObject; CloseReason :
      integer);
    function ReadFromSource(ARaiseExceptionIfDisconnected: Boolean = True;
      ATimeout: Integer = IdTimeoutDefault;
      ARaiseExceptionOnTimeout: Boolean = True): Integer; override;
    procedure SetCertStorage(Value : TElCustomCertStorage); override;
    procedure SetCipherSuites(Index : TSBCipherSuite; Value : boolean); override;
    procedure SetOnCertificateValidate(Value : TSBCertificateValidateEvent); override;
    procedure SetOnCiphersNegotiated(Value: TNotifyEvent); override;
    procedure SetOnError(Value: TSBErrorEvent); override;

    procedure SetVersions(Value : TSBVersions); override;
    procedure SetAuthenticationLevel(Value : TSBAuthenticationLevel);
    procedure SetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm; Value:
        boolean); override;
    procedure SetForceCertificateChain(Value : boolean);
  protected
    FOnCertificateValidate: TSBIndyIOHandlerCertificateValidateEvent;
  public
    function Clone :  TIdSSLIOHandlerSocketBase; override;
    procedure Close; override;
    function Connected: Boolean; override;
    destructor Destroy; override;
    procedure InternalValidate(var Validity: TSBCertificateValidity; var Reason:
        TSBCertificateValidityReason);
    procedure RenegotiateCiphers; reintroduce;
    procedure StartSSL; override;
    { if you got an error here, please see the comment on the top of the unit }
    {$ifndef INDY1011}
    procedure WriteDirect(ABuffer: TIdBytes); override;
    {$else}
    procedure WriteDirect(var ABuffer: TIdBytes); override;
    {$endif}
  published
    property OnCertificateValidate: TSBIndyIOHandlerCertificateValidateEvent read
        FOnCertificateValidate write FOnCertificateValidate;
    property ClientAuthentication : boolean read GetClientAuthentication
      write SetClientAuthentication;
    property AuthenticationLevel : TSBAuthenticationLevel read GetAuthenticationLevel
      write SetAuthenticationLevel;
    property ForceCertificateChain : boolean read GetForceCertificateChain
      write SetForceCertificateChain;
    property ServerCertStorage : TElMemoryCertStorage read GetServerCertStorage
      write SetServerCertStorage;
    property SessionPool : TElSessionPool read GetSessionPool write SetSessionPool;
  end;

  TElIndySSLServerIOHandler = class(TIdServerIOHandlerSSLBase)
  private
    FCertStorage : TElCustomCertStorage;
    FCipherSuites : array[SB_SUITE_FIRST..SB_SUITE_LAST] of boolean;
    FCompressionAlgorithms : array[TSBSSLCompressionAlgorithm] of boolean;
    FClientAuthentication : boolean;
    FAuthenticationLevel : TSBAuthenticationLevel;
    FForceCertificateChain : boolean;
    FOnCertificateNeeded: TSBCertificateNeededEvent;
    FOnCertificateNeededEx: TSBCertificateNeededExEvent;
    FOnCertificateValidate: TSBIndyIOHandlerCertificateValidateEvent;
    FOnSSLEstablished: TSBSSLEstablishedEvent;
    FPassthrough : boolean;
    FServerCertStorage : TElMemoryCertStorage;
    FSessionPool : TElSessionPool;
    FVersions : TSBVersions;
    procedure HandleCertificateValidate(Sender: TObject; X509Certificate:
        TElX509Certificate; IOHandler: TElClientServerIndySSLIOHandlerSocket; var
        Validate: boolean);
    procedure HandleCiphersNegotiated(Sender : TObject);
    procedure HandleError(Sender : TObject; ErrorCode: integer; Fatal: boolean;
        Remote : boolean);
    procedure HandleSSLEstablished(Sender : TObject; Version : TSBVersion;
        CipherSuite : TSBCipherSuite);
  protected
    FOnCiphersNegotiated: TNotifyEvent;
    FOnError: TSBErrorEvent;
    procedure CopySSLParams(IOHandler : TElClientServerIndySSLIOHandlerSocket);
    function GetCipherSuites(Index : TSBCipherSuite) : boolean;
    function GetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm): boolean;
    procedure Notification(AComponent : TComponent; AOperation : TOperation); override;
    procedure SetCertStorage(Value : TElCustomCertStorage);
    procedure SetCipherSuites(Index : TSBCipherSuite; Value : boolean);
    procedure SetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm; Value:
        boolean);
    procedure SetServerCertStorage(Value : TElMemoryCertStorage);
    procedure SetSessionPool(Value : TElSessionPool);
  public
    function Accept(ASocket: TIdSocketHandle; AListenerThread: TIdThread;
      AYarn: TIdYarn): TIdIOHandler; override;
    procedure Init; override;
    procedure InitComponent; override;
    function MakeClientIOHandler : TIdSSLIOHandlerSocketBase; override;
    function MakeClientIOHandler(ATheThread:TIdYarn ): TIdIOHandler; overload; override;
    function MakeFTPSvrPasv : TIdSSLIOHandlerSocketBase; override;
    function MakeFTPSvrPort : TIdSSLIOHandlerSocketBase; override;
    procedure SetScheduler(AScheduler:TIdScheduler); override;
    property CipherSuites[Index : TSBCipherSuite] : boolean read GetCipherSuites
      write SetCipherSuites;
    property CompressionAlgorithms[Index: TSBSSLCompressionAlgorithm]: boolean read
        GetCompressionAlgorithms write SetCompressionAlgorithms;
  published
    property CertStorage : TElCustomCertStorage read FCertStorage
      write SetCertStorage;
    property ClientAuthentication : boolean read FClientAuthentication
      write FClientAuthentication;
    property AuthenticationLevel : TSBAuthenticationLevel read FAuthenticationLevel
      write FAuthenticationLevel default alRequireCert;
    property ForceCertificateChain : boolean read FForceCertificateChain
      write FForceCertificateChain default false;
    property OnCertificateNeeded: TSBCertificateNeededEvent read
        FOnCertificateNeeded write FOnCertificateNeeded;
    property OnCertificateNeededEx: TSBCertificateNeededExEvent read
        FOnCertificateNeededEx write FOnCertificateNeededEx;
    property OnCertificateValidate: TSBIndyIOHandlerCertificateValidateEvent read
        FOnCertificateValidate write FOnCertificateValidate;
    property OnCiphersNegotiated: TNotifyEvent read FOnCiphersNegotiated write
        FOnCiphersNegotiated;
    property OnError: TSBErrorEvent read FOnError write FOnError;
    property OnSSLEstablished: TSBSSLEstablishedEvent read FOnSSLEstablished write
        FOnSSLEstablished;
    property Passthrough : boolean read FPassthrough write FPassthrough
      default true;
    property ServerCertStorage : TElMemoryCertStorage read FServerCertStorage
      write SetServerCertStorage;
    property SessionPool : TElSessionPool read FSessionPool write SetSessionPool;
    property Versions : TSBVersions read FVersions write FVersions;
  end;

procedure Register;

implementation

uses
  Sysutils, IdException, IdExceptionCore, IdResourceStrings, IdResourceStringsCore,
  IdResourceStringsProtocols;

procedure Register;
begin
  RegisterComponents('SSLBlackbox', [TElClientServerIndySSLIOHandlerSocket,
    TElIndySSLServerIOHandler]);
end;                         

function TElClientServerIndySSLIOHandlerSocket.GetClientAuthentication : boolean;
begin
  Result := FSecureServer.ClientAuthentication;
end;

function TElClientServerIndySSLIOHandlerSocket.GetServerCertStorage : TElMemoryCertStorage;
begin
  Result := FSecureServer.CertStorage;
end;

function TElClientServerIndySSLIOHandlerSocket.GetSessionPool : TElSessionPool;
begin
  Result := FSecureServer.SessionPool;
end;

function TElClientServerIndySSLIOHandlerSocket.GetAuthenticationLevel : TSBAuthenticationLevel;
begin
  Result := FSecureServer.AuthenticationLevel;
end;

function TElClientServerIndySSLIOHandlerSocket.GetForceCertificateChain : boolean;
begin
  Result := FSecureServer.ForceCertificateChain;
end;

procedure TElClientServerIndySSLIOHandlerSocket.HandleCertificateValidate(
    Sender: TObject; X509Certificate: TElX509Certificate; var Validate:
    boolean);
begin
  if Assigned(FOnCertificateValidate) then
    FOnCertificateValidate(Self, X509Certificate, Self, Validate);
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetClientAuthentication(Value : boolean);
begin
  FSecureServer.ClientAuthentication := Value;
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetServerCertStorage(Value : TElMemoryCertStorage);
begin
  FSecureServer.CertStorage := Value;
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetSessionPool(Value : TElSessionPool);
begin
  FSecureServer.SessionPool := Value;
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetAuthenticationLevel(Value : TSBAuthenticationLevel);
begin
  FSecureServer.AuthenticationLevel := Value;
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetForceCertificateChain(Value : boolean);
begin
  FSecureServer.ForceCertificateChain := Value;
end;

procedure TElClientServerIndySSLIOHandlerSocket.DoSSLEstablished;
begin
  if Assigned(FOnSSLEstablished) then
    FOnSSLEstablished(Self, FSecureServer.CurrentVersion, FSecureServer.CipherSuite);
end;

function TElClientServerIndySSLIOHandlerSocket.GetCipherSuite : TSBCipherSuite;
begin
  if FIsPeer then
    Result := FSecureServer.CipherSuite
  else
    Result := FSecureClient.CipherSuite;
end;

function TElClientServerIndySSLIOHandlerSocket.GetVersion : TSBVersion;
begin
  if FIsPeer then
    Result := FSecureServer.CurrentVersion
  else
    Result := FSecureClient.CurrentVersion;
end;

////////////////////////////////////////////////////////////////////////////////
// TElClientServerIndySSLIOHandlerSocket class

procedure TElClientServerIndySSLIOHandlerSocket.InitComponent;
var
  I : integer;
begin
  inherited;
  FSecureServer := TElSecureServer.Create(nil);
  for I := SB_SUITE_FIRST to SB_SUITE_LAST do
    FSecureServer.CipherSuites[I] := FSecureClient.CipherSuites[I];
  FSecureServer.Versions := FSecureClient.Versions;
  FSecureServer.OnCloseConnection := OnSecureServerCloseConnection;
  FSecureServer.OnCertificateValidate := HandleCertificateValidate;
  //FSecureServer.OnError := HandleError;
  //FSecureServer.OnCiphersNegotiated := HandleCiphersNegotiated; 
end;

procedure TElClientServerIndySSLIOHandlerSocket.OnSecureServerCloseConnection(Sender :
  TObject; CloseReason : integer);
begin
  FErrorOccured := true;
end;

function TElClientServerIndySSLIOHandlerSocket.ReadFromSource(ARaiseExceptionIfDisconnected:
  Boolean = True; ATimeout: Integer = IdTimeoutDefault;
  ARaiseExceptionOnTimeout: Boolean = True): Integer;
var
  Buf: TIdBytes;
  Written : integer;
begin
  Result := 0;
  SetLength(Buf, 16384);
  if (FSecured) and (not FPassThrough) then
  begin
    if FErrorOccured then
    begin
      Result := 1;
      FClosedGracefully := true;
      if ARaiseExceptionIfDisconnected then
      begin
        ForceClose := true;
        raise EIdConnClosedGracefully.Create('Disconnected');
      end;
    end
    else
    begin
      if Assigned(FBinding) and (FBinding.Readable(ATimeout)) then
      begin
        if FIsPeer then
          FSecureServer.DataAvailable
        else
          FSecureClient.DataAvailable;
      end;
    end;
  end
  else 
  begin
    if ATimeOut = 0 then
    begin
      Result := inherited ReadFromSource(ARaiseExceptionIfDisconnected, ATimeOut,
        ARaiseExceptionOnTimeOut);
      Exit;
    end;
    if Assigned(FBinding) and (FBinding.Readable(ATimeout)) then
    begin
      Written := FBinding.Receive(Buf);
      if Written <= 0 then
      begin
        FErrorOccured := true;
        Result := 1;
        FClosedGracefully := true;
        if ARaiseExceptionIfDisconnected then
          raise EIdConnClosedGracefully.Create('Error while reading from socket');
      end
      else
      begin
        SetLength(Buf, Written);
        if Assigned(Intercept) then
        begin
          Intercept.Receive(Buf);
        end;
        FInputBuffer.Write(Buf);
      end;
    end
    else
      Result := 1;
  end;
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetCertStorage(Value : TElCustomCertStorage);
begin
  inherited SetCertStorage(Value);
  FSecureServer.ClientCertStorage := Value;
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetCipherSuites(Index : TSBCipherSuite;
  Value : boolean);
begin
  inherited SetCipherSuites(Index, Value);
  FSecureServer.CipherSuites[Index] := Value;  
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetOnCertificateValidate(Value :
  TSBCertificateValidateEvent);
begin
  inherited SetOnCertificateValidate(Value);
  FSecureServer.OnCertificateValidate := Value;  
end;

procedure TElClientServerIndySSLIOHandlerSocket.SetVersions(Value : TSBVersions);
begin
  inherited SetVersions(Value);
  FSecureServer.Versions := Value;
end;

function TElClientServerIndySSLIOHandlerSocket.Clone :  TIdSSLIOHandlerSocketBase;
var
  IOHandler : TElClientServerIndySSLIOHandlerSocket;
  I : integer;
begin
  IOHandler := TElClientServerIndySSLIOHandlerSocket.Create(nil);
  IOHandler.Versions := Versions;
  for I := SB_SUITE_FIRST to SB_SUITE_LAST do
    IOHandler.CipherSuites[I] := CipherSuites[I];
  IOHandler.CertStorage := CertStorage;
  IOHandler.ServerCertStorage := ServerCertStorage;
  IOHandler.SessionPool := SessionPool;
  IOHandler.ClientAuthentication := ClientAuthentication;
  IOHandler.OnCertificateValidate := OnCertificateValidate;
  IOHandler.OnCertificateNeeded := OnCertificateNeeded;
  IOHandler.OnCertificateNeededEx := OnCertificateNeededEx;
  IOHandler.OnError := OnError;
  IOHandler.OnCiphersNegotiated := OnCiphersNegotiated;
  IOHandler.PassThrough := FPassThrough;
  IOHandler.AuthenticationLevel := AuthenticationLevel;
  IOHandler.ForceCertificateChain := ForceCertificateChain;
  Result := IOHandler;
end;

procedure TElClientServerIndySSLIOHandlerSocket.Close;
begin