cldc.pas

Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码 Clever_Internet_Suite_6.2的代码

{
  Clever Internet Suite Version 6.2
  Copyright (C) 1999 - 2006 Clever Components
  www.CleverComponents.com
}

unit clDC;

interface

{$I clVer.inc}

uses
  Windows, SysUtils, Classes, clWinInet, clConnection, clDCUtils, clUtils, SyncObjs,
  clCryptApi, clCert, clFtpUtils, clHttpUtils, clHttpAuth, clUriUtils, clSyncUtils
  {$IFDEF LOGGER}, clLogger{$ENDIF};

type
  TclProcessPriority = (ppLower, ppNormal, ppHigher);
  TclProcessStatus = (psUnknown, psSuccess, psFailed, psErrors, psProcess, psTerminated);

  TclOnStatusChanged = procedure (Sender: TObject; Status: TclProcessStatus) of object;
  TclOnDataItemProceed = procedure (Sender: TObject; ResourceInfo: TclResourceInfo;
    BytesProceed: Integer; CurrentData: PChar; CurrentDataSize: Integer) of object;
  TclOnError = procedure (Sender: TObject; const Error: string; ErrorCode: Integer) of object;
  TclOnGetResourceInfo = procedure (Sender: TObject; ResourceInfo: TclResourceInfo) of object;
  TclPerformRequestOperation = procedure (AParameters: TObject) of object;

  TclCustomThreader = class(TThread)
  private
    FURL: string;
    FDataStream: TStream;
    FLastError: string;
    FLastErrorCode: Integer;
    FTimeOut: Integer;
    FTryCount: Integer;
    FBatchSize: Integer;
    FSelfConnection: TclInternetConnection;
    FConnection: TclInternetConnection;
    FStatus: TclProcessStatus;
    FURLParser: TclUrlParser;
    FOnStatusChanged: TclOnStatusChanged;
    FOnError: TclOnError;
    FOnGetResourceInfo: TclOnGetResourceInfo;
    FOnUrlParsing: TclOnUrlParsing;
    FOnDataItemProceed: TclOnDataItemProceed;
    FUrlComponents: TURLComponents;
    FCertificateFlags: TclCertificateFlags;
    FUseInternetErrorDialog: Boolean;
    FOnGetCertificate: TclOnGetCertificateEvent;
    FCertificate: TclCertificate;
    FCertificateHandled: Boolean;
    FProxyBypass: string;
    FInternetAgent: string;
    FSelfResourceInfo: TclResourceInfo;
    FDataAccessor: TCriticalSection;
    FBytesToProceed: Integer;
    FResourcePos: Integer;
    FKeepConnection: Boolean;
    FPassiveFTPMode: Boolean;
    FReconnectAfter: Integer;
    FSleepEvent: THandle;
    FAllowCompression: Boolean;
    FSynchronizer: TclThreadSynchronizer;
    FRequestHeader: TStrings;
    FDoNotGetResourceInfo: Boolean;
    FFtpProxySettings: TclFtpProxySettings;
    FHttpProxySettings: TclHttpProxySettings;
    FResponseHeader: TStrings;
    FTempErrorCode: Integer;
    procedure DoOnURLParsing(Sender: TObject; var UrlComponents: TURLComponents);
    procedure PrepareURL;
    procedure SyncDoGetResourceInfo;
    procedure SyncDoError;
    procedure SyncDoStatusChanged;
    procedure SyncDoURLParsing;
    procedure SyncDoGetCertificate;
    procedure SyncTerminate;
    procedure SetupCertIgnoreOptions(AOpenRequest: TclHttpOpenRequestAction);
    procedure SetupCertificateOptions(AOpenRequest: TclHttpOpenRequestAction);
    function SetCertOptions(AOpenRequest: TclHttpOpenRequestAction; AErrorCode: Integer): Boolean;
    procedure SetResourceInfo(const Value: TclResourceInfo);
    function GetInternalResourceInfo: TclResourceInfo;
    procedure SetURLParser(const Value: TclUrlParser);
    procedure SetCertOptionsOperation(AParameters: TObject);
    function GetConnection: TclInternetConnection;
    procedure SetConnection(const Value: TclInternetConnection);
    procedure WaitForReconnect(ATimeOut: Integer);
    function GetOpenRequestFlags(ANeedCaching: Boolean): DWORD;
    procedure SetRequestHeader(const Value: TStrings);
    procedure QueryGetInfo(AOpenRequestAction: TclHttpOpenRequestAction);
    procedure QueryHeadInfo(AOpenRequestAction: TclHttpOpenRequestAction);
    procedure SetFtpProxySettings(const Value: TclFtpProxySettings);
    procedure SetHttpProxySettings(const Value: TclHttpProxySettings);
    function GetProxyString: string;
    procedure GetAllHeaders(ARequest: TclHttpOpenRequestAction);
  protected
    FResourceInfo: TclResourceInfo;
    procedure ServerAuthentication(AOpenRequest: TclHttpOpenRequestAction);
    procedure ProxyAuthentication(AOpenRequest: TclHttpOpenRequestAction);
    procedure GetHttpStatusCode(ARequest: TclHttpOpenRequestAction);
    procedure FreeObjectIfNeed(var AObject);
    procedure SendRequest(AOpenRequest: TclHttpOpenRequestAction);
    procedure PerformRequestOperation(AOpenRequest: TclHttpOpenRequestAction;
      AOperation: TclPerformRequestOperation; AParameters: TObject);
    procedure GetResourceInfo(AConnect: TclConnectAction);
    procedure GetHTTPResourceInfo(AConnect: TclConnectAction); virtual;
    procedure GetFTPResourceInfo(AConnect: TclConnectAction); virtual;
    procedure ProcessHTTP(AConnect: TclConnectAction); virtual;
    procedure ProcessFTP(AConnect: TclConnectAction); virtual;
    procedure DoTerminate; override;
    procedure Execute; override;
    procedure ProcessURL; virtual;
    procedure DoStop; virtual;
    procedure SetHttpHeader(AResourceAction: TclInternetResourceAction);
    procedure AssignIfNeedResourceInfo;
    procedure ClearInfo;
    procedure SetStatus(AStatus: TclProcessStatus);
    procedure InternalSynchronize(Method: TThreadMethod);
    function GetNormTimeOut(ATimeOut: Integer): Integer; virtual;
    procedure AssignError(const AError, ADescription: string; AErrorCode: Integer);
    procedure BeginDataStreamAccess;
    procedure EndDataStreamAccess;
    property DataStream: TStream read FDataStream;
    property URL: string read FURL;
    property TempErrorCode: Integer read FTempErrorCode;
  public
    constructor Create(const AURL: string; ADataStream: TStream);
    destructor Destroy; override;
    procedure Perform; virtual;
    procedure Wait;
    procedure Stop;
    property RequestHeader: TStrings read FRequestHeader write SetRequestHeader;
    property ResponseHeader: TStrings read FResponseHeader;
    property Status: TclProcessStatus read FStatus;
    property LastError: string read FLastError;
    property LastErrorCode: Integer read FLastErrorCode;
    property DoNotGetResourceInfo: Boolean read FDoNotGetResourceInfo write FDoNotGetResourceInfo;
    property PassiveFTPMode: Boolean read FPassiveFTPMode write FPassiveFTPMode;
    property BytesToProceed: Integer read FBytesToProceed write FBytesToProceed;
    property ResourcePos: Integer read FResourcePos write FResourcePos;
    property URLParser: TclUrlParser read FURLParser write SetURLParser;
    property ResourceInfo: TclResourceInfo read GetInternalResourceInfo write SetResourceInfo;
    property DataAccessor: TCriticalSection read FDataAccessor write FDataAccessor;
    property Connection: TclInternetConnection read GetConnection write SetConnection;
    property KeepConnection: Boolean read FKeepConnection write FKeepConnection;
    property BatchSize: Integer read FBatchSize write FBatchSize;
    property TryCount: Integer read FTryCount write FTryCount;
    property TimeOut: Integer read FTimeOut write FTimeOut;
    property ReconnectAfter: Integer read FReconnectAfter write FReconnectAfter; 
    property CertificateFlags: TclCertificateFlags read FCertificateFlags write FCertificateFlags;
    property UseInternetErrorDialog: Boolean read FUseInternetErrorDialog write FUseInternetErrorDialog;
    property ProxyBypass: string read FProxyBypass write FProxyBypass;
    property HttpProxySettings: TclHttpProxySettings read FHttpProxySettings write SetHttpProxySettings;
    property FtpProxySettings: TclFtpProxySettings read FFtpProxySettings write SetFtpProxySettings;
    property InternetAgent: string read FInternetAgent write FInternetAgent;
    property AllowCompression: Boolean read FAllowCompression write FAllowCompression;
    property OnDataItemProceed: TclOnDataItemProceed read FOnDataItemProceed write FOnDataItemProceed;
    property OnError: TclOnError read FOnError write FOnError;
    property OnGetCertificate: TclOnGetCertificateEvent read FOnGetCertificate write FOnGetCertificate;
    property OnGetResourceInfo: TclOnGetResourceInfo read FOnGetResourceInfo write FOnGetResourceInfo;
    property OnStatusChanged: TclOnStatusChanged read FOnStatusChanged write FOnStatusChanged;
    property OnUrlParsing: TclOnUrlParsing read FOnUrlParsing write FOnUrlParsing;
  end;

  TclDownLoadThreader = class(TclCustomThreader)
  private
    FIsGetResourceInfo: Boolean;
    FDataProceed: PChar;
    FDataProceedSize: Integer;
    FTotalDownloaded: Integer;
    procedure SyncDoDataItemProceed;
    procedure Dump(AResourceAction: TclInternetResourceAction);
    procedure SetResourcePos(AResourceAction: TclInternetResourceAction);
    procedure PrepareHeader;
  protected
    procedure ProcessHTTP(AConnect: TclConnectAction); override;
    procedure ProcessFTP(AConnect: TclConnectAction); override;
  public
    constructor Create(const AURL: string; ADataStream: TStream; AIsGetResourceInfo: Boolean);
  end;

  TclDeleteThreader = class(TclCustomThreader)
  protected
    procedure ProcessHTTP(AConnect: TclConnectAction); override;
    procedure ProcessFTP(AConnect: TclConnectAction); override;
  public
    constructor Create(const AURL: string);
  end;

  TclUploadThreader = class(TclCustomThreader)
  private
    FIsGetResourceInfo: Boolean;
    FDataProceedSize: Integer;
    FUploadedDataSize: Integer;
    FDataProceed: PChar;
    FHttpResponse: TStream;
    FForceRemoteDir: Boolean;
    FUseSimpleRequest: Boolean;
    FRequestMethod: string;
    FRetryCount: Integer;
    FRetryProceed: Integer;
    procedure SyncDoDataItemProceed;
    procedure ProcessRequest(AOpenRequest: TclHttpOpenRequestAction;
      const AHeader: string; ADataSize: Integer);
    procedure ProcessSimpleRequest(AOpenRequest: TclHttpOpenRequestAction;
      const AHeader: string; AData: TStream);
    procedure GetResourceInfoByDataStream;
    procedure RequestOperation(AParameters: TObject);
    procedure SimpleRequestOperation(AParameters: TObject);
    procedure ForceRemoteDirectory(AConnect: TclConnectAction);
    function GetRetryCount: Integer;
  protected
    procedure GetHttpResponse(AOpenRequest: TclHttpOpenRequestAction);
    procedure Dump(AResourceAction: TclInternetResourceAction);
    procedure ProcessFTP(AConnect: TclConnectAction); override;
    procedure ProcessHTTP(AConnect: TclConnectAction); override;
  public
    constructor Create(const AURL: string; ADataStream: TStream; AIsGetResourceInfo: Boolean);
    property HttpResponse: TStream read FHttpResponse write FHttpResponse;
    property ForceRemoteDir: Boolean read FForceRemoteDir write FForceRemoteDir;
    property UseSimpleRequest: Boolean read FUseSimpleRequest write FUseSimpleRequest;
    property RequestMethod: string read FRequestMethod write FRequestMethod;
  end;

