{
  Clever Internet Suite
  Copyright (C) 2013 Clever Components
  All Rights Reserved
  www.CleverComponents.com
}

unit clTcpClientTls;

interface

{$I clVer.inc}

uses
{$IFNDEF DELPHIXE2}
  Classes, SysUtils,
{$ELSE}
  System.Classes, System.SysUtils,
{$ENDIF}
  clTcpClient, clTlsSocket, clSocket, clCertificate, clCertificateStore, clSspi, clSspiTls, clSocketUtils;

type
  TclClientTlsMode = (ctNone, ctAutomatic, ctImplicit, ctExplicit);

  TclTcpClientTls = class(TclTcpClient)
  private
    FUseTLS: TclClientTlsMode;
    FCertificateFlags: TclCertificateVerifyFlags;
    FTLSFlags: TclTlsFlags;

    FOnGetCertificate: TclGetCertificateEvent;
    FOnVerifyServer: TclVerifyPeerEvent;
    FSecurityPackage: string;
    FUseStrongCryptoAlgorithms: Boolean;
    FSendRootCertificate: Boolean;
    
    procedure SetCertificateFlags(const Value: TclCertificateVerifyFlags);
    procedure SetTLSFlags(const Value: TclTlsFlags);
    procedure SetSendRootCertificate(const Value: Boolean);
    procedure SetUseStrongCryptoAlgorithms(const Value: Boolean);
    function GetIsTls: Boolean;
    procedure SetSecurityPackage(const Value: string);
  protected
    function GetNetworkStream: TclNetworkStream; override;

    procedure GetCertificate(Sender: TObject; var ACertificate: TclCertificate;
      AExtraCerts: TclCertificateList; var Handled: Boolean);
    procedure VerifyServer(Sender: TObject; ACertificate: TclCertificate;
      const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
    function GetTlsStream: TclTlsNetworkStream;

    procedure SetUseTLS(const Value: TclClientTlsMode); virtual;

    procedure DoGetCertificate(var ACertificate: TclCertificate;
      AExtraCerts: TclCertificateList; var Handled: Boolean); dynamic;
    procedure DoVerifyServer(ACertificate: TclCertificate;
      const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    procedure StartTls; virtual;
    function ExplicitStartTls: Boolean;

    property IsTls: Boolean read GetIsTls;
  published    
    property UseTLS: TclClientTlsMode read FUseTLS write SetUseTLS default ctNone;
    property CertificateFlags: TclCertificateVerifyFlags read FCertificateFlags
      write SetCertificateFlags default [];
    property TLSFlags: TclTlsFlags read FTLSFlags write SetTLSFlags default [tfUseTLS, tfUseTLS11, tfUseTLS12];
    property SendRootCertificate: Boolean read FSendRootCertificate write SetSendRootCertificate default False;
    property UseStrongCryptoAlgorithms: Boolean read FUseStrongCryptoAlgorithms write SetUseStrongCryptoAlgorithms default False;
    property SecurityPackage: string read FSecurityPackage write SetSecurityPackage;

    property OnGetCertificate: TclGetCertificateEvent read FOnGetCertificate write FOnGetCertificate;
    property OnVerifyServer: TclVerifyPeerEvent read FOnVerifyServer write FOnVerifyServer;
  end;

implementation

{$IFDEF LOGGER}
uses
  clLogger;
{$ENDIF}

{ TclTcpClientTls }

constructor TclTcpClientTls.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);

  FUseTLS := ctNone;
  FTLSFlags :=  [tfUseTLS, tfUseTLS11, tfUseTLS12];
  FSendRootCertificate := False;
  FUseStrongCryptoAlgorithms := False;
end;

procedure TclTcpClientTls.SetUseStrongCryptoAlgorithms(const Value: Boolean);
begin
  if (FUseStrongCryptoAlgorithms <> Value) then
  begin
    FUseStrongCryptoAlgorithms := Value;
    Changed();
  end;
end;

procedure TclTcpClientTls.SetUseTLS(const Value: TclClientTlsMode);
begin
  if (FUseTLS <> Value) then
  begin
    FUseTLS := Value;
    Changed();
  end;
end;

function TclTcpClientTls.GetTlsStream: TclTlsNetworkStream;
begin
  Result := TclTlsNetworkStream.Create();
  Result.CertificateFlags := CertificateFlags;
  Result.TLSFlags := TLSFlags;
  Result.SendRootCertificate := SendRootCertificate;
  Result.UseStrongCryptoAlgorithms := UseStrongCryptoAlgorithms;
  Result.TargetName := Server;
  Result.SecurityPackage := SecurityPackage;
  Result.OnGetCertificate := GetCertificate;
  Result.OnVerifyPeer := VerifyServer;
end;

procedure TclTcpClientTls.DoGetCertificate(var ACertificate: TclCertificate;
  AExtraCerts: TclCertificateList; var Handled: Boolean);
begin
  if Assigned(OnGetCertificate) then
  begin
    OnGetCertificate(Self, ACertificate, AExtraCerts, Handled);
  end;
end;

procedure TclTcpClientTls.GetCertificate(Sender: TObject;
  var ACertificate: TclCertificate; AExtraCerts: TclCertificateList; var Handled: Boolean);
begin
  DoGetCertificate(ACertificate, AExtraCerts, Handled);
end;

function TclTcpClientTls.GetIsTls: Boolean;
begin
  Result := (Connection.NetworkStream is TclTlsNetworkStream);
end;

function TclTcpClientTls.GetNetworkStream: TclNetworkStream;
begin
  if ((UseTLS = ctAutomatic) and (Port <> GetDefaultPort())) or (UseTLS = ctImplicit) then
  begin
    Result := GetTlsStream();
  end else
  begin
    Result := inherited GetNetworkStream();
  end;
end;

function TclTcpClientTls.ExplicitStartTls: Boolean;
begin
  Result := ((UseTLS = ctAutomatic) and (Port = GetDefaultPort()))
    or (UseTLS = ctExplicit);

  if Result then
  begin
    StartTls();
  end;
end;

procedure TclTcpClientTls.StartTls;
begin
  if (UseTLS = ctNone) then
  begin
    UseTLS := ctExplicit;
  end;
  try
    Connection.NetworkStream := GetTlsStream();
    Connection.OpenSession();
  except
    InProgress := True;
    try
      Close();
    except
      on EclSocketError do ;
    end;
    InProgress := False;

    raise;
  end;
end;

procedure TclTcpClientTls.DoVerifyServer(ACertificate: TclCertificate;
  const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
begin
  if Assigned(OnVerifyServer) then
  begin
    OnVerifyServer(Self, ACertificate, AStatusText, AStatusCode, AVerified);
  end;
end;

procedure TclTcpClientTls.VerifyServer(Sender: TObject; ACertificate: TclCertificate;
  const AStatusText: string; AStatusCode: Integer; var AVerified: Boolean);
begin
  DoVerifyServer(ACertificate, AStatusText, AStatusCode, AVerified);
end;

procedure TclTcpClientTls.SetCertificateFlags(const Value: TclCertificateVerifyFlags);
begin
  if (FCertificateFlags <> Value) then
  begin
    FCertificateFlags := Value;
    Changed();
  end;
end;

procedure TclTcpClientTls.SetSecurityPackage(const Value: string);
begin
  if (FSecurityPackage <> Value) then
  begin
    FSecurityPackage := Value;
    Changed();
  end;
end;

procedure TclTcpClientTls.SetSendRootCertificate(const Value: Boolean);
begin
  if (FSendRootCertificate <> Value) then
  begin
    FSendRootCertificate := Value;
    Changed();
  end;
end;

procedure TclTcpClientTls.SetTLSFlags(const Value: TclTlsFlags);
begin
  if (FTLSFlags <> Value) then
  begin
    FTLSFlags := Value;
    Changed();
  end;
end;

end.
