david
2824855ea7
- Recompilación en Delphi10 de todos los paquetes de RO para generar las DCU's en Lib\D10 - Recompilación en Delphi10 de todos los paquetes de DA para generar las DCU's en Lib\D10 git-svn-id: https://192.168.0.254/svn/Componentes.Terceros.RemObjects@9 b6239004-a887-0f4b-9937-50029ccdca16
443 lines
13 KiB
ObjectPascal
443 lines
13 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
|
|
{$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
|
|
{$IFNDEF RemObjects_INDY8}IdCustomHTTPServer,{$ENDIF}
|
|
{$IFDEF RemObjects_INDY10}IdContext, IdSocketHandle,{$ELSE}IdThreadMgr,{$ENDIF}
|
|
Classes, uROServer, uROIndyTCPServer, IdTCPServer,
|
|
IdHTTPServer, uROClientIntf;
|
|
|
|
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 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;
|
|
function GetIndyServer: TROIdHTTPServer;
|
|
|
|
protected
|
|
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 OnGetRODLReader;
|
|
end;
|
|
|
|
implementation
|
|
|
|
uses SysUtils, IdGlobal, uRORes, uROHTTPTools, uROHTTPDispatch, uROServerIntf,
|
|
uROClient, uROHtmlServerInfo, uRODL;
|
|
|
|
{ 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).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);
|
|
var req, resp : TStringStream;
|
|
transport : IROHTTPTransport;
|
|
ok : boolean;
|
|
disp : TROHTTPDispatcher;
|
|
root, sub, reqdata : string;
|
|
lIgnore: TROResponseOptions;
|
|
format: TDataFormat;
|
|
info: IRONamedModuleInfo;
|
|
lRodl: TRODLLibrary;
|
|
begin
|
|
req := NIL;
|
|
transport := TIndyHTTPTransport.Create(RequestInfo, ResponseInfo);
|
|
|
|
resp := TStringStream.Create('');
|
|
|
|
try
|
|
{$IFDEF RemObjects_INDY8}
|
|
req := TStringStream.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.QueryParams=RequestInfo.UnparsedParams)
|
|
then reqdata := ''
|
|
else reqdata := RequestInfo.UnparsedParams;
|
|
|
|
req := TStringStream.Create(reqdata);
|
|
{$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
|
|
resp.WriteString('<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher);
|
|
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.Writestring(GetRodlCss);
|
|
ResponseInfo.ContentType := 'text/css';
|
|
ok := true;
|
|
end else
|
|
if sub = 'xslt' then
|
|
begin
|
|
resp.WriteString(GetRodlStyleSheet);
|
|
ResponseInfo.ContentType := 'text/xml';
|
|
ok := true;
|
|
end else if sub = '' then
|
|
begin
|
|
lRodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
ResponseInfo.ContentType := 'text/xml';
|
|
resp.WriteString(GetRodlWithStyleSheet(lRodl, '/doc/xslt'));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
resp.WriteString('<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher);
|
|
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.WriteString(GetRodlServerInfo('/', lRodl, Dispatchers));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
resp.WriteString('<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher);
|
|
ok := false;
|
|
end;
|
|
|
|
if ok or not fSendExceptionsAs500 then
|
|
ResponseInfo.ResponseNo := HTTP_OK
|
|
else
|
|
ResponseInfo.ResponseNo := HTTP_FAILED;
|
|
|
|
ResponseInfo.ContentText := resp.DataString;
|
|
finally
|
|
req.Free;
|
|
resp.Free;
|
|
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 := FALSE;
|
|
end;
|
|
|
|
procedure TROIndyHTTPServer.SetDisableNagle(const Value: boolean);
|
|
begin
|
|
// Not supported in the HTTP channels
|
|
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 := str_ProductName
|
|
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 := str_ProductName
|
|
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;
|
|
|
|
{ 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.
|