procedure DownloadUrl(const AUrl: string; ATimeOut: Integer; AHtml: TStrings);

var
  PutOptimization: Boolean = False;

implementation

{$IFDEF DEMO}
uses
  Forms;
{$ENDIF}

type
  TclResourceInfoAccess = class(TclResourceInfo);

procedure DownloadUrl(const AUrl: string; ATimeOut: Integer; AHtml: TStrings);
var
  Stream: TStream;
  Threader: TclDownloadThreader;
begin
  Stream := nil;
  Threader := nil;
  try
    Stream := TMemoryStream.Create();
    Threader := TclDownloadThreader.Create(AUrl, Stream, False);
    Threader.TimeOut := ATimeOut;
    Threader.AllowCompression := False;
    Threader.Perform();
    Threader.Wait();
    if not (Threader.Status in [psSuccess, psErrors]) then
    begin
      raise EclInternetError.Create(Threader.LastError, Threader.LastErrorCode);
    end;
    Stream.Position := 0;
    AHtml.Clear();
    AHtml.LoadFromStream(Stream);
  finally
    Threader.Free();
    Stream.Free();
  end;
end;

{ TclCustomThreader }

procedure TclCustomThreader.PrepareURL;
var
  s: string;
begin
  if FURLParser.ParsedUrl <> '' then Exit;
  s := FURLParser.Parse(FURL);
  if (s <> '') then
  begin
    FURL := s;
  end else
  begin
    raise EclInternetError.CreateByLastError();
  end;
