ftpunit.pas

来自「著名的SecureBlackBox控件完整源码」· PAS 代码 · 共 656 行 · 第 1/2 页

unit FTPUnit;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, SBUtils, SBConstants, SBSimpleFTPS, SBCustomCertStorage, SBX509, SBWinCertStorage,
  ImgList, Menus, ComCtrls, ToolWin, ExtCtrls;

type
  TFTPForm = class(TForm)
    Splitter: TSplitter;
    lvLog: TListView;
    pClient: TPanel;
    memoOutput: TMemo;
    MainMenu: TMainMenu;
    mnuConnection: TMenuItem;
    mnuConnect: TMenuItem;
    mnuDisconnect: TMenuItem;
    mnuBreak: TMenuItem;
    mnuExit: TMenuItem;
    mnuHelp: TMenuItem;
    mnuAbout: TMenuItem;
    imgLog: TImageList;
    ElWinCertStorage: TElWinCertStorage;
    ElMemoryCertStorage: TElMemoryCertStorage;
    pnlCommands: TPanel;
    Label1: TLabel;
    editCmdParam: TEdit;
    Label2: TLabel;
    btnConnect: TButton;
    btnDisconnect: TButton;
    btnPWD: TButton;
    btnCWD: TButton;
    btnCDUp: TButton;
    btnList: TButton;
    btnMKD: TButton;
    btnRMD: TButton;
    btnDownload: TButton;
    dlgOpen: TOpenDialog;
    dlgSave: TSaveDialog;
    btnUpload: TButton;
    btnDelete: TButton;
    procedure btnConnectClick(Sender: TObject);
    procedure mnuExitClick(Sender: TObject);
    procedure btnDisconnectClick(Sender: TObject);
    procedure mnuConnectClick(Sender: TObject);
    procedure mnuDisconnectClick(Sender: TObject);
    procedure btnPWDClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure btnCWDClick(Sender: TObject);
    procedure btnCDUpClick(Sender: TObject);
    procedure mnuAboutClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnListClick(Sender: TObject);
    procedure btnMKDClick(Sender: TObject);
    procedure btnRMDClick(Sender: TObject);
    procedure btnDownloadClick(Sender: TObject);
    procedure btnUploadClick(Sender: TObject);
    procedure btnDeleteClick(Sender: TObject);
  private
    FClient : TElSimpleFTPSClient;
    FCert : TElX509Certificate;
    FUseCert : boolean;
    FNeededIndex : integer;

    procedure ClientSSLError(Sender : TObject; ErrorCode: integer; Fatal: boolean; Remote : boolean);
    procedure ClientCertificateNeededEx(Sender: TObject; var Certificate:
        TElX509Certificate);
    procedure ClientCertificateValidate(Sender: TObject; Cert : TElX509Certificate;
        var Validate : boolean);
    procedure ClientTextDataLine(Sender : TObject; const TextLine : string);
    procedure ClientControlSend(Sender : TObject; const TextLine : string);
    procedure ClientControlreceive(Sender : TObject; const TextLine : string);
    procedure ClientProgress(Sender : TObject; Total, Current : Int64; var Cancel : boolean);
    procedure Connect;
    procedure Disconnect;
    procedure ExitApp;
    procedure FinalizeApp;
    procedure InitializeApp;
    procedure Log(const S: string; Error: boolean);
    procedure SetupEvents;
    procedure ShowAbout;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FTPForm: TFTPForm;

implementation

uses ProgressForm, ConnPropsForm, AboutForm, SBSSLConstants;

resourcestring
  sNotConnected = 'You are not connected. Use Connect command first.';
  sNoParameter  = 'Command parameter not specified';

{$R *.DFM}

procedure TFTPForm.btnConnectClick(Sender: TObject);
begin
  Connect;
end;

procedure TFTPForm.mnuExitClick(Sender: TObject);
begin
  ExitApp;
end;

procedure TFTPForm.btnDisconnectClick(Sender: TObject);
begin
  Disconnect;
end;

procedure TFTPForm.ClientCertificateNeededEx(Sender: TObject; var Certificate:
    TElX509Certificate);
begin
  if (FUseCert) and (FNeededIndex = 0) then
  begin
    Certificate := FCert;
    Inc(FNeededIndex);
  end
  else
  begin
    Certificate := nil;
  end;
end;

procedure TFTPForm.ClientCertificateValidate(Sender: TObject; Cert :
    TElX509Certificate; var Validate : boolean);
var
  S: string;
  Validity: TSBCertificateValidity;
  Reason: TSBCertificateValidityReason;
begin
  Log('Certificate received', false);
  S := 'Issuer: ' + 'CN=' + Cert.IssuerName.CommonName + ', C=' + Cert.IssuerName.Country +
    ', O=' + Cert.IssuerName.Organization + ', L=' + Cert.IssuerName.Locality;
  Log(S, false);
  S := 'Subject: ' + 'CN=' + Cert.SubjectName.CommonName + ', C=' + Cert.SubjectName.Country +
    ', O=' + Cert.SubjectName.Organization + ', L=' + Cert.SubjectName.Locality;
  Log(S, false);
  FClient.InternalValidate(Validity, Reason);
  if not (Validity in [cvOk, cvSelfSigned]) then
  begin
    Validity := ElMemoryCertStorage.Validate(Cert, Reason);
    if not (Validity in [cvOk, cvSelfSigned]) then
      Log('Warning: certificate is not valid!', true)
    else
      Log('Certificate is OK', false);
  end
  else
    Log('Certificate is OK', false);
  // adding certificate to temporary store
  ElMemoryCertStorage.Add(Cert);
  Validate := true;
