david
e4d0fcb01d
git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@46 b6239004-a887-0f4b-9937-50029ccdca16
517 lines
16 KiB
ObjectPascal
517 lines
16 KiB
ObjectPascal
unit uROIndyHTTPServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Indy Components }
|
|
{ }
|
|
{ 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}
|
|
|
|
{TODO: Do like in the webmodule. Save a pointer to the user's OnCOmmandGet and fire it }
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFNDEF RemObjects_INDY8}IdCustomHTTPServer,{$ENDIF}
|
|
{$IFDEF RemObjects_INDY10}IdContext, {IdSocketHandle,}{$ELSE}IdThreadMgr,{$ENDIF}
|
|
Classes, uROServer, uROIndyTCPServer, {IdTCPServer,}
|
|
IdHTTPServer, uROClientIntf, idTCPServer, uROHTTPTools;
|
|
|
|
type
|
|
{ TIndyHTTPTransport }
|
|
TIndyHTTPTransport = class(TInterfacedObject, IROTransport, IROTCPTransport, IROHTTPTransport)
|
|
private
|
|
fRequestInfo: TIdHTTPRequestInfo;
|
|
fResponseInfo : TIdHTTPResponseInfo;
|
|
fOverriddenPathInfo : string;
|
|
protected
|
|
{ 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 GetQueryString : string;
|
|
function GetQueryParameter(const aName: String): String;
|
|
|
|
function GetLocation : string;
|
|
|
|
{ IROTransport }
|
|
function GetTransportObject : TObject;
|
|
function GetClientAddress : string;
|
|
|
|
public
|
|
constructor Create(aRequestInfo: TIdHTTPRequestInfo; aResponseInfo : TIdHTTPResponseInfo);
|
|
|
|
property RequestInfo: TIdHTTPRequestInfo read fRequestInfo;
|
|
property ResponseInfo : TIdHTTPResponseInfo read fResponseInfo;
|
|
end;
|
|
|
|
{ TROIdHTTPServer }
|
|
TROIdHTTPServer = class(TIdHTTPServer)
|
|
private
|
|
function GetActive: boolean;
|
|
|
|
public
|
|
procedure IndySetActive(Value : boolean);
|
|
|
|
published
|
|
property Active : boolean read GetActive;
|
|
end;
|
|
|
|
{ TROIndyHTTPServer }
|
|
TROIndyHTTPServer = class(TROCustomIndyTCPServer)
|
|
private
|
|
fServeRodl, fServeInfoPage: Boolean;
|
|
fSendExceptionsAs500: boolean;
|
|
fDisableNagle: Boolean;
|
|
fOnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod;
|
|
fSendClientAccessPolicyXml: TROClientAccessPolicyType;
|
|
function GetIndyServer: TROIdHTTPServer;
|
|
|
|
protected
|
|
procedure InternalServerConnect(AThread: {$IFDEF RemObjects_INDY10}TIdContext{$ELSE}TIdPeerThread{$ENDIF}); virtual;
|
|
procedure InternalServerCommandGet(AThread: TIdThreadClass;
|
|
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); virtual;
|
|
|
|
|
|
function CreateIndyServer : TComponent; override;
|
|
procedure IntSetActive(const Value: boolean); override;
|
|
function IntGetActive : boolean; override;
|
|
|
|
function GetDispatchersClass : TROMessageDispatchersClass; override;
|
|
|
|
function GetKeepAlive: boolean; override;
|
|
procedure SetKeepAlive(const Value: boolean); override;
|
|
|
|
function GetDisableNagle: boolean; override;
|
|
procedure SetDisableNagle(const Value: boolean); override;
|
|
|
|
public
|
|
constructor Create(aComponent: TComponent); override;
|
|
|
|
published
|
|
property IndyServer : TROIdHTTPServer read GetIndyServer;
|
|
property Port:Integer read GetPort write SetPort;
|
|
property KeepAlive : boolean read GetKeepAlive write SetKeepAlive default false;
|
|
property ServeInfoPage : Boolean read fServeInfoPage write fServeInfoPage default true;
|
|
property ServeRodl : Boolean read fServeRodl write fServeRodl default true;
|
|
property SendExceptionsAs500: boolean read fSendExceptionsAs500 write fSendExceptionsAs500 default true;
|
|
property DisableNagle;
|
|
property OnGetRODLReader;
|
|
property OnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod read fOnGetCustomClientAccessPolicy write fOnGetCustomClientAccessPolicy;
|
|
property SendClientAccessPolicyXml: TROClientAccessPolicyType read fSendClientAccessPolicyXml write fSendClientAccessPolicyXml default captAllowNone;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses SysUtils, IdGlobal, uRORes, uROHTTPDispatch, uROServerIntf,
|
|
uROClient, uROHtmlServerInfo, uRODL, idstackconsts, uROClasses;
|
|
|
|
{ TROIndyHTTPServer }
|
|
constructor TROIndyHTTPServer.Create(aComponent: TComponent);
|
|
begin
|
|
inherited;
|
|
fServeRodl := true;
|
|
fServeInfoPage := true;
|
|
fSendExceptionsAs500 := true;
|
|
end;
|
|
|
|
function TROIndyHTTPServer.CreateIndyServer: TComponent;
|
|
begin
|
|
result := TROIdHTTPServer.Create(Self);//TIdHTTPServer.Create(Self);
|
|
TROIdHTTPServer(result).OnCommandGet := InternalServerCommandGet;
|
|
TROIdHTTPServer(result).OnConnect := InternalServerConnect;
|
|
TROIdHTTPServer(result).DefaultPort := 8099;
|
|
end;
|
|
|
|
function TROIndyHTTPServer.IntGetActive: boolean;
|
|
begin
|
|
result := GetIndyServer.Active
|
|
end;
|
|
|
|
procedure TROIndyHTTPServer.IntSetActive(const Value: boolean);
|
|
begin
|
|
{$IFDEF RemObjects_INDY10B}
|
|
if (Value) and (IndyServer.Bindings.Count = 0) then begin
|
|
with IndyServer.Bindings.Add do begin
|
|
Ip := '';
|
|
Port := Self.Port;
|
|
IPVersion := Id_IPv4;
|
|
end;
|
|
end;
|
|
{$ENDIF}
|
|
GetIndyServer.IndySetActive(Value);
|
|
if not Value
|
|
then IndyServer.Bindings.Clear;
|
|
end;
|
|
|
|
function TROIndyHTTPServer.GetIndyServer: TROIdHTTPServer;
|
|
begin
|
|
//result := TROIdHTTPServer(inherited IndyServer);
|
|
result := TObject(inherited IndyServer) as TROIdHTTPServer;
|
|
end;
|
|
|
|
procedure TROIndyHTTPServer.InternalServerCommandGet(AThread: TIdThreadClass;
|
|
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
|
|
|
|
procedure WriteError(resp : TROBinaryMemoryStream);
|
|
begin
|
|
resp.WriteAnsiString('<font size="7">500 Invalid Path</font><br />'+{$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(err_CannotFindMessageDispatcher));
|
|
end;
|
|
|
|
var req : TStream;
|
|
resp : TROBinaryMemoryStream;
|
|
transport : IROHTTPTransport;
|
|
ok : boolean;
|
|
disp : TROHTTPDispatcher;
|
|
root, sub: string;
|
|
{$IFNDEF RemObjects_INDY8}reqdata : string;{$ENDIF}
|
|
lIgnore: TROResponseOptions;
|
|
format: TDataFormat;
|
|
info: IRONamedModuleInfo;
|
|
lRodl: TRODLLibrary;
|
|
lPolicyContent: AnsiString;
|
|
begin
|
|
if AThread = nil then req := nil else // for preventing warning in FPC
|
|
req := NIL;
|
|
format := '';
|
|
transport := TIndyHTTPTransport.Create(RequestInfo, ResponseInfo);
|
|
|
|
resp := TROBinaryMemoryStream.Create;
|
|
ok := false;
|
|
try
|
|
{$IFDEF RemObjects_INDY8}
|
|
req := TROBinaryMemoryStream.Create(RequestInfo.UnparsedParams);
|
|
{$ELSE}
|
|
{ This was introduced to support URLs with parameters for partial WSDLs.
|
|
When a browser sends a URL such as "http://localhost:8099/SOAP?Service=TestService", Indy
|
|
puts the value "Service=TestService" in the UnparsedParams. This is not what we want as we
|
|
expect UnparsedParams as the data of the HTTP request. }
|
|
if RequestInfo.PostStream <> nil then begin
|
|
req := RequestInfo.PostStream;
|
|
end
|
|
else begin
|
|
if Length(RequestInfo.FormParams) = 0 then begin
|
|
if (RequestInfo.QueryParams=RequestInfo.UnparsedParams) then
|
|
reqdata := ''
|
|
else
|
|
reqdata := RequestInfo.UnparsedParams;
|
|
end else begin
|
|
reqdata := RequestInfo.FormParams;
|
|
end;
|
|
req := TROBinaryMemoryStream.Create({$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(reqdata));
|
|
end;
|
|
{$ENDIF}
|
|
|
|
root := transport.PathInfo;
|
|
if (root <> '') and (root[1] = '/') then delete(root, 1,1);
|
|
if pos('/', root) > 0 then
|
|
begin
|
|
sub := copy(root, pos('/', root)+1, maxint);
|
|
root := '/' + copy(root, 1, pos('/', root) - 1);
|
|
end else
|
|
begin
|
|
root := '/' + root;
|
|
sub := '';
|
|
end;
|
|
|
|
disp := TROHTTPMessageDispatchers(Dispatchers).GetDispatcherByPath(root) as TROHTTPDispatcher;
|
|
|
|
if disp <> nil then
|
|
begin
|
|
if (req.Size = 0) then begin
|
|
ok := fServeRodl;
|
|
if ok then
|
|
ok := IntDispatchMessage(disp, transport, req, resp, lIgnore)
|
|
else
|
|
WriteError(resp);
|
|
end else if (sub = '') then
|
|
ok := IntDispatchMessage(disp, transport, req, resp, lIgnore)
|
|
else if (CompareText(sub, 'rodl') = 0) and fServeRodl then
|
|
begin
|
|
if copy(disp.PathInfo, 1, 1) = '/' then transport.PathInfo := disp.PathInfo else transport.PathInfo := '/'+disp.PathInfo;
|
|
GetRodl(resp, transport, format, GetRODLReader);
|
|
ResponseInfo.ContentType := format;
|
|
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 transport.PathInfo := disp.PathInfo else transport.PathInfo := '/'+disp.PathInfo;
|
|
info.GetModuleInfo(resp, transport, format);
|
|
ResponseInfo.ContentType := format;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
ok := IntDispatchMessage(disp, transport, req, resp, lIgnore)
|
|
end;
|
|
end else if (CompareText(root, '/rodl') = 0) and (sub = '') and fServeRodl then
|
|
begin
|
|
GetRodl(resp, transport, format, GetRODLReader);
|
|
ok := true;
|
|
end else if fServeInfoPage and (CompareText(root, '/doc') = 0) then
|
|
begin
|
|
if sub = 'css' then
|
|
begin
|
|
resp.WriteAnsiString(GetRodlCss);
|
|
ResponseInfo.ContentType := 'text/css';
|
|
ok := true;
|
|
end else
|
|
if sub = 'xslt' then
|
|
begin
|
|
resp.WriteAnsiString(GetRodlStyleSheet);
|
|
ResponseInfo.ContentType := 'text/xml';
|
|
ok := true;
|
|
end else
|
|
if sub = '' then
|
|
begin
|
|
lRodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
ResponseInfo.ContentType := 'text/xml';
|
|
resp.WriteAnsiString(GetRodlWithStyleSheet(lRodl, '/doc/xslt'));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
WriteError(resp);
|
|
ok := false;
|
|
end;
|
|
end else if fServeInfoPage and (CompareStr(root, '/favicon.ico') = 0) then
|
|
begin
|
|
GetRodlFavIcon(resp);
|
|
ResponseInfo.ContentType := 'image/x-icon';
|
|
ok := true;
|
|
end else if fServeInfoPage and (root = '/') then
|
|
begin
|
|
lrodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
resp.WriteAnsiString(GetRodlServerInfo('/', lRodl, Dispatchers));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
if CompareText(root, '/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
|
|
ResponseInfo.ContentType := 'text/xml';
|
|
resp.WriteAnsiString(lPolicyContent);
|
|
end;
|
|
end else
|
|
begin
|
|
WriteError(resp);
|
|
ok := false;
|
|
end;
|
|
|
|
if ok or not fSendExceptionsAs500 then
|
|
ResponseInfo.ResponseNo := HTTP_OK
|
|
else
|
|
ResponseInfo.ResponseNo := HTTP_FAILED;
|
|
|
|
resp.Position:=0;
|
|
ResponseInfo.ContentStream := resp;
|
|
finally
|
|
{$IFDEF RemObjects_INDY8}
|
|
req.Free;
|
|
{$ELSE}
|
|
if req <> RequestInfo.PostStream then req.Free;
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
|
|
function TROIndyHTTPServer.GetDispatchersClass : TROMessageDispatchersClass;
|
|
begin
|
|
result := TROHTTPMessageDispatchers
|
|
end;
|
|
|
|
function TROIndyHTTPServer.GetKeepAlive: Boolean;
|
|
begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
Result := false;
|
|
{$ELSE}
|
|
Result := IndyServer.KeepAlive;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TROIndyHTTPServer.SetKeepAlive(const Value: Boolean);
|
|
begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
// keepalive not supported on Indy 8
|
|
{$ELSE}
|
|
IndyServer.KeepAlive := Value;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TROIndyHTTPServer.GetDisableNagle: boolean;
|
|
begin
|
|
result := fDisableNagle;
|
|
end;
|
|
|
|
procedure TROIndyHTTPServer.SetDisableNagle(const Value: boolean);
|
|
begin
|
|
fDisableNagle := true;
|
|
end;
|
|
|
|
procedure TROIndyHTTPServer.InternalServerConnect(AThread: {$IFDEF RemObjects_INDY10}TIdContext{$ELSE}TIdPeerThread{$ENDIF});
|
|
begin
|
|
|
|
|
|
if DisableNagle then begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
AThread.Connection.Binding.SetSockOpt(Id_IPPROTO_TCP, Id_TCP_NODELAY, PChar(@Id_SO_True), SizeOf(Id_SO_True));
|
|
{$ELSE}
|
|
{$IFDEF RemObjects_INDY9}
|
|
AThread.Connection.Socket.Binding.SetSockOpt(Id_IPPROTO_TCP, Id_TCP_NODELAY, PChar(@Id_SO_True), SizeOf(Id_SO_True));
|
|
{$ELSE}
|
|
AThread.Connection.Socket.Binding.SetSockOpt(Id_IPPROTO_TCP, Id_TCP_NODELAY, Id_SO_True);
|
|
{$ENDIF}
|
|
{$ENDIF}
|
|
end;
|
|
end;
|
|
|
|
{ TIndyHTTPTransport }
|
|
|
|
constructor TIndyHTTPTransport.Create(
|
|
aRequestInfo: TIdHTTPRequestInfo; aResponseInfo: TIdHTTPResponseInfo);
|
|
begin
|
|
inherited Create;
|
|
fRequestInfo := aRequestInfo;
|
|
fResponseInfo := aResponseInfo;
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetClientAddress: string;
|
|
begin
|
|
result := fRequestInfo.RemoteIP;
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetContentType: string;
|
|
begin
|
|
result := fResponseInfo.ContentType;
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetHeaders(const aName: string): string;
|
|
begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
result := GetHeaderValue(fRequestInfo.Headers, aName);
|
|
{$ELSE}
|
|
result := GetHeaderValue(fRequestInfo.RawHeaders, aName);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetPathInfo: string;
|
|
begin
|
|
if fOverriddenPathInfo <> '' then
|
|
result := fOverriddenPathInfo
|
|
else
|
|
result := RequestInfo.Document
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetLocation: string;
|
|
begin
|
|
result := 'http://'+fRequestInfo.Host
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetTargetURL: string;
|
|
begin
|
|
result := ''
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetTransportObject: TObject;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetUserAgent: string;
|
|
begin
|
|
result := fResponseInfo.ServerSoftware;
|
|
end;
|
|
|
|
procedure TIndyHTTPTransport.SetContentType(const aValue: string);
|
|
begin
|
|
fResponseInfo.ContentType := aValue
|
|
end;
|
|
|
|
procedure TIndyHTTPTransport.SetHeaders(const aName,
|
|
aValue: string);
|
|
begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
SetHeaderValue(fResponseInfo.Headers, aName, aValue);
|
|
{$ELSE}
|
|
SetHeaderValue(fResponseInfo.RawHeaders, aName, aValue);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TIndyHTTPTransport.SetTargetURL(const aValue: string);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TIndyHTTPTransport.SetUserAgent(const aValue: string);
|
|
begin
|
|
fResponseInfo.ServerSoftware := aValue;
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetQueryString: string;
|
|
begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
result := '';
|
|
{$ELSE}
|
|
result := fRequestInfo.QueryParams;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TIndyHTTPTransport.SetPathInfo(const aValue: String);
|
|
begin
|
|
fOverriddenPathInfo := aValue;
|
|
end;
|
|
|
|
function TIndyHTTPTransport.GetQueryParameter(const aName: String): String;
|
|
begin
|
|
{$IFDEF RemObjects_INDY8}
|
|
result := '';
|
|
{$ELSE}
|
|
result := fRequestInfo.Params.Values[aName];
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{ TROIdHTTPServer }
|
|
|
|
function TROIdHTTPServer.GetActive: boolean;
|
|
begin
|
|
result := inherited Active
|
|
end;
|
|
|
|
procedure TROIdHTTPServer.IndySetActive(Value: boolean);
|
|
begin
|
|
inherited Active := Value
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROIndyHTTPServer);
|
|
finalization
|
|
UnregisterServerClass(TROIndyHTTPServer);
|
|
end.
|