end;

constructor TclCustomThreader.Create(const AURL: string; ADataStream: TStream);
begin
  inherited Create(True);
  FFtpProxySettings := TclFtpProxySettings.Create();
  FHttpProxySettings := TclHttpProxySettings.Create();
  FRequestHeader := TStringList.Create();
  FResponseHeader := TStringList.Create();
  FSynchronizer := TclThreadSynchronizer.Create();
  FSleepEvent := CreateEvent(nil, False, False, nil);
  FURLParser := TclUrlParser.Create();
  FURLParser.OnUrlParsing := DoOnURLParsing;
  FURL := AURL;
  FDataStream := ADataStream;
  FStatus := psUnknown;
  FTryCount := cTryCount;
  FBatchSize := cBatchSize;
  FTimeOut := cTimeOut;
  FReconnectAfter := cTimeOut;
  FInternetAgent := cInternetAgent;
  FResourcePos := 0;
  FBytesToProceed := -1;
end;

destructor TclCustomThreader.Destroy;
begin
  ClearInfo();
  FURLParser.Free();
  FSelfConnection.Free();
  CloseHandle(FSleepEvent);
  FSynchronizer.Free();
  FResponseHeader.Free();
  FRequestHeader.Free();
  FHttpProxySettings.Free();
  FFtpProxySettings.Free();
  inherited Destroy();
