clhttprequest.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 clHttpRequest;

interface

{$I clVer.inc}

uses
  Classes, SysUtils, clHtmlParser, clStreams, clHttpHeader;

type
  TclHttpRequestItem = class;

  TclGetDataStreamEvent = procedure (Sender: TObject; AItem: TclHttpRequestItem;
    var AData: TStream) of object;

  TclDataAddedEvent = procedure (Sender: TObject; AItem: TclHttpRequestItem; AData: TStream) of object;

  TclGetFormNumberEvent = procedure(Sender: TObject; AParser: TclHtmlParser;
    var AFormNumber: Integer) of object;

  TclHttpRequest = class;
  
  TclHttpRequestItem = class(TPersistent)
  private
    FOwner: TclHttpRequest;
    FTag: Integer;
    FCanonicalized: Boolean;
    procedure SetOwner(const Value: TclHttpRequest);
    procedure SetCanonicalized(const Value: Boolean);
  protected
    procedure ReadData(Reader: TReader); virtual;
    procedure WriteData(Writer: TWriter); virtual;
    procedure ParseHeader(AHeader, AFieldList: TStrings); virtual;
    procedure AddData(const AData: PChar; ADataSize: Integer); virtual; abstract;
    procedure AfterAddData; virtual; abstract;
    function GetData: TStream; virtual; abstract;
    function GetSize: Integer;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure Update;
    function GetCanonicalizedValue(const AValue: string): string;
  public
    constructor Create(AOwner: TclHttpRequest); virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    property Owner: TclHttpRequest read FOwner write SetOwner;
    property Tag: Integer read FTag write FTag;
    property Canonicalized: Boolean read FCanonicalized write SetCanonicalized;
  end;

  TclHttpRequestItemClass = class of TclHttpRequestItem;

  TclBinaryRequestItem = class(TclHttpRequestItem)
  protected
    procedure AddData(const AData: PChar; ADataSize: Integer); override;
    procedure AfterAddData; override;
    function GetData: TStream; override;
  end;

  TclTextRequestItem = class(TclHttpRequestItem)
  private
    FTextData: string;
    procedure SetTextData(const Value: string);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure AddData(const AData: PChar; ADataSize: Integer); override;
    procedure AfterAddData; override;
    function GetData: TStream; override;
  public
    procedure Assign(Source: TPersistent); override;
    property TextData: string read FTextData write SetTextData;
  end;

  TclFormFieldRequestItem = class(TclHttpRequestItem)
  private
    FFieldName: string;
    FFieldValue: string;
    function GetRequest: string;
    procedure SetFieldName(const Value: string);
    procedure SetFieldValue(const Value: string);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure AddData(const AData: PChar; ADataSize: Integer); override;
    procedure AfterAddData; override;
    function GetData: TStream; override;
  public
    procedure Assign(Source: TPersistent); override;
    property FieldName: string read FFieldName write SetFieldName;
    property FieldValue: string read FFieldValue write SetFieldValue;
  end;

  TclSubmitFileRequestItem = class(TclHttpRequestItem)
  private
    FFileName: string;
    FFieldName: string;
    FContentType: string;
    procedure SetContentType(const Value: string);
    procedure SetFieldName(const Value: string);
    procedure SetFileName(const Value: string);
  protected
    procedure ReadData(Reader: TReader); override;
    procedure WriteData(Writer: TWriter); override;
    procedure ParseHeader(AHeader, AFieldList: TStrings); override;
    procedure AddData(const AData: PChar; ADataSize: Integer); override;
    procedure AfterAddData; override;
    function GetData: TStream; override;
  public
    constructor Create(AOwner: TclHttpRequest); override;
    procedure Assign(Source: TPersistent); override;
    property FieldName: string read FFieldName write SetFieldName;
    property FileName: string read FFileName write SetFileName;
    property ContentType: string read FContentType write SetContentType;
  end;

  TclHttpRequest = class(TComponent)
  private
    FList: TList;
    FHeader: TclHttpRequestHeader;
    FOnChanged: TNotifyEvent;
    FOnGetDataStream: TclGetDataStreamEvent;
    FOnGetDataSourceStream: TclGetDataStreamEvent;
    FOnGetFormNumber: TclGetFormNumberEvent;
    FUpdateCount: Integer;
    FRequestSource: TStrings;
    FHeaderSource: TStrings;
    FIsParse: Boolean;
    FDataStream: TStream;
    FBatchSize: Integer;
    FOnDataAdded: TclDataAddedEvent;
    function GetTotalSize: Integer;
    function GetCount: Integer;
    function GetItem(Index: Integer): TclHttpRequestItem;
    procedure RemoveItem(AItem: TclHttpRequestItem);
    procedure AddItem(AItem: TclHttpRequestItem);
    procedure ClearItems;
    procedure ReadItems(Reader: TReader);
    procedure WriteItems(Writer: TWriter);
    procedure SetHeader(const Value: TclHttpRequestHeader);
    function GetFormField(const AFieldName: string): TclFormFieldRequestItem;
    procedure GetTotalRequestData(AStream: TclMultiStream);
    function GenerateBoundary: string;
    function GetRequestSource: TStrings;
    function GetHeaderSource: TStrings;
    procedure SetHeaderSource(const Value: TStrings);
    procedure ParseMultiPartRequest(AStream: TStream);
    procedure ParseFormField(const AFieldInfo: string);
    procedure ParseFormFieldRequest(const ASource: string);
    function GetRequestAsStream: TStream;
    procedure SetRequestAsStream(const Value: TStream);
    procedure SetRequestSource(const Value: TStrings);
    function ReadLine(AStream: TStream; AMaxBytes: Integer): string;
    procedure DoOnHeaderChanged(Sender: TObject);
    procedure InitBoundary;
    procedure ClearDataStream;
    function CreateMultiPartItem(const AHeader: string): TclHttpRequestItem;
  protected
    function IsMultiPart: Boolean;
    function IsForm: Boolean;
    function CreateHeader: TclHttpRequestHeader; virtual;
    function CreateItem(AHeader, AFieldList: TStrings): TclHttpRequestItem; virtual;
    procedure CreateSingleItem(AStream: TStream); virtual;
    function GetContentType: string; virtual;
    procedure InitHeader; virtual;
    procedure DefineProperties(Filer: TFiler); override;
    procedure DoGetDataStream(AItem: TclHttpRequestItem; var AData: TStream); dynamic;
    procedure DoGetDataSourceStream(AItem: TclHttpRequestItem; var AData: TStream); dynamic;
    procedure DoDataAdded(AItem: TclHttpRequestItem; AData: TStream); dynamic;
    procedure DoGetFormNumber(AParser: TclHtmlParser; var AFormNumber: Integer); dynamic;
    procedure Changed; dynamic;
    property DataStream: TStream read FDataStream write FDataStream;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function Add(AItemClass: TclHttpRequestItemClass): TclHttpRequestItem;
    function AddBinaryData: TclBinaryRequestItem;
    function AddTextData(const ATextData: string): TclTextRequestItem;
    function AddSubmitFile(const AFileName: string): TclSubmitFileRequestItem; overload;
    function AddSubmitFile(const AFileName, AFieldName: string): TclSubmitFileRequestItem; overload;
    function AddFormField(const AFieldName, AFieldValue: string): TclFormFieldRequestItem;
    procedure Delete(Index: Integer);
    procedure Move(CurIndex, NewIndex: Integer);
    procedure Clear; virtual;
    procedure BeginUpdate;
    procedure EndUpdate;
    function BuildFormPostRequest(AParser: TclHtmlParser): string; overload;
    function BuildFormPostRequest(AParser: TclHtmlParser; AFormNumber: Integer): string; overload;
    function BuildFormPostRequest(AHtml: TStrings): string; overload;
    function BuildFormPostRequest(const AUrl: string): string; overload;
    property RequestSource: TStrings read GetRequestSource write SetRequestSource;
    property HeaderSource: TStrings read GetHeaderSource write SetHeaderSource;
    property RequestStream: TStream read GetRequestAsStream write SetRequestAsStream;
    property Items[Index: Integer]: TclHttpRequestItem read GetItem; default;
    property FormFields[const AFieldName: string]: TclFormFieldRequestItem read GetFormField;
    property Count: Integer read GetCount;
    property TotalSize: Integer read GetTotalSize;
  published
    property Header: TclHttpRequestHeader read FHeader write SetHeader;
    property BatchSize: Integer read FBatchSize write FBatchSize default 8192;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
    property OnGetDataStream: TclGetDataStreamEvent read FOnGetDataStream write FOnGetDataStream;
    property OnGetDataSourceStream: TclGetDataStreamEvent read FOnGetDataSourceStream write FOnGetDataSourceStream;
    property OnDataAdded: TclDataAddedEvent read FOnDataAdded write FOnDataAdded;
    property OnGetFormNumber: TclGetFormNumberEvent read FOnGetFormNumber write FOnGetFormNumber;
  end;

