david
e4d0fcb01d
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@46 b6239004-a887-0f4b-9937-50029ccdca16
493 lines
16 KiB
ObjectPascal
493 lines
16 KiB
ObjectPascal
unit uROWebBrokerServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Core Library }
|
|
{ }
|
|
{ compiler: Delphi 5 and up, Kylix 2 and up }
|
|
{ platform: Win32, Linux }
|
|
{ }
|
|
{ (c)opyright RemObjects Software. all rights reserved. }
|
|
{ }
|
|
{ Using this code requires a valid license of the RemObjects SDK }
|
|
{ which can be obtained at http://www.remobjects.com. }
|
|
{----------------------------------------------------------------------------}
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, HTTPApp, uROClientIntf, uROServer, uROHTTPTools;
|
|
|
|
type
|
|
{ TROWebBrokerServer }
|
|
TROWebBrokerServer = class(TROServer, IROTransport, IROTCPTransport, IROHTTPTransport)
|
|
private
|
|
fUserBeforeDispatch : THTTPMethodEvent;
|
|
fActions : TWebActionItems;
|
|
|
|
fActive : boolean;
|
|
fTransportIntf : IROHTTPTransport;
|
|
|
|
fRequest : TWebRequest;
|
|
fResponse : TWebResponse;
|
|
fSendExceptionsAs500: boolean;
|
|
fOverridePathInfo : string;
|
|
fServeInfoPage: Boolean;
|
|
fServeRodl: Boolean;
|
|
|
|
|
|
fOnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod;
|
|
fSendClientAccessPolicyXml: TROClientAccessPolicyType;
|
|
|
|
function ReadRequestStream(aRequest : TWebRequest): TStream;
|
|
function GetRequest: TWebRequest;
|
|
function GetResponse: TWebResponse;
|
|
function IsWebModuleAction(const aPathInfo: ansistring) : boolean;
|
|
|
|
protected
|
|
procedure ReplaceBeforeDispatch(aOwner : TComponent; aNewHandler : THTTPMethodEvent); virtual;
|
|
|
|
function GetDispatchersClass : TROMessageDispatchersClass; override;
|
|
|
|
procedure Loaded; override;
|
|
procedure IntSetActive(const Value: boolean); override;
|
|
function IntGetActive : boolean; override;
|
|
|
|
{ IROTransport }
|
|
function GetTransportObject : TObject;
|
|
|
|
{ IROTCPTransport }
|
|
function GetClientAddress : string;
|
|
|
|
{ IROHTTPTransport }
|
|
procedure SetHeaders(const aName, aValue : string);
|
|
function GetHeaders(const aName : string) : string;
|
|
function GetContentType : string;
|
|
procedure SetContentType(const aValue : string);
|
|
function GetUserAgent : string;
|
|
procedure SetUserAgent(const aValue : string);
|
|
function GetTargetURL : string;
|
|
procedure SetTargetURL(const aValue : string);
|
|
function GetPathInfo : string;
|
|
procedure SetPathInfo (const aValue : string);
|
|
function GetLocation : string;
|
|
function GetQueryString : string;
|
|
function GetQueryParameter(const aName: String): String;
|
|
public
|
|
constructor Create(aOwner : TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
property Request : TWebRequest read GetRequest;
|
|
property Response : TWebResponse read GetResponse;
|
|
|
|
published
|
|
procedure IntOnBeforeDispatch(Sender: TObject;
|
|
Request: TWebRequest;
|
|
Response: TWebResponse; var Handled: Boolean); virtual;
|
|
property SendExceptionsAs500: boolean read fSendExceptionsAs500 write fSendExceptionsAs500 default true;
|
|
property ServeInfoPage : Boolean read fServeInfoPage write fServeInfoPage default true;
|
|
property ServeRodl : Boolean read fServeRodl write fServeRodl default true;
|
|
property OnGetRODLReader;
|
|
property OnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod read fOnGetCustomClientAccessPolicy write fOnGetCustomClientAccessPolicy;
|
|
property SendClientAccessPolicyXml: TROClientAccessPolicyType read fSendClientAccessPolicyXml write fSendClientAccessPolicyXml default captAllowNone;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses TypInfo, uRORes, SysUtils, {$IFDEF DELPHI2009UP}AnsiStrings,{$ENDIF}uROHTTPDispatch, uROServerIntf,
|
|
uROClient, uROHtmlServerInfo, uRODL, uROClasses;
|
|
|
|
type
|
|
// See TROWebBrokerServer.Loaded This is for EWF support.
|
|
IInterfaceComponentReference = interface
|
|
['{E28B1858-EC86-4559-8FCD-6B4F824151ED}']
|
|
function GetComponent: TComponent;
|
|
end;
|
|
|
|
{ TROWebBrokerServer }
|
|
|
|
constructor TROWebBrokerServer.Create(aOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
|
|
fActive := TRUE;
|
|
fActions := NIL;
|
|
fServeInfoPage := true;
|
|
fServeRodl := true;
|
|
fSendExceptionsAs500 := true;
|
|
Supports(Self, IROTransport, fTransportIntf);
|
|
end;
|
|
|
|
destructor TROWebBrokerServer.Destroy;
|
|
begin
|
|
fTransportIntf := NIL;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.Loaded;
|
|
var dispatchactions : IUnknown;
|
|
icref : IInterfaceComponentReference;
|
|
begin
|
|
inherited;
|
|
|
|
if not (csDesigning in ComponentState) then begin
|
|
ReplaceBeforeDispatch(Owner, IntOnBeforeDispatch);
|
|
|
|
if Owner is TWebModule
|
|
then fActions := TWebActionItems(GetObjectProp(Owner, 'Actions'))
|
|
else try
|
|
{ This is for EWF. I don't want to set a dependency to the EWF units.
|
|
This component has to stay WebBroker and EWF neutral since, in the end, we are
|
|
dealing with web broker actions. This solves the problem. }
|
|
|
|
{$IFDEF DELPHI6UP}
|
|
if IsPublishedProp(Owner, 'DispatchActions')
|
|
then dispatchactions := GetInterfaceProp(Owner, 'DispatchActions')
|
|
else Exit;
|
|
{$ENDIF DELPHI6UP}
|
|
|
|
if (dispatchactions<>NIL) then begin
|
|
if Supports(dispatchactions, IInterfaceComponentReference, icref) then begin
|
|
fActions := TWebActionItems(GetObjectProp(icref.GetComponent, 'Actions'));
|
|
end;
|
|
end;
|
|
except
|
|
//ToDo: do we really want to catch this exception and display a DIAOG??
|
|
on E:Exception do begin
|
|
//showmessage(e.message);
|
|
fActions := NIL;
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROWebBrokerServer.IntGetActive: boolean;
|
|
begin
|
|
result := fActive;
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.IntSetActive(const Value: boolean);
|
|
begin
|
|
fActive := Value;
|
|
end;
|
|
|
|
function TROWebBrokerServer.ReadRequestStream(aRequest : TWebRequest): TStream;
|
|
var s : ansistring;
|
|
t : ansistring;
|
|
i : integer;
|
|
begin
|
|
s := {$IFDEF DELPHI2009UP}aRequest.RawContent{$ELSE}aRequest.Content{$ENDIF};
|
|
i := aRequest.ContentLength-Length(s);
|
|
|
|
while (i>0) do begin
|
|
t := aRequest.ReadString(I);
|
|
s := S+T;
|
|
i := i-Length(t);
|
|
end;
|
|
|
|
result := TROBinaryMemoryStream.Create(s);
|
|
end;
|
|
|
|
function TROWebBrokerServer.IsWebModuleAction(const aPathInfo: ansistring) : boolean;
|
|
var
|
|
i : integer;
|
|
lpathinfo : string;
|
|
begin
|
|
result := FALSE;
|
|
if (fActions=NIL) then Exit;
|
|
lpathinfo := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(aPathInfo);
|
|
for i := 0 to (fActions.Count-1) do
|
|
if (CompareText(fActions[i].PathInfo, lPathInfo)=0) then begin
|
|
result := TRUE;
|
|
Exit;
|
|
end;
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.IntOnBeforeDispatch(Sender: TObject;
|
|
Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);
|
|
|
|
procedure WriteError(responsestream : TROBinaryMemoryStream);
|
|
begin
|
|
responsestream.WriteAnsiString('<font size="7">500 Invalid Path</font><br />'+{$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(err_CannotFindMessageDispatcher));
|
|
end;
|
|
|
|
var requeststream : TStream;
|
|
responsestream : TROBinaryMemoryStream;
|
|
root: ansistring;
|
|
sub : string;
|
|
disp: TROHTTPDispatcher;
|
|
lIgnore: TROResponseOptions;
|
|
format: TDataFormat;
|
|
info: IRONamedModuleInfo;
|
|
ok : boolean;
|
|
lRodl: TRODLLibrary;
|
|
lPolicyContent: AnsiString;
|
|
begin
|
|
requeststream := NIL;
|
|
responsestream := NIL;
|
|
|
|
fRequest := Request;
|
|
fResponse := Response;
|
|
ok := false;
|
|
// Executes the user's event handler
|
|
if Assigned(fUserBeforeDispatch)
|
|
then fUserBeforeDispatch(Sender, Request, Response, Handled);
|
|
|
|
// Processes the message if not handled already
|
|
root := request.PathInfo;
|
|
if not Handled and not IsWebModuleAction(root) then begin
|
|
try
|
|
responsestream := TROBinaryMemoryStream.Create;
|
|
requeststream := ReadRequestStream(Request);
|
|
|
|
if (root <> '') and (root[1] = '/') then delete(root, 1,1);
|
|
if pos(AnsiChar('/'), root) > 0 then
|
|
begin
|
|
sub :={$IFDEF UNICODE}AnsiStringToWideString{$ENDIF} (copy(root, pos(AnsiChar('/'), root)+1, maxint));
|
|
root := '/' + copy(root, 1, pos(AnsiChar('/'), root) - 1);
|
|
end else
|
|
begin
|
|
root := '/' + root;
|
|
sub := '';
|
|
end;
|
|
|
|
disp := TROHTTPMessageDispatchers(Dispatchers).GetDispatcherByPath({$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(root)) as TROHTTPDispatcher;
|
|
|
|
if disp <> nil then
|
|
begin
|
|
if (requeststream.Size = 0) then begin
|
|
ok := fServeRodl;
|
|
if ok then
|
|
ok := IntDispatchMessage(disp, fTransportIntf, requeststream, responsestream, lIgnore)
|
|
else
|
|
WriteError(responsestream);
|
|
end else if (sub = '') then
|
|
ok := IntDispatchMessage(disp, fTransportIntf, requeststream, responsestream, lIgnore)
|
|
else if (CompareText(sub, 'rodl') = 0) and fServeRodl then
|
|
begin
|
|
if copy(disp.PathInfo, 1, 1) = '/' then fTransportIntf.PathInfo := disp.PathInfo else fTransportIntf.PathInfo := '/'+disp.PathInfo;
|
|
GetRodl(responsestream, fTransportIntf, format, GetRODLReader);
|
|
ok := true;
|
|
end else if Supports(disp.Message, IRONamedModuleInfo, info) and
|
|
(CompareText(info.ModuleInfoName, sub) = 0) and fServeRodl then
|
|
begin
|
|
if copy(disp.PathInfo, 1, 1) = '/' then fTransportIntf.PathInfo := disp.PathInfo else fTransportIntf.PathInfo := '/'+disp.PathInfo;
|
|
info.GetModuleInfo(responsestream, fTransportIntf, format);
|
|
ok := true;
|
|
end else
|
|
begin
|
|
ok := IntDispatchMessage(disp, fTransportIntf, requeststream, responsestream, lIgnore)
|
|
end;
|
|
end else if (CompareText(root, AnsiString('/rodl')) = 0) and (sub = '') and fServeRodl then
|
|
begin
|
|
GetRodl(responsestream, fTransportIntf, format, GetRODLReader);
|
|
ok := true;
|
|
end else if fServeInfoPage and (CompareText(root, AnsiString('/doc')) = 0) then
|
|
begin
|
|
if sub = 'css' then
|
|
begin
|
|
responsestream.WriteAnsistring(GetRodlCss);
|
|
Response.ContentType := 'text/css';
|
|
ok := true;
|
|
end else
|
|
if sub = 'xslt' then
|
|
begin
|
|
responsestream.WriteAnsiString(GetRodlStyleSheet);
|
|
Response.ContentType := 'text/xml';
|
|
ok := true;
|
|
end else if sub = '' then
|
|
begin
|
|
lRodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
Response.ContentType := 'text/xml';
|
|
responsestream.WriteAnsiString(GetRodlWithStyleSheet(lRodl, {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.ScriptName) + '/doc/xslt'));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
WriteError(responsestream);
|
|
ok := false;
|
|
end;
|
|
end else if fServeInfoPage and (CompareStr(root, AnsiString('/favicon.ico')) = 0) then
|
|
begin
|
|
GetRodlFavIcon(responsestream);
|
|
Response.ContentType := 'image/x-icon';
|
|
ok := true;
|
|
end else if fServeInfoPage and (root = '/') then
|
|
begin
|
|
lrodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
responsestream.WriteAnsiString(GetRodlServerInfo({$IFDEF UNICODE}UTF8ToString{$ENDIF}(fRequest.ScriptName), lRodl, Dispatchers));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
if CompareText(root, AnsiString('/clientaccesspolicy.xml')) = 0 then begin
|
|
case fSendClientAccessPolicyXml of
|
|
captAllowAll: begin
|
|
lPolicyContent := GetClientAccessPolicy;
|
|
end;
|
|
captCustom: begin
|
|
if Assigned(fOnGetCustomClientAccessPolicy) then
|
|
fOnGetCustomClientAccessPolicy(Self, lPolicyContent);
|
|
end;
|
|
end;
|
|
if lPolicyContent <> '' then begin
|
|
Response.ContentType := 'text/xml';
|
|
responsestream.WriteAnsiString(lPolicyContent);
|
|
end;
|
|
end else
|
|
begin
|
|
WriteError(responsestream);
|
|
ok := false;
|
|
end;
|
|
|
|
if ok or not fSendExceptionsAs500 then
|
|
Response.StatusCode := HTTP_OK
|
|
else
|
|
Response.StatusCode := HTTP_FAILED;
|
|
|
|
finally
|
|
requeststream.Free;
|
|
Handled := TRUE;
|
|
|
|
responsestream.Position := 0;
|
|
Response.ContentStream := responsestream;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetRequest: TWebRequest;
|
|
begin
|
|
result := fRequest;
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetResponse: TWebResponse;
|
|
begin
|
|
result := fResponse;
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetClientAddress: string;
|
|
begin
|
|
result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.RemoteAddr);
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetContentType: string;
|
|
begin
|
|
result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Response.ContentType)
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetHeaders(const aName: string): string;
|
|
begin
|
|
Result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Request.GetFieldByName({$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(aName)));
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetTargetURL: string;
|
|
begin
|
|
result := ''
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetTransportObject: TObject;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetUserAgent: string;
|
|
begin
|
|
result := str_ProductName
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.SetContentType(const aValue: string);
|
|
begin
|
|
Response.ContentType :={$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(aValue);
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.SetHeaders(const aName, aValue: string);
|
|
begin
|
|
SetHeaderValue(Response.CustomHeaders, aName, aValue);
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.SetPathInfo(const aValue: string);
|
|
begin
|
|
fOverridePathInfo := aValue;
|
|
// ignore?
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.SetTargetURL(const aValue: string);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.SetUserAgent(const aValue: string);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TROWebBrokerServer.ReplaceBeforeDispatch(aOwner: TComponent;
|
|
aNewHandler: THTTPMethodEvent);
|
|
// Do not change the sequance of these names. It's important for EWF.
|
|
const EventHandlerNames : array[0..1] of string = ('OnBeforeDispatch', 'BeforeDispatch');
|
|
var pinfo : PPropInfo;
|
|
i : integer;
|
|
myevent : THTTPMethodEvent;
|
|
mtd,
|
|
mtd2 : TMethod;
|
|
s : string;
|
|
begin
|
|
for i := 0 to High(EventHandlerNames) do begin
|
|
s := EventHandlerNames[i];
|
|
pinfo := GetPropInfo(Owner, s);
|
|
|
|
if (pinfo<>NIL) then begin
|
|
myevent := IntOnBeforeDispatch;
|
|
mtd := TMethod(myevent); // <--- I have to pass through a local variable. Cannot type caet directly... Go figure!
|
|
|
|
mtd2 := GetMethodProp(Owner, pinfo);
|
|
SetMethodProp(Owner, pinfo, mtd);
|
|
|
|
TMethod(fUserBeforeDispatch) := mtd2;
|
|
Exit;
|
|
end;
|
|
end;
|
|
//TWebModule(aOwner).BeforeDispatch := aNewHandler;
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetPathInfo: string;
|
|
begin
|
|
if fOverridePathInfo <> '' then
|
|
result := fOverridePathInfo
|
|
else
|
|
result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Request.PathInfo)
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetDispatchersClass: TROMessageDispatchersClass;
|
|
begin
|
|
result := TROHTTPMessageDispatchers;
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetLocation: string;
|
|
begin
|
|
result := 'http://'+{$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.Host+fRequest.URL);
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetQueryString: string;
|
|
begin
|
|
result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.Query);
|
|
end;
|
|
|
|
function TROWebBrokerServer.GetQueryParameter(const aName: String): String;
|
|
begin
|
|
result := fRequest.QueryFields.Values[aName];
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROWebBrokerServer);
|
|
finalization
|
|
UnregisterServerClass(TROWebBrokerServer);
|
|
end.
|