end;

procedure TFTPForm.Connect;
var
  F : TFileStream;
  R : integer;
  S : string;
begin
  if FClient.Active then
  begin
    MessageDlg('Already connected, please disconnect first', mtWarning, [mbOk], 0);
    Exit;
  end;

  if frmConnProps.ShowModal = mrOk then
  begin
    memoOutput.Clear;
    lvLog.Items.Clear;

    FClient.Address := frmConnProps.editHost.Text;
    FClient.Port := StrToIntDef(frmConnProps.editPort.Text, 21);
    FClient.Username := frmConnProps.editUsername.Text;
    FClient.Password := frmConnProps.editPassword.Text;
    FClient.CompressionAlgorithms[SSL_CA_ZLIB]:=frmConnProps.cbCompression.Checked;
    FClient.Versions := [];
    if frmConnProps.cbSSL2.Checked then
      FClient.Versions := FClient.Versions + [sbSSL2];
    if frmConnProps.cbSSL3.Checked then
      FClient.Versions := FClient.Versions + [sbSSL3];
    if frmConnProps.cbTLS1.Checked then
      FClient.Versions := FClient.Versions + [sbTLS1];
    if frmConnProps.cbTLS11.Checked then
      FClient.Versions := FClient.Versions + [sbTLS11];
    FUseCert := false;
    if (frmConnProps.editCert.Text <> '') and (FileExists(frmConnProps.editCert.Text)) then
    begin
      try
        F := TFileStream.Create(frmConnProps.editCert.Text, fmOpenRead);
        try
          R := FCert.LoadFromStreamPFX(F, frmConnProps.editCertPassword.Text);
          if R = 0 then
          begin
            FUseCert := true;
            Log('Certificate loaded OK', false);
          end
          else
            Log('Failed to load certificate, PFX error ' + IntToHex(R, 4), true);
        finally
          F.Free;
        end;
      except
        on E: Exception do
          Log(E.Message, true);
      end;
    end;
    Log('Connecting to ' + FClient.Address + ':' + IntToStr(FClient.Port), false);
    FClient.UseSSL := frmConnProps.cbUseSSL.Checked;
    FClient.EncryptDataChannel := not frmConnProps.cbClear.Checked;
    if frmConnProps.ComboAuthCmd.ItemIndex =-1 then
      FClient.AuthCmd := acAuto
    else
      FClient.AuthCmd := TSBFTPAuthCmd(frmConnProps.ComboAuthCmd.ItemIndex);
    FClient.PassiveMode := frmConnProps.cbPassive.Checked;
    if frmConnProps.cbImplicit.Checked then
      FClient.SSLMode := smImplicit
    else
      FClient.SSLMode := smExplicit;

    FNeededIndex := 0;
    ElMemoryCertStorage.Clear;

    try
      FClient.Open;
      Log('Connected', false);

      FClient.Login;
      Log('Loggged in', false);

      if FClient.UseSSL then
      begin
        case FClient.Version of
          sbSSL2 : S := 'SSL2';
          sbSSL3 : S := 'SSL3';
          sbTLS1 : S := 'TLS1';
          sbTLS11 : S := 'TLS1.1';
        else
          S := 'Unknown';
        end;
        Log('SSL version is ' + S, false);
      end;

    except
      on E: Exception do
        Log(E.Message, true);
    end;
  end;
end;

procedure TFTPForm.Disconnect;
begin
  if FClient.Active then
  begin
    Log('Disconnecting', false);
    try
      FClient.Close(true);
      Log('Disconnected', false);
    except
      on E: Exception do
        Log(E.Message, true);
    end;
  end;
end;

procedure TFTPForm.ExitApp;
begin
  Self.Close;
end;

procedure TFTPForm.FinalizeApp;
begin
  FCert.Free;
  FClient.Free;
end;

procedure TFTPForm.InitializeApp;
begin
  FClient := TElSimpleFTPSClient.Create(nil);
  FCert := TElX509Certificate.Create(nil);
  SetupEvents;
  FClient.CertStorage := ElWinCertStorage;
end;

procedure TFTPForm.Log(const S: string; Error: boolean);
var
  Item : TListItem;
begin
  Item := lvLog.Items.Add;
  Item.Caption := TimeToStr(Now);
  Item.SubItems.Add(S);
  if Error then
    Item.ImageIndex := 1
  else
    Item.ImageIndex := 0;
end;

procedure TFTPForm.mnuConnectClick(Sender: TObject);
begin
  Connect;
end;

procedure TFTPForm.mnuDisconnectClick(Sender: TObject);
begin
  Disconnect;
end;

procedure TFTPForm.SetupEvents;
begin
  FClient.OnCertificateValidate := ClientCertificateValidate;
  FClient.OnCertificateNeededEx := ClientCertificateNeededEx;
  FClient.OnTextDataLine := ClientTextDataLine;
  FClient.OnControlSend := ClientControlSend;
  FClient.OnControlReceive := ClientControlReceive;
  FClient.OnSSLError := ClientSSLError;
  FClient.OnProgress := ClientProgress;
end;

 procedure TFTPForm.ShowAbout;
begin
  frmAbout.ShowModal;