procedure RegisterHttpRequestItem(AHeaderClass: TclHttpRequestItemClass);
function GetRegisteredHttpRequestItems: TList;

{$IFDEF DEMO}
{$IFNDEF IDEDEMO}
var
  IsHttpRequestDemoDisplayed: Boolean = False;
{$ENDIF}
{$ENDIF}

implementation

uses                         
  clWinInet, clDC, clUtils, Windows{$IFDEF DEMO}, Forms{$ENDIF};

const
  cFormDataContentType = 'application/x-www-form-urlencoded';
  cMultiPartContentType = 'multipart/form-data';

var
  RegisteredHttpRequestItems: TList = nil;

procedure RegisterHttpRequestItem(AHeaderClass: TclHttpRequestItemClass);
begin
  GetRegisteredHttpRequestItems().Add(AHeaderClass);
  Classes.RegisterClass(AHeaderClass);
end;

function GetRegisteredHttpRequestItems(): TList;
begin
  if (RegisteredHttpRequestItems = nil) then
  begin
    RegisteredHttpRequestItems := TList.Create();
  end;
  Result := RegisteredHttpRequestItems;
end;

{ TclHttpRequestItem }

procedure TclHttpRequestItem.Assign(Source: TPersistent);
begin
  if (Source is TclHttpRequestItem) then
  begin
    Canonicalized := TclHttpRequestItem(Source).Canonicalized;
  end else
  begin
    inherited Assign(Source);
  end;
