sbftpcli.pas

著名的SecureBlackBox控件完整源码

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

unit SBFtpCli;

interface

uses
  Classes,
  FtpCli,
  SBSSLCommon,
  SBSSLConstants,
  SBClient,
  SBWSocket,
  SBConstants,
  WSocket,
  SBX509,
  SBUtils,
  SBCustomCertStorage
  ;

type
  TSBFtpAuthType = (atAuthSSL, atAuthTLS, atAuthImplicit);
  TElSecureFtpClient = class(TFtpClient)
  private
    FOnCertificateValidate: TSBCertificateValidateEvent;
    FOnCertificateNeeded: TSBCertificateNeededEvent;
    FOnCertificateChoose: TSBChooseCertificateEvent;
    FOnCertificateNeededEx: TSBCertificateNeededExEvent;
    FOldOnSessionConnected: TSessionConnected;
    FOldDataSocketOnSessionConnected: TSessionConnected;
    FOldDataSocketOnSessionAvailable: TSessionAvailable;
    FOnSSLEstablished: TSBSSLEstablishedEvent;
    FCertStorage: TElCustomCertStorage;
    FState: integer;
    FOutBuffer: string;
    FSSLEnabled: boolean;
    FEncryptDataChannel: boolean;
    FVersions: TSBVersions;
    FCipherSuites: array[SB_SUITE_FIRST..SB_SUITE_LAST] of boolean;
    FCompressionAlgorithms: array[TSBSSLCompressionAlgorithm] of boolean;
    FServerSupportsSSL: boolean;
    FAuthSSLSent: boolean;
    FAuth: TSBFtpAuthType;
    FProtectedBufferSize: cardinal;
    FAuxSocket: TWSocket;
    function GetCipherSuites(Index: TSBCipherSuite): boolean;
    procedure SetCipherSuites(Index: TSBCipherSuite; Value: boolean);
  protected
    FOnCiphersNegotiated: TNotifyEvent;
    FOnError: TSBErrorEvent;
    procedure Notification(AComponent: TComponent; AOperation: TOperation); override;
    procedure HandleSessionConnected(Sender: TObject; Error: word);
    procedure HandleDataAvailable(Sender: TObject; Error: word);
    procedure HandleControlSocketSessionConnected(Sender: TObject; Error: word);
    procedure HandleDataSocketSessionAvailable(Sender: TObject; Error: word);
    procedure HandleDataSocketSessionConnected(Sender: TObject; Error: word);
    procedure HandleDataSocketCertificate(Sender: TObject; Certificate:
      TElX509Certificate; var Validate: boolean);
    function ReadCode(const Buf; Len: integer): integer;
    procedure SendCommand(Cmd: string); override;
    procedure SetCertStorage(Storage: TElCustomCertStorage);
    function GetCertStorage: TElCustomCertStorage;
    function GetCipherSuite: TSBCipherSuite;
    function GetVersion: TSBVersion;
    procedure CopySocketInfo(Src, Dest: TWSocket);
    function GetCompressionAlgorithm: TSBSSLCompressionAlgorithm;
    function GetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm): boolean;
    procedure SetCompressionAlgorithms(Index: TSBSSLCompressionAlgorithm; Value:
      boolean);
    procedure SetOnSSLEstablished(Value: TSBSSLEstablishedEvent);
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure OpenAsync; override;
    procedure QuitAsync; override;
    procedure PutAsync; override;
    procedure RestPutAsync; override;
    property CipherSuite: TSBCipherSuite read GetCipherSuite;
    property Version: TSBVersion read GetVersion;
    property CipherSuites[Index: TSBCipherSuite]: boolean read
    GetCipherSuites write SetCipherSuites;
    property CompressionAlgorithm: TSBSSLCompressionAlgorithm read
    GetCompressionAlgorithm;
    property CompressionAlgorithms[Index: TSBSSLCompressionAlgorithm]: boolean read
    GetCompressionAlgorithms write SetCompressionAlgorithms;
    procedure HandleControlSocketError(Sender: TObject; ErrorCode: Integer; Fatal,
      Remote: Boolean);
    procedure InternalValidate(var Validity: TSBCertificateValidity;
      var Reason: TSBCertificateValidityReason);
    procedure RenegotiateCiphers;
  published
    property SSLEnabled: boolean read FSSLEnabled write FSSLEnabled;
    property SSLVersions: TSBVersions read FVersions write FVersions;
    property Auth: TSBFtpAuthType read FAuth write FAuth;
    property EncryptDataChannel: boolean read FEncryptDataChannel write FEncryptDataChannel;
    property CertStorage: TElCustomCertStorage read GetCertStorage
    write SetCertStorage;
    property ProtectedBufferSize: cardinal read FProtectedBufferSize
    write FProtectedBufferSize default 0;
    property OnCertificateValidate: TSBCertificateValidateEvent read
    FOnCertificateValidate write FOnCertificateValidate;
    property OnCertificateNeeded: TSBCertificateNeededEvent read
    FOnCertificateNeeded write FOnCertificateNeeded;
    property OnCertificateChoose: TSBChooseCertificateEvent read
    FOnCertificateChoose write FOnCertificateChoose;
    property OnCertificateNeededEx: TSBCertificateNeededExEvent read
    FOnCertificateNeededEx write FOnCertificateNeededEx;
    property OnCiphersNegotiated: TNotifyEvent read FOnCiphersNegotiated write
    FOnCiphersNegotiated;
    property OnSSLError: TSBErrorEvent read FOnError write FOnError;
    property OnSSLEstablished: TSBSSLEstablishedEvent read FOnSSLEstablished
    write SetOnSSLEstablished;
  end;

