idwebbrooker.pas

C/S方式下的HTTPS安全数据传输控件.控件在INDY9 和delphi7下编译通过.可以很好的使用

unit IdWebBrooker;

interface

uses
  Classes, WebBroker, WebBrokerSOAP, IdHTTPServer, IdCustomHTTPServer, IdTCPServer,
  HTTPApp, SOAPHTTPPasInv, WSDLPub {$IFDEF INDY10}, IdContext {$ENDIF};

type
  TIdSoapHTTPServer = class(TIdHTTPServer)
  protected
    procedure DoCommandGet({$IFDEF INDY10}AContext: TIdContext{$ELSE}AThread:
  TIdPeerThread{$ENDIF};
  ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo); override;
  public
    constructor Create(aOwner: TComponent); override;
  end;

  TIdWebRequest = class(TWebRequest)
  private
    FIdHttpServer: TIdCustomHTTPServer;
    FIdRequest: TIdHTTPRequestInfo;
    FIdResponse: TIdHTTPResponseInfo;
    FPort: Integer;
    FReadClientIndex: Integer;
  protected
  { Abstract methods overridden }
    function GetStringVariable(Index: Integer): string; override;
    function GetIntegerVariable(Index: Integer): Integer; override;
    function GetDateVariable(Index: Integer): TDateTime; override;
  public
    constructor Create(IdHttpServer: TIdCustomHTTPServer; IdRequest:
  TIdHTTPRequestInfo; IdResponse: TIdHTTPResponseInfo);
    destructor Destroy; override;
  { Abstract methods overridden }
  // Read count bytes from client
    function ReadClient(var Buffer; Count: Integer): Integer; override;
  // Read count characters as a string from client
    function ReadString(Count: Integer): string; override;
  // Translate a relative URI to a local absolute path
    function TranslateURI(const URI: string): string; override;
  // Write count bytes back to client
    function WriteClient(var Buffer; Count: Integer): Integer; override;
  // Write string contents back to client
    function WriteString(const AString: string): Boolean; override;
  // Write HTTP header string
    function WriteHeaders(StatusCode: Integer; const ReasonString, Headers: string):
  Boolean; override;
    function GetFieldByName(const Name: string): string; override;
    property IdRequestInfo: TIdHTTPRequestInfo read FIdRequest;
  end;

  TIdWebResponse = class(TWebResponse)
  private
    FIdResponse: TIdHTTPResponseInfo;
    FSent: boolean;
  protected
  { Abstract methods overridden }
    function GetStringVariable(Index: Integer): string; override;
    procedure SetStringVariable(Index: Integer; const Value: string); override;
    function GetDateVariable(Index: Integer): TDateTime; override;
    procedure SetDateVariable(Index: Integer; const Value: TDateTime); override;
    function GetIntegerVariable(Index: Integer): Integer; override;
    procedure SetIntegerVariable(Index: Integer; Value: Integer); override;
    function GetContent: string; override;
    procedure SetContent(const Value: string); override;
    procedure SetContentStream(Value: TStream); override;
    function GetStatusCode: Integer; override;
    procedure SetStatusCode(Value: Integer); override;
    function GetLogMessage: string; override;
    procedure SetLogMessage(const Value: string); override;
  public
  { Abstract methods overridden }
    procedure SendResponse; override;
    procedure SendRedirect(const URI: string); override;
    procedure SendStream(AStream: TStream); override;
  public
    constructor Create(Request: TWebRequest; Response: TIdHTTPResponseInfo);
    destructor Destroy; override;
    function Sent: Boolean; override;
    procedure SetCookieField(Values: TStrings; const ADomain, APath: string;
  AExpires: TDateTime; ASecure: Boolean);
    property IdResponse: TIdHTTPResponseInfo read FIdResponse;
  end;

  TIdWebApplication = class;
  TIdWebModule = class(TCustomWebDispatcher, IWebRequestHandler)
  private
    fSOAPDispatcher: THTTPSoapDispatcher;
    fSOAPInvoker: THTTPSoapPascalInvoker;
    fWSDLPublish: TWSDLHTMLPublish;
    fWebApplication: TIdWebApplication;
  protected
    function HandleRequest(Request: TWebRequest; Response: TWebResponse): Boolean;
    procedure InitModule; virtual;
  public
    property WebApplication: TIdWebApplication read fWebApplication;
    property SOAPDispatcher: THTTPSoapDispatcher read fSOAPDispatcher;
    property SOAPInvoker: THTTPSoapPascalInvoker read fSOAPInvoker;
    property WSDLPublish: TWSDLHTMLPublish read fWSDLPublish;
    constructor Create(aOwner: TComponent); override;
  end;

  TIdWebApplication = class(TWebApplication)
  private
    FHTTPServer: TIdHTTPServer;
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Run; override;
    function HandleRequest(Request: TWebRequest; Response: TWebResponse): Boolean; //to be public
    property HTTPServer: TIdHTTPServer read FHTTPServer;
  end;

implementation

uses
  SysUtils, BrkrConst, IdHTTPHeaderInfo, IdHeaderList, Math, SOAPPasInv2;

{ TIdSoapHTTPServer }

constructor TIdSoapHTTPServer.Create(aOwner: TComponent);
begin
  inherited;
  FOkToProcessCommand:= True;
end;

procedure TIdSoapHTTPServer.DoCommandGet({$IFDEF INDY10}AContext:
  TIdContext{$ELSE}AThread: TIdPeerThread{$ENDIF}; ARequestInfo: TIdHTTPRequestInfo;
  AResponseInfo: TIdHTTPResponseInfo);