end;

procedure TclHttpRequestItem.BeginUpdate;
begin
  if (Owner <> nil) then
  begin
    Owner.BeginUpdate();
  end;
end;

procedure TclHttpRequestItem.Update;
begin
  BeginUpdate();
  EndUpdate();
end;

constructor TclHttpRequestItem.Create(AOwner: TclHttpRequest);
begin
  inherited Create();
  SetOwner(AOwner);
  FCanonicalized := True;
end;

destructor TclHttpRequestItem.Destroy;
begin
  SetOwner(nil);
  inherited Destroy();
end;

procedure TclHttpRequestItem.EndUpdate;
begin
  if (Owner <> nil) then
  begin
    Owner.EndUpdate();
  end;
end;

procedure TclHttpRequestItem.ReadData(Reader: TReader);
begin
  BeginUpdate();
  try
    Canonicalized := Reader.ReadBoolean();
  finally
    EndUpdate();
  end;
end;

procedure TclHttpRequestItem.SetOwner(const Value: TclHttpRequest);
begin
  if (FOwner <> Value) then
  begin
    if (FOwner <> nil) then FOwner.RemoveItem(Self);
    FOwner := Value;
    if (FOwner <> nil) then FOwner.AddItem(Self);
  end;
end;

procedure TclHttpRequestItem.WriteData(Writer: TWriter);
begin
  Writer.WriteBoolean(Canonicalized);
end;

function TclHttpRequestItem.GetCanonicalizedValue(const AValue: string): string;
  function GetPos(const Substr, S: string): Integer;
  begin
    if LeadBytes = [] then
    begin
      Result := Pos(Substr, S);
    end else
    begin
      Result := AnsiPos(Substr, S);
    end;
  end;

const
  UnsafeChars = '+&*%<>"#{}|\^~[]''?!=/:$';
var
  i: Integer;