procedure Register;

implementation

uses
  SysUtils;

const
  FTP_STATE_BEFORE = 0;
  FTP_STATE_HELLO_RECEIVED = 1;
  FTP_STATE_AUTH_SENT = 2;
  FTP_STATE_AUTH_RECEIVED = 3;
  FTP_STATE_SSL_ENABLED = 4;
  FTP_STATE_PROTP_SENT = 5;
  FTP_STATE_PUT = 6;
  FTP_STATE_PBSZ_SENT = 7;

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

constructor TElSecureFtpClient.Create(AOwner: TComponent);
var
  I: integer;
begin
  inherited;
  FSSLEnabled := true;
  for I := SB_SUITE_FIRST to SB_SUITE_LAST do
    FCipherSuites[I] := true;
  FCompressionAlgorithms[SSL_CA_NONE] := true;
  FCompressionAlgorithms[SSL_CA_ZLIB] := false;
  FVersions := [sbSSL2, sbSSL3, sbTLS1, sbTLS11];
  FAuthSSLSent := false;
  FProtectedBufferSize := 0;
  FAuxSocket := TWSocket.Create(nil);
end;

destructor TElSecureFtpClient.Destroy;
begin
  inherited;
  FreeAndNil(FAuxSocket);
end;

procedure TElSecureFtpClient.OpenAsync;
var
  I: integer;
  Destr: boolean;
begin
  Destr := false;
  if FSSLEnabled then
  begin
    if Assigned(FControlSocket) then
    begin
      CopySocketInfo(FControlSocket, FAuxSocket);
      FreeAndNil(FControlSocket);
      Destr := true;
    end;
    FControlSocket := TElSecureWSocket.Create(nil);
    if Destr then
      CopySocketInfo(FAuxSocket, FControlSocket);

    if TMethod(FControlSocket.OnSessionConnected).Code <> @TElSecureFtpClient.HandleControlSocketSessionConnected then
      FControlSocket.OnSessionConnected := HandleControlSocketSessionConnected;
    if TMethod(FControlSocket.OnDataAvailable).Code <> @TElSecureFtpClient.HandleDataAvailable then
      FControlSocket.OnDataAvailable := HandleDataAvailable;
    if TMethod(FControlSocket.OnSessionClosed).Code <> @TElSecureFtpClient.ControlSocketSessionClosed then
      FControlSocket.OnSessionClosed := ControlSocketSessionClosed;
    if TMethod(FControlSocket.OnDnsLookupDone).Code <> @TElSecureFtpClient.ControlSocketDnsLookupDone then
      FControlSocket.OnDnsLookupDone := ControlSocketDnsLookupDone;

    TElSecureWSocket(FControlSocket).OnCertificateValidate := FOnCertificateValidate;
    TElSecureWSocket(FControlSocket).OnCertificateNeeded := FOnCertificateNeeded;
    TElSecureWSocket(FControlSocket).OnCertificateChoose := FOnCertificateChoose;
    TElSecureWSocket(FControlSocket).OnCertificateNeededEx := FOnCertificateNeededEx;
    TElSecureWSocket(FControlSocket).OnSSLError := HandleControlSocketError;
    TElSecureWSocket(FControlSocket).OnSSLEstablished := FOnSSLEstablished;
    TElSecureWSocket(FControlSocket).OnCiphersNegotiated := FOnCiphersNegotiated;
    TElSecureWSocket(FControlSocket).SSLEnabled := FAuth = atAuthImplicit;
    if FCertStorage <> nil then
      TElSecureWSocket(FControlSocket).CertStorage := FCertStorage;
    if FEncryptDataChannel then
    begin
      Destr := false;
      if Assigned(FDataSocket) then
      begin
        CopySocketInfo(FDataSocket, FAuxSocket);
        FreeAndNil(FDataSocket);
        Destr := true;
      end;
      FDataSocket := TElSecureWSocket.Create(nil);
      if Destr then
        CopySocketInfo(FAuxSocket, FDataSocket);
      TElSecureWSocket(FDataSocket).OnCertificateValidate := HandleDataSocketCertificate;
      TElSecureWSocket(FDataSocket).SSLEnabled := true;
      FDataSocket.OnDataAvailable := DataSocketGetDataAvailable;
      FOldDataSocketOnSessionConnected := FDataSocket.OnSessionConnected;
      FOldDataSocketOnSessionAvailable := FDataSocket.OnSessionAvailable;
      FDataSocket.OnSessionAvailable := HandleDataSocketSessionAvailable;
      TElSecureWSocket(FDataSocket).Versions := FVersions;
    end;

    if TMethod(FOnSessionConnected).Code <> @TElSecureFtpClient.HandleSessionConnected then
    begin
      FOldOnSessionConnected := FOnSessionConnected;
      FOnSessionConnected := HandleSessionConnected;
    end;

    FState := FTP_STATE_BEFORE;
    TElSecureWSocket(FControlSocket).Versions := FVersions;
    FServerSupportsSSL := true;

    for I := SB_SUITE_FIRST to SB_SUITE_LAST do
    begin
      TElSecureWSocket(FControlSocket).CipherSuites[I] := FCipherSuites[I];
      if FEncryptDataChannel then
        TElSecureWSocket(FDataSocket).CipherSuites[I] := FCipherSuites[I];
    end;
    for I := SSL_CA_FIRST to SSL_CA_LAST do
    begin
      TElSecureWSocket(FControlSocket).CompressionAlgorithms[I] := FCompressionAlgorithms[I];
      if FEncryptDataChannel then
        TElSecureWSocket(FDataSocket).CompressionAlgorithms[I] := FCompressionAlgorithms[I];
    end;
  end
  else
  begin
    if Assigned(FControlSocket) then
    begin
      CopySocketInfo(FControlSocket, FAuxSocket);
      FreeAndNil(FControlSocket);
      Destr := true;
    end;
    FControlSocket := TWSocket.Create(nil);
    if Destr then
      CopySocketInfo(FAuxSocket, FControlSocket);
    FControlSocket.OnSessionConnected := ControlSocketSessionConnected;
    FControlSocket.OnDataAvailable := ControlSocketDataAvailable;
    FControlSocket.OnSessionClosed := ControlSocketSessionClosed;
    FControlSocket.OnDnsLookupDone := ControlSocketDnsLookupDone;
    Destr := false;
    if Assigned(FDataSocket) then
    begin
      CopySocketInfo(FDataSocket, FAuxSocket);
      FreeAndNil(FDataSocket);
      Destr := true;
    end;
    FDataSocket := TWSocket.Create(nil);
    if Destr then
      CopySocketInfo(FAuxSocket, FDataSocket);
    FServerSupportsSSL := false;
  end;
  FOutBuffer := '';
  FAuthSSLSent := false;
  inherited OpenAsync;
