417 lines
12 KiB
ObjectPascal
417 lines
12 KiB
ObjectPascal
unit uROIPHttpServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ RemObjects SDK Library - Synapse 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}
|
|
|
|
interface
|
|
|
|
uses
|
|
Classes, uROServer, uROClientIntf, uIPAsyncSocket, uIPAsyncHttpServer, uIPHttpHeaders,
|
|
uROThreadPool, uROServerIntf, uRORes, uROClient, uROHtmlServerInfo, uRODL;
|
|
|
|
type
|
|
TROIpHttpServer = class(TROServer)
|
|
private
|
|
fServeRodl, fServeInfoPage: Boolean;
|
|
fSendExceptionsAs500: boolean;
|
|
fServer: TIPAsyncHttpServer;
|
|
fThreadPool: TROThreadPool;
|
|
fOwnsThreadPool: Boolean;
|
|
fOnManualBindSocket: TNotifyEvent;
|
|
procedure SetThreadPool(const Value: TROThreadPool);
|
|
protected
|
|
procedure IntSetActive(const Value: boolean); override;
|
|
function IntGetActive : boolean; override;
|
|
|
|
function GetDispatchersClass : TROMessageDispatchersClass; override;
|
|
|
|
|
|
function GetPort: Integer;
|
|
procedure SetPort(const Value: Integer);
|
|
procedure IntRequest(Sender: TObject; aContext: IIPAsyncContext);
|
|
public
|
|
constructor Create(aComponent: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
property Server: TIPAsyncHttpServer read fServer;
|
|
published
|
|
property Port:Integer read GetPort write SetPort;
|
|
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;
|
|
|
|
property ThreadPool: TROThreadPool read fThreadPool write SetThreadPool;
|
|
|
|
property OnManualBindSocket: TNotifyEvent read fOnManualBindSocket write fOnManualBindSocket;
|
|
end;
|
|
|
|
implementation
|
|
uses
|
|
uROHTTPTools, uROHTTPDispatch, TypInfo, SysUtils, uROIpTcpServer;
|
|
|
|
type
|
|
TROIpHttpWorker = class(TInterfacedObject, IROThreadPoolCallback, IROTransport, IROTCPTransport, IROHTTPTransport)
|
|
private
|
|
fOwner: TROIPHttpServer;
|
|
fContext: IIPAsyncContext;
|
|
fQueryData: TStringList;
|
|
function GetClientAddress: String;
|
|
function GetTransportObject: TObject;
|
|
function GetContentType: String;
|
|
function GetHeaders(const aName: String): String;
|
|
function GetLocation: String;
|
|
function GetPathInfo: String;
|
|
function GetQueryParameter(const aName: String): String;
|
|
function GetQueryString: String;
|
|
function GetTargetURL: String;
|
|
function GetUserAgent: String;
|
|
procedure SetContentType(const aValue: String);
|
|
procedure SetHeaders(const aName: String; const aValue: String);
|
|
procedure SetPathInfo(const aValue: String);
|
|
procedure SetTargetURL(const aValue: String);
|
|
procedure SetUserAgent(const aValue: String);
|
|
public
|
|
constructor Create(aOwner: TROIPHttpServer; aContext: IIPAsyncContext);
|
|
destructor Destroy; override;
|
|
procedure Callback(Caller: TROThreadPool; aThread: TThread);
|
|
end;
|
|
|
|
{ TROIPHttpServer }
|
|
|
|
constructor TROIPHttpServer.Create(aComponent: TComponent);
|
|
begin
|
|
inherited Create(aComponent);
|
|
|
|
fServer := TIPAsyncHttpServer.Create;
|
|
fServer.OnRequest := IntRequest;
|
|
fServer.Port := 8099;
|
|
fServeInfoPage := true;
|
|
fServeRodl := true;
|
|
end;
|
|
|
|
destructor TROIPHttpServer.Destroy;
|
|
begin
|
|
Active := false;
|
|
fServer.Free;
|
|
if fOwnsThreadPool then
|
|
fThreadPool.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROIPHttpServer.GetDispatchersClass: TROMessageDispatchersClass;
|
|
begin
|
|
Result := TROHTTPMessageDispatchers;
|
|
end;
|
|
|
|
function TROIPHttpServer.GetPort: Integer;
|
|
begin
|
|
result := fServer.Port;
|
|
end;
|
|
|
|
function TROIPHttpServer.IntGetActive: boolean;
|
|
begin
|
|
result := fServer.Active;
|
|
end;
|
|
|
|
procedure TROIPHttpServer.IntSetActive(const Value: boolean);
|
|
begin
|
|
inherited;
|
|
if Value = fserver.Active then exit;
|
|
if Value then begin
|
|
fServer.OnManualBind := fOnManualBindSocket;
|
|
if fThreadPool = nil then begin
|
|
fThreadPool := TROThreadPool.Create(nil);
|
|
fOwnsThreadPool := true;
|
|
end;
|
|
fServer.Active := true;
|
|
end else begin
|
|
fServer.Active := false;
|
|
|
|
end;
|
|
end;
|
|
|
|
procedure TROIPHttpServer.SetPort(const Value: Integer);
|
|
begin
|
|
fServer.Port := Value;
|
|
end;
|
|
|
|
procedure TROIPHttpServer.SetThreadPool(const Value: TROThreadPool);
|
|
begin
|
|
if fOwnsThreadPool then begin
|
|
FreeAndNil(fThreadPool);
|
|
end;
|
|
fOwnsThreadPool := false;
|
|
fThreadPool := Value;
|
|
end;
|
|
|
|
procedure TROIPHttpServer.IntRequest(Sender: TObject;
|
|
aContext: IIPAsyncContext);
|
|
begin
|
|
try
|
|
fThreadPool.QueueItem(TROIpHttpWorker.Create(self, aContext));
|
|
except
|
|
aContext.GetSelf.Disconnect;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TROIpHttpWorker }
|
|
|
|
procedure TROIpHttpWorker.Callback(Caller: TROThreadPool;
|
|
aThread: TThread);
|
|
var
|
|
Req: TByteArrayWrapper;
|
|
lRodl: TRODLLibrary;
|
|
root,
|
|
sub: string;
|
|
data: TDynamicByteArray;
|
|
disp: TROHTTPDispatcher;
|
|
ok: Boolean;
|
|
resp: TMemoryStream;
|
|
lIgnore: TROResponseOptions;
|
|
s: string;
|
|
info: IRONamedModuleInfo;
|
|
begin
|
|
req := TByteArrayWrapper.Create(TByteArray(fContext.RequestData));
|
|
resp := TMemoryStream.Create;
|
|
fcontext.Response.Headers.Values['Content-Type'] := fContext.Request.ContentType;
|
|
fcontext.Response.Code := 200;
|
|
fcontext.Response.Reason := 'OK';
|
|
|
|
try
|
|
root := fContext.Request.Path;
|
|
if Pos('?', Root) > 0 then Delete(Root, pos('/', root), MaxInt);
|
|
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(fOwner.Dispatchers).GetDispatcherByPath(root) as TROHTTPDispatcher;
|
|
|
|
if disp <> nil then
|
|
begin
|
|
if (req.Size = 0) then begin
|
|
ok := fOwner.fServeRodl;
|
|
if ok then
|
|
ok := fOwner.IntDispatchMessage(disp, self, req, resp, lIgnore)
|
|
else begin
|
|
s := '<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
|
|
SetContentType('text/html');
|
|
resp.Write(s[1], Length(s));
|
|
end;
|
|
end else if (sub = '') then
|
|
ok := fOwner.IntDispatchMessage(disp, self, req, resp, lIgnore)
|
|
else if (CompareText(sub, 'rodl') = 0) and fOwner.fServeRodl then
|
|
begin
|
|
if copy(disp.PathInfo, 1, 1) = '/' then SetPathInfo(disp.PathInfo) else SetPathInfo('/'+disp.PathInfo);
|
|
GetRodl(resp, self, s, fOwner.GetRODLReader);
|
|
SetContentType(s);
|
|
|
|
ok := true;
|
|
end else if Supports(disp.Message, IRONamedModuleInfo, info) and (CompareText(info.ModuleInfoName, sub) = 0) and fOwner.fServeRodl then
|
|
begin
|
|
if copy(disp.PathInfo, 1, 1) = '/' then SEtPathInfo(disp.PathInfo) else SetPathInfo('/'+disp.PathInfo);
|
|
info.GetModuleInfo(resp, self, s);
|
|
SetContentType(s);
|
|
ok := true;
|
|
end else
|
|
begin
|
|
ok := fOwner.IntDispatchMessage(disp, self, req, resp, lIgnore)
|
|
end;
|
|
end else if (CompareText(root, '/rodl') = 0) and (sub = '') and fOwner.fServeRodl then
|
|
begin
|
|
GetRodl(resp, self, s, fOwner.GetRODLReader);
|
|
SetContentType(s);
|
|
ok := true;
|
|
end else if fOwner.fServeInfoPage and (CompareText(root, '/doc') = 0) then
|
|
begin
|
|
if sub = 'css' then
|
|
begin
|
|
s := GetRodlCss;
|
|
resp.Write(s[1], Length(s));
|
|
SetContentType('text/css');
|
|
ok := true;
|
|
end else
|
|
if sub = 'xslt' then
|
|
begin
|
|
s := GetRodlStyleSheet;
|
|
resp.Write(s[1], Length(s));
|
|
SetContentType('text/xml');
|
|
ok := true;
|
|
end else if sub = '' then
|
|
begin
|
|
lRodl := GetRodlLibrary(fOwner.GetRODLReader);
|
|
try
|
|
SetContentType('text/xml');
|
|
s := GetRodlWithStyleSheet(lRodl, '/doc/xslt');
|
|
resp.Write(s[1], Length(s));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
s :='<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
|
|
resp.Write(s[1], Length(s));
|
|
ok := false;
|
|
end;
|
|
end else if fOwner.fServeInfoPage and (CompareStr(root, '/favicon.ico') = 0) then
|
|
begin
|
|
GetRodlFavIcon(resp);
|
|
SetContentType('image/x-icon');
|
|
ok := true;
|
|
end else if fOwner.fServeInfoPage and (root = '/') then
|
|
begin
|
|
lrodl := GetRodlLibrary(fOwner.GetRODLReader);
|
|
try
|
|
s := GetRodlServerInfo('/', lRodl, fOwner.Dispatchers);
|
|
resp.Write(s[1], Length(s));
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
ok := true;
|
|
end else
|
|
begin
|
|
s := '<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
|
|
resp.Write(s[1], Length(s));
|
|
ok := false;
|
|
end;
|
|
|
|
if not (ok or fOwner.fSendExceptionsAs500) then begin
|
|
fcontext.Response.Code := 500;
|
|
fcontext.Response.Reason := 'Internal Server Error';
|
|
end;
|
|
except
|
|
end;
|
|
req.Free;
|
|
try
|
|
SetLength(data, resp.Size);
|
|
resp.position := 0;
|
|
resp.Read(data[0], Length(data));
|
|
fContext.ResponseData := data;
|
|
fContext.SendResponse;
|
|
finally
|
|
resp.Free;
|
|
end;
|
|
end;
|
|
|
|
constructor TROIpHttpWorker.Create(aOwner: TROIPHttpServer;
|
|
aContext: IIPAsyncContext);
|
|
begin
|
|
inherited Create;
|
|
fOwner := aOwner;
|
|
fContext := aContext;
|
|
end;
|
|
|
|
destructor TROIpHttpWorker.Destroy;
|
|
begin
|
|
fQueryData.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetClientAddress: String;
|
|
begin
|
|
result := fContext.Request.ClientAddress;
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetContentType: String;
|
|
begin
|
|
result := fContext.Request.ContentType;
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetHeaders(const aName: String): String;
|
|
begin
|
|
result := fContext.Request.Headers.Values[aname];
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetLocation: String;
|
|
begin
|
|
Result := '';
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetPathInfo: String;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetQueryParameter(const aName: String): String;
|
|
begin
|
|
if fQueryData = nil then begin
|
|
fQueryData := TStringList.Create;
|
|
fQueryData.Delimiter := '&';
|
|
fQueryData.DelimitedText := GetQueryString;
|
|
end;
|
|
result := fqueryData.Values[aName];
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetQueryString: String;
|
|
begin
|
|
result := fContext.Request.Path;
|
|
if Pos('?', result) = 0 then result := '' else
|
|
result := Copy(Result, Pos('?', result)+1, MaxInt);
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetTargetURL: String;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetTransportObject: TObject;
|
|
begin
|
|
result := FOwner;
|
|
end;
|
|
|
|
function TROIpHttpWorker.GetUserAgent: String;
|
|
begin
|
|
Result := fContext.Request.Headers.Values['User-Agent'];
|
|
end;
|
|
|
|
procedure TROIpHttpWorker.SetContentType(const aValue: String);
|
|
begin
|
|
fContext.Response.Headers.Values['Content-Type'] := aValue;
|
|
end;
|
|
|
|
procedure TROIpHttpWorker.SetHeaders(const aName, aValue: String);
|
|
begin
|
|
fContext.Response.Headers.Values[aName] := aValue;
|
|
end;
|
|
|
|
procedure TROIpHttpWorker.SetPathInfo(const aValue: String);
|
|
begin
|
|
end;
|
|
|
|
procedure TROIpHttpWorker.SetTargetURL(const aValue: String);
|
|
begin
|
|
|
|
end;
|
|
|
|
procedure TROIpHttpWorker.SetUserAgent(const aValue: String);
|
|
begin
|
|
fContext.Response.Headers.Values['User-Agent'] := aValue;
|
|
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROIPHTTPServer);
|
|
finalization
|
|
UnregisterServerClass(TROIPHTTPServer);
|
|
end.
|