var
  Request: TIdWebRequest;
  Response: TIdWebResponse;
begin
  Request:= TIdWebRequest.Create(Self, ARequestInfo, aResponseInfo);
  try
    Response := TIdWebResponse.Create(Request, AResponseInfo);
    try
      TIdWebApplication(Owner).HandleRequest(Request, Response);
    finally
      Response.Free;
    end;
  finally
    Request.Free;
  end;
  inherited;
end;

{ TIdWebApplication }
constructor TIdWebApplication.Create(AOwner: TComponent);
begin
  inherited;
  FHTTPServer:= TIdSoapHTTPServer.Create(Self);
end;

destructor TIdWebApplication.Destroy;
begin

  inherited;
end;

procedure TIdWebApplication.Run;
begin
  inherited;
  fHTTPServer.Active:= True;
end;

function TIdWebApplication.HandleRequest(Request: TWebRequest; Response:
TWebResponse): Boolean;
begin
  Result:= inherited HandleRequest(Request, Response);
end;

{ TIdWebRequest }
constructor TIdWebRequest.Create(IdHttpServer: TIdCustomHTTPServer; IdRequest:
TIdHTTPRequestInfo; IdResponse: TIdHTTPResponseInfo);
begin
  FIdHttpServer:= IdHttpServer;
  FIdRequest := IdRequest;
  FIdResponse:= IdResponse;
  FPort:= IdHTTPServer.Bindings[0].Port; // IdHttpServer.DefaultPort;
  inherited Create;
end;

destructor TIdWebRequest.Destroy;
begin

  inherited;
end;

function StripHTTP(const Name: string): string;
begin
  if Pos('HTTP_', Name) = 1 then
    Result := Copy(Name, Length('HTTP_')+1, MaxInt)
  else
    Result := Name;
end;

function TIdWebRequest.GetFieldByName(const Name: string): string;
begin
  {$IF gsIdVersion = '8.0.25'} // D6, K2 compatible
  Result := FIdRequest.Headers.Values[StripHTTP(Name)];
  {$ELSE}
  Result := FIdRequest.RawHeaders.Values[StripHTTP(Name)];
  {$IFEND}
end;

const
  viMethod = 0;
  viProtocolVersion = 1;
  viURL = 2;
  viQuery = 3;
  viPathInfo = 4;
  viPathTranslated = 5;
  viCacheControl = 6;
  viDate = 7;
  viAccept = 8;
  viFrom = 9;
  viHost = 10;
  viIfModifiedSince = 11;
  viReferer = 12;
  viUserAgent = 13;
  viContentEncoding = 14;
  viContentType = 15;
  viContentLength = 16;
  viContentVersion = 17;
  viDerivedFrom = 18;
  viExpires = 19;
  viTitle = 20;
  viRemoteAddr = 21;
  viRemoteHost = 22;
  viScriptName = 23;
  viServerPort = 24;
  viContent = 25;
  viConnection = 26;
  viCookie = 27;
  viAuthorization = 28;
function TIdWebRequest.GetDateVariable(Index: Integer): TDateTime;
begin
  case Index of
    viDate: Result:= FIdRequest.Date;
    viIfModifiedSince: Result:= FIdRequest.LastModified;
    viExpires: Result:= FIdRequest.Expires;
  else
    Result:= 0;
  end;
end;

function TIdWebRequest.GetIntegerVariable(Index: Integer): Integer;
begin
  case Index of
    viContentLength: Result:= FIdRequest.ContentLength;
    viServerPort: Result:= fPort;
  else
    Result:= 0;
  end;
end;

function TIdWebRequest.GetStringVariable(Index: Integer): string;
  function HeaderValue(S: string): string;
  begin
    {$IF gsIdVersion = '8.0.25'} // D6, K2 compatible
    Result := FIdRequest.Headers.Values[S];
    {$ELSE}
    Result := FIdRequest.RawHeaders.Values[S];
    {$IFEND}
  end;
  function GetScriptName: string;
  var
    SlashPos: Integer;
  begin
    Result := FIdRequest.Document;
    if Length(Result) > 0 then
    begin
      Delete(Result, 1, 1); // delete the first /
      SlashPos := Pos('/', Result);
      if SlashPos <> 0 then
        Delete(Result, SlashPos, MaxInt); // delete everything after the next /
  // Add back in the starting slash
      Result := '/' + Result;
    end;
  end;
begin
  case Index of
    viMethod: Result := FIdRequest.Command; // ExtractFileName(FIdRequest.Command)
    viProtocolVersion: Result := FIdRequest.Version;
    viURL: Result := ''; // Not implemented
    viQuery:
      if FIdRequest.ContentLength > 0 then
        Result := FIdRequest.UnparsedParams
      else
        Result := '';
    viPathInfo: Result:= FIdRequest.Document;
    viPathTranslated: Result := FIdRequest.Document; // Not implemented
    viCacheControl: Result := FIdRequest.CacheControl;
    viAccept: Result := FIdRequest.Accept;
    viFrom: Result := FIdRequest.From;
    viHost: Result := FIdRequest.Host;
    viReferer: Result := FIdRequest.Referer;
    viUserAgent: Result := FIdRequest.UserAgent;
    viContentEncoding: Result := FIdRequest.ContentEncoding;
    viContentType: Result := FIdRequest.ContentType;
    viContentVersion: Result := FIdRequest.ContentVersion;
    viDerivedFrom: Result := ''; // Not implemented