end;

procedure TElSecureFtpClient.CopySocketInfo(Src, Dest: TWSocket);
begin
  Dest.BufSize := Src.BufSize;
  Dest.Addr := Src.Addr;
  Dest.Port := Src.Port;
  Dest.Proto := Src.Proto;
  Dest.LocalAddr := Src.LocalAddr;
  Dest.LocalPort := Src.LocalPort;
  Dest.MultiThreaded := Src.MultiThreaded;
  Dest.MultiCast := Src.MultiCast;
  Dest.MultiCastAddrStr := Src.MultiCastAddrStr;
  Dest.MultiCastIpTTL := Src.MultiCastIpTTL;
  Dest.ReuseAddr := Src.ReuseAddr;
  Dest.ComponentOptions := Src.ComponentOptions;
  Dest.FlushTimeout := Src.FlushTimeout;
  Dest.SendFlags := Src.SendFlags;
  Dest.LingerOnOff := Src.LingerOnOff;
  Dest.LingerTimeout := Src.LingerTimeout;
  Dest.SocksLevel := Src.SocksLevel;
  Dest.SocksServer := Src.SocksServer;
  Dest.SocksPort := Src.SocksPort;
  Dest.SocksUsercode := Src.SocksUsercode;
  Dest.SocksPassword := Src.SocksPassword;
  Dest.SocksAuthentication := Src.SocksAuthentication;
{$IFDEF NOFORMS}
  Dest.OnMessagePump := Src.OnMessagePump;
{$ENDIF}
end;

procedure TElSecureFtpClient.HandleSessionConnected(Sender: TObject; Error: word);
var
  S: string;
begin
  if FAuth <> atAuthImplicit then
  begin
    FState := FTP_STATE_AUTH_SENT;
    if FAuth = atAuthTLS then
    begin
      S := 'AUTH TLS';
      FControlSocket.SendStr(S + #13#10);
    end
    else
    begin
      S := 'AUTH SSL';
      FControlSocket.SendStr(S + #13#10);
    end;
    S := '> ' + S;
    if Assigned(FOnDisplay) then
      FOnDisplay(Self, S);
  end
  else
  begin
    FState := FTP_STATE_SSL_ENABLED;
    ControlSocketSessionConnected(Self, Error);
    if Assigned(FOldOnSessionConnected) then
      FOldOnSessionConnected(Sender, Error);
  end;
end;

procedure TElSecureFtpClient.HandleDataAvailable(Sender: TObject; Error: word);
const
  BUFFER_SIZE = 16384;
var
  Len: integer;
  Buf: array[0..BUFFER_SIZE - 1] of byte;
  S: string;
begin
  if (FState = FTP_STATE_BEFORE) or (FState = FTP_STATE_SSL_ENABLED) then
  begin