begin
  //TODO Canonicalized should be different for both multipart and formfield
  if (not Canonicalized) or ((Owner <> nil) and Owner.IsMultiPart()) then
  begin
    Result := AValue;
    Exit;
  end;
  
  Result := '';
  for i := 1 to Length(AValue) do
  begin
    if (GetPos(AValue[i], UnsafeChars) > 0) or (AValue[i] >= #$80) then
    begin
      Result := Result + '%' + IntToHex(Ord(AValue[i]), 2);
    end else
    if (AValue[i] = ' ') then
    begin
      Result := Result + '+';
    end else
    begin
      Result := Result + AValue[i];
    end;
  end
end;

procedure TclHttpRequestItem.SetCanonicalized(const Value: Boolean);
begin
  if (FCanonicalized <> Value) then
  begin
    FCanonicalized := Value;
    Update();
  end;
end;

function TclHttpRequestItem.GetSize: Integer;
var
  Stream: TStream;
begin
  Stream := GetData();
  try
    Result := Stream.Size;
  finally
    Stream.Free();
  end;
end;

procedure TclHttpRequestItem.ParseHeader(AHeader, AFieldList: TStrings);
begin
end;

{ TclHttpRequest }

function TclHttpRequest.GetContentType: string;
const
  RequestTypes: array[Boolean] of string = ('', cFormDataContentType);
var
  i: Integer;
  IsFormData: Boolean;
begin
  IsFormData := (Count > 0);
  for i := 0 to Count - 1 do
  begin
    if (Items[i] is TclSubmitFileRequestItem) then
    begin
      Result := cMultiPartContentType;
      Exit;
    end;
    IsFormData := IsFormData and (Items[i] is TclFormFieldRequestItem);
  end;
  Result := RequestTypes[IsFormData];
end;

procedure TclHttpRequest.AddItem(AItem: TclHttpRequestItem);
begin
  BeginUpdate();
  try
    FList.Add(AItem);
    if (not (csLoading in ComponentState)) and (not FIsParse) then
    begin
      Header.ContentType := GetContentType();
    end;
  finally
    EndUpdate();
  end;
end;

function TclHttpRequest.AddBinaryData: TclBinaryRequestItem;
begin
  BeginUpdate();
  try
    Result := Add(TclBinaryRequestItem) as TclBinaryRequestItem;
  finally
    EndUpdate();
  end;
end;

function TclHttpRequest.AddSubmitFile(const AFileName: string): TclSubmitFileRequestItem;
begin
  Result := AddSubmitFile(AFileName, 'FileName');
end;

function TclHttpRequest.AddFormField(const AFieldName, AFieldValue: string): TclFormFieldRequestItem;
begin
  BeginUpdate();
  try
    Result := Add(TclFormFieldRequestItem) as TclFormFieldRequestItem;
    Result.FieldName := AFieldName;
    Result.FieldValue := AFieldValue;
  finally
    EndUpdate();
  end;
end;

function TclHttpRequest.Add(AItemClass: TclHttpRequestItemClass): TclHttpRequestItem;
begin
  BeginUpdate();
  try
    Result := AItemClass.Create(Self);
  finally
    EndUpdate();
  end;
end;

function TclHttpRequest.AddTextData(const ATextData: string): TclTextRequestItem;
begin
  BeginUpdate();
  try
    Result := Add(TclTextRequestItem) as TclTextRequestItem;
    Result.TextData := ATextData;
  finally
    EndUpdate();
  end;
end;

procedure TclHttpRequest.Assign(Source: TPersistent);
var
  i: Integer;
  Item: TclHttpRequestItem;
begin
  if (Source is TclHttpRequest) then
  begin
    BeginUpdate();
    try
      Clear();
      for i := 0 to TclHttpRequest(Source).Count - 1 do
      begin
        Item := TclHttpRequest(Source).Items[i];
        Add(TclHttpRequestItemClass(Item.ClassType)).Assign(Item);
      end;
      Header.Assign(TclHttpRequest(Source).Header);
    finally
      EndUpdate();
    end;
  end else
  begin
    inherited Assign(Source);
  end;
end;

procedure TclHttpRequest.Clear;
begin
  BeginUpdate();
  try
    ClearItems();
    Header.Clear();
  finally
    EndUpdate();
  end;
end;

constructor TclHttpRequest.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FRequestSource := TStringList.Create();
  FHeaderSource := TStringList.Create();
  FList := TList.Create();
  FHeader := CreateHeader();
  FHeader.OnChanged := DoOnHeaderChanged;
  FBatchSize := 8192;
end;

function TclHttpRequest.CreateHeader: TclHttpRequestHeader;
begin
  Result := TclHttpRequestHeader.Create();
end;

procedure TclHttpRequest.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
  Filer.DefineProperty('Items', ReadItems, WriteItems, (FList.Count > 0));
end;

procedure TclHttpRequest.Delete(Index: Integer);
begin
  BeginUpdate();
  try
    FList.Delete(Index);
  finally
    EndUpdate();
  end;
end;

procedure TclHttpRequest.ClearDataStream;
begin
  FDataStream.Free();
  FDataStream := nil;
end;

destructor TclHttpRequest.Destroy;
begin
  ClearDataStream();
  ClearItems();
  FHeader.Free();
  FList.Free();
  FHeaderSource.Free();
  FRequestSource.Free();
  inherited Destroy();
end;

function TclHttpRequest.GetCount: Integer;
begin
  Result := FList.Count;
end;

function TclHttpRequest.GetItem(Index: Integer): TclHttpRequestItem;
begin
  Result := TclHttpRequestItem(FList[Index]);
end;

procedure TclHttpRequest.ReadItems(Reader: TReader);
var
  ItemClass: TclHttpRequestItemClass;
begin
  ClearItems();
  Reader.ReadListBegin();
  while not Reader.EndOfList() do
  begin
    ItemClass := TclHttpRequestItemClass(GetClass(Reader.ReadString()));
    if (ItemClass <> nil) then
    begin
      Add(ItemClass).ReadData(Reader);
    end;
  end;
  Reader.ReadListEnd();
end;