end;

procedure TclCustomThreader.AssignError(const AError, ADescription: string; AErrorCode: Integer);
begin
{$IFDEF LOGGER}try clPutLogMessage(Self, edEnter, 'AssignError');{$ENDIF}

  if Terminated then Exit;
  FLastError := AError;
  FLastErrorCode := AErrorCode;
  if (FLastError = '') then
  begin
    FLastErrorCode := GetLastError();
    FLastError := GetLastErrorText(FLastErrorCode);
  end;
  if (ADescription <> '') then
  begin
    FLastError := FLastError + ': ' + ADescription;
  end;
  InternalSynchronize(SyncDoError);
{$IFDEF LOGGER}clPutLogMessage(Self, edLeave, 'AssignError'); except on E: Exception do begin clPutLogMessage(Self, edLeave, 'AssignError', E); raise; end; end;{$ENDIF}
end;

procedure TclCustomThreader.SyncDoStatusChanged;
begin
  if Assigned(FOnStatusChanged) then
  begin
    FOnStatusChanged(Self, FStatus);
  end;
end;

procedure TclCustomThreader.AssignIfNeedResourceInfo;
begin
  if (FSelfResourceInfo = nil) then
  begin
    FSelfResourceInfo := TclResourceInfo.Create();
  end;
  TclResourceInfoAccess(ResourceInfo).SetName(FURLParser.Urlpath);
end;

procedure TclCustomThreader.SetupCertIgnoreOptions(AOpenRequest: TclHttpOpenRequestAction);
var
  dwFlags, dwBuffLen: DWORD;
begin
  if (URLParser.UrlType <> utHTTPS) then Exit;
  dwBuffLen := SizeOf(dwFlags);
  if not InternetQueryOption(AOpenRequest.hResource, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, dwBuffLen) then
  begin
    raise EclInternetError.CreateByLastError();
  end;
  
  if cfIgnoreCommonNameInvalid in FCertificateFlags then
    dwFlags := dwFlags or SECURITY_FLAG_IGNORE_CERT_CN_INVALID;
  if cfIgnoreDateInvalid in FCertificateFlags then
    dwFlags := dwFlags or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID;
  if cfIgnoreUnknownAuthority in FCertificateFlags then
    dwFlags := dwFlags or SECURITY_FLAG_IGNORE_UNKNOWN_CA;
  if cfIgnoreRevocation in FCertificateFlags then
    dwFlags := dwFlags or SECURITY_FLAG_IGNORE_REVOCATION;
  if cfIgnoreWrongUsage in FCertificateFlags then
    dwFlags := dwFlags or SECURITY_FLAG_IGNORE_WRONG_USAGE;

  if not InternetSetOption(AOpenRequest.hResource, INTERNET_OPTION_SECURITY_FLAGS, @dwFlags, dwBuffLen) then
  begin
    raise EclInternetError.CreateByLastError();
  end;
end;

procedure TclCustomThreader.SetupCertificateOptions(AOpenRequest: TclHttpOpenRequestAction);
var
  size: DWORD;
begin
  FCertificate := nil;
  size := 0;
  FCertificateHandled := False;
  InternalSynchronize(SyncDoGetCertificate);
  if FCertificateHandled then
  begin
    if (FCertificate <> nil) then
    begin
      size := SizeOf(CERT_CONTEXT);
    end;
    if not InternetSetOption(AOpenRequest.hResource, INTERNET_OPTION_CLIENT_CERT_CONTEXT,
      FCertificate.Context, size) then
    begin
      raise EclInternetError.CreateByLastError();
    end;
  end;
end;

function TclCustomThreader.SetCertOptions(AOpenRequest: TclHttpOpenRequestAction;
  AErrorCode: Integer): Boolean;
var
  p: Pointer;
begin
  Result := True;
  if FUseInternetErrorDialog then
  begin
    Result := InternetErrorDlg(GetDesktopWindow(), AOpenRequest.hResource, AErrorCode,
      FLAGS_ERROR_UI_FILTER_FOR_ERRORS or
      FLAGS_ERROR_UI_FLAGS_GENERATE_DATA or
      FLAGS_ERROR_UI_FLAGS_CHANGE_OPTIONS, p) <> ERROR_CANCELLED;
  end else
  begin
    case AErrorCode of
      ERROR_INTERNET_CLIENT_AUTH_CERT_NEEDED: SetupCertificateOptions(AOpenRequest);
      ERROR_INTERNET_SEC_CERT_CN_INVALID,
      ERROR_INTERNET_SEC_CERT_DATE_INVALID,
      ERROR_INTERNET_INVALID_CA: SetupCertIgnoreOptions(AOpenRequest);
      else Result := False;
    end;
  end;
end;

procedure TclCustomThreader.SetCertOptionsOperation(AParameters: TObject);
begin
  (AParameters as TclHttpSendRequestAction).FireAction(GetNormTimeOut(TimeOut));
end;

procedure TclCustomThreader.PerformRequestOperation(AOpenRequest: TclHttpOpenRequestAction;
  AOperation: TclPerformRequestOperation; AParameters: TObject);
var
  cnt, LastError: Integer;
begin
  cnt := 0;
  LastError := 0;
  repeat
    try
      AOperation(AParameters);
      Break;
    except
      on E: EclTimeoutInternetError do raise;
      on E: EclInternetError do
      begin
        if (E.ErrorCode <> 12032) then
        begin
          cnt := 0;
          if (LastError = E.ErrorCode) then raise;
          LastError := E.ErrorCode;
          if not SetCertOptions(AOpenRequest, LastError) then raise;
        end else
        begin
          Inc(cnt);
          if (cnt > 9) then raise;
        end;
      end;
    end;
  until False;
end;

procedure TclCustomThreader.SendRequest(AOpenRequest: TclHttpOpenRequestAction);
var
  i: Integer;
  request: TclHttpSendRequestAction;