475 lines
15 KiB
ObjectPascal
475 lines
15 KiB
ObjectPascal
unit uROBPDXHTTPServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ 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, uROServer, uROClientIntf, uROBPDXTCPServer,
|
|
{$IFDEF RemObjects_USE_RODX}
|
|
uRODXString, uRODXServerCore, uRODXSock, uRODXHTTPServerCore, uRODXHTTPHeaderTools;
|
|
{$ELSE}
|
|
DXString, DXServerCore, DXSock, DXHTTPServerCore, DXHTTPHeaderTools;
|
|
{$ENDIF}
|
|
|
|
type
|
|
{ TROBPDXHTTPTransport }
|
|
TROBPDXHTTPTransport = class(TInterfacedObject, IROTransport, IROTCPTransport, IROHTTPTransport)
|
|
private
|
|
fResponseHeaders : TStringList;
|
|
|
|
fClientThread: TDXClientThread;
|
|
fHeaderInfo: PHeaderInfo;
|
|
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;
|
|
function GetLocation : string;
|
|
function GetQueryString : string;
|
|
procedure SetPathInfo(const aValue: String);
|
|
|
|
{ IROTransport }
|
|
function GetTransportObject : TObject;
|
|
function GetClientAddress : string;
|
|
public
|
|
constructor Create(aClientThread: TDXClientThread; aHeaderInfo: PHeaderInfo);
|
|
destructor Destroy; override;
|
|
|
|
property ClientThread: TDXClientThread read fClientThread;
|
|
property HeaderInfo: PHeaderInfo read fHeaderInfo;
|
|
end;
|
|
|
|
{ TROBPDXHTTPServer }
|
|
TROBPDXHTTPServer = class(TROBPDXTCPServer)
|
|
private
|
|
fServeInfoPage, fServeRodl: Boolean;
|
|
fSendExceptionsAs500: boolean;
|
|
function GetBPDXServer: TDXHTTPServerCore;
|
|
function GetSupportKeepAlive: Boolean;
|
|
procedure SetSupportKeepAlive(const Value: Boolean);
|
|
|
|
protected
|
|
function CreateBPDXServer : TDXServerCore; override;
|
|
|
|
function BuildResponseHeader(StatusCode:Integer;var EnableKeepAlive : Boolean) : string;
|
|
procedure CleanupNetscapeAndProxyRequests(HeaderInfo:PHeaderInfo);
|
|
|
|
procedure InternalOnNewConnect(ClientThread:TDXClientThread);
|
|
procedure InternalHandleSession(ClientThread: TDXClientThread; HeaderInfo: PHeaderInfo; var EnableKeepAlive: boolean);
|
|
|
|
function GetDispatchersClass : TROMessageDispatchersClass; override;
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
|
|
published
|
|
property BPDXServer: TDXHTTPServerCore read GetBPDXServer;
|
|
property SupportKeepAlive: Boolean read GetSupportKeepAlive write SetSupportKeepAlive;
|
|
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, uRORes, uROHTTPDispatch, uROHTTPTools, uROClient, uROServerIntf,
|
|
uROHtmlServerInfo, uRODL;
|
|
|
|
constructor TROBPDXHTTPTransport.Create(aClientThread: TDXClientThread; aHeaderInfo: PHeaderInfo);
|
|
begin
|
|
inherited Create;
|
|
fResponseHeaders := TStringList.Create;
|
|
fClientThread := aClientThread;
|
|
fHeaderInfo := aHeaderInfo;
|
|
end;
|
|
|
|
destructor TROBPDXHTTPTransport.Destroy;
|
|
begin
|
|
fResponseHeaders.Free;
|
|
|
|
inherited;
|
|
end;
|
|
|
|
procedure TROBPDXHTTPTransport.SetHeaders(const aName, aValue : string);
|
|
begin
|
|
SetHeaderValue(fResponseHeaders, aName, aValue);
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetHeaders(const aName : string) : string;
|
|
var
|
|
s: string;
|
|
lPos: Integer;
|
|
begin
|
|
lPos := Pos(#13#10+aName+'=', fHeaderInfo.Unknown);
|
|
if lPos = 0 then begin
|
|
result := '';
|
|
exit;
|
|
end;
|
|
s := Copy(fHeaderInfo.Unknown, lPos + 2, MaxInt);
|
|
s := copy(s,1,pos(#13#10, s)-1);
|
|
s := copy(s,pos('=', s)+1, MaxInt);
|
|
result := s;
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetContentType : string;
|
|
begin
|
|
result := fHeaderInfo.ContentType
|
|
end;
|
|
|
|
procedure TROBPDXHTTPTransport.SetContentType(const aValue : string);
|
|
begin
|
|
SetHeaders(id_ContentType, aValue);
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetUserAgent : string;
|
|
begin
|
|
result := fHeaderInfo.UserAgent
|
|
end;
|
|
|
|
procedure TROBPDXHTTPTransport.SetUserAgent(const aValue : string);
|
|
begin
|
|
SetHeaders(id_UserAgent, aValue);
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetTargetURL : string;
|
|
begin
|
|
result := ''
|
|
end;
|
|
|
|
procedure TROBPDXHTTPTransport.SetTargetURL(const aValue : string);
|
|
begin
|
|
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetTransportObject : TObject;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetClientAddress : string;
|
|
begin
|
|
result := fClientThread.Socket.PeerIPAddress;
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetPathInfo : string;
|
|
begin
|
|
if fOverriddenPathInfo <> '' then
|
|
result := fOverriddenPathInfo
|
|
else begin
|
|
result := StringReplace(fHeaderInfo^.URI, 'http://', '', []);
|
|
result := Copy(result, Pos('/', result), MaxInt);
|
|
end;
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetLocation : string;
|
|
begin
|
|
result := 'http://'+fHeaderInfo^.Host
|
|
end;
|
|
|
|
{ TROBPDXHTTPServer }
|
|
function TROBPDXHTTPServer.GetBPDXServer: TDXHTTPServerCore;
|
|
begin
|
|
result := TDXHTTPServerCore(inherited BPDXServer);
|
|
end;
|
|
|
|
function TROBPDXHTTPServer.CreateBPDXServer: TDXServerCore;
|
|
begin
|
|
//DXSock.TDXXferTimeout := 100;
|
|
result := TDXHTTPServerCore.Create(Self);
|
|
|
|
with TDXHTTPServerCore(result) do begin
|
|
ServerPort := 8099;
|
|
BindTo := ''; // blank = ALL IP's!
|
|
Timeout := 50000; // 50 seconds for initial header
|
|
ThreadCacheSize := 10;
|
|
SocketOutputBufferSize := bsfHuge;
|
|
|
|
// Optimized settings
|
|
{$IFNDEF LINUX}
|
|
ListenerThreadPriority := tpIdle;
|
|
SpawnedThreadPriority := tpIdle;
|
|
{$ENDIF LINUX}
|
|
SocketOutputBufferSize := bsfNormal;
|
|
UseThreadPool := FALSE;
|
|
SupportKeepAlive := FALSE;
|
|
|
|
OnNewConnect := InternalOnNewConnect;
|
|
OnCommandGET := InternalHandleSession;
|
|
OnCommandPOST := InternalHandleSession;
|
|
OnCommandHEAD := InternalHandleSession;
|
|
end;
|
|
end;
|
|
|
|
function TROBPDXHTTPServer.BuildResponseHeader(StatusCode:Integer;var EnableKeepAlive : Boolean) : string;
|
|
begin
|
|
Result := 'HTTP/1.1 '+BPDXServer.HeaderText(StatusCode)+#13#10+
|
|
'Server: RemObjects DXSock Web Server v1.0'+#13#10+
|
|
'Date: '+{DXString.}DateTimeToGMTRFC822(Now)+#13#10+
|
|
'MIME-Version: 1.0'+#13#10+
|
|
'Public: GET,POST,HEAD,TRACE'+#13#10+
|
|
'Accept-Ranges: none'+#13#10;
|
|
if StatusCode<>200 then begin
|
|
Result := Result+
|
|
'Pragma: no-cache'+#13#10+
|
|
'Cache-Control: no-cache'+#13#10;
|
|
EnableKeepAlive := False;
|
|
end;
|
|
if EnableKeepAlive then begin
|
|
Result := Result+'Connection: Keep-Alive'+#13#10+
|
|
'Keep-Alive: timeout='+IntToStr((BPDXServer.Timeout div 1000))+#13#10;
|
|
End
|
|
else begin
|
|
Result := Result+'Connection: close'+#13#10;
|
|
end;
|
|
end;
|
|
|
|
Procedure TROBPDXHTTPServer.CleanupNetscapeAndProxyRequests(HeaderInfo:PHeaderInfo);
|
|
Var
|
|
Ws:String;
|
|
begin
|
|
if (QuickPos('://',HeaderInfo^.Raw)>0) and (QuickPos('://',HeaderInfo^.Raw)<10) then begin
|
|
Ws := Copy(HeaderInfo^.RAW,1,CharPos(#32,HeaderInfo^.RAW));
|
|
Delete(HeaderInfo^.RAW,1,QuickPos('://',HeaderInfo^.RAW)+2);
|
|
if CharPos('/',HeaderInfo^.RAW)=0 then HeaderInfo^.RAW := '/ HTTP/1.1'
|
|
else Delete(HeaderInfo^.RAW,1,CharPos('/',HeaderInfo^.RAW)-1);
|
|
HeaderInfo^.RAW := Ws+HeaderInfo^.RAW;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBPDXHTTPServer.InternalOnNewConnect(ClientThread:TDXClientThread);
|
|
begin
|
|
// ClientThread.Socket.SetNagle(False);
|
|
BPDXServer.ProcessSession(ClientThread); // tell server to handle connection
|
|
end;
|
|
|
|
procedure TROBPDXHTTPServer.InternalHandleSession(ClientThread: TDXClientThread; HeaderInfo: PHeaderInfo; var EnableKeepAlive: boolean);
|
|
Var
|
|
StatusCode:Integer; // you set this!
|
|
req : TStringStream;
|
|
resp:TMemoryStream; // you set this!
|
|
transport : IROHTTPTransport;
|
|
HeaderStr:String;
|
|
disp : TROHTTPDispatcher;
|
|
s, root, sub : string;
|
|
lIgnore: TROResponseOptions;
|
|
format: TDataFormat;
|
|
info: IRONamedModuleInfo;
|
|
lRodl: TRodlLibrary;
|
|
ok: Boolean;
|
|
begin
|
|
req := NIL;
|
|
resp := NIL;
|
|
|
|
// if POST then collect the post data!
|
|
if HeaderInfo^.Method='POST' then begin // collect post data!
|
|
if HeaderInfo^.ContentLength=0 then begin // HACKER!!
|
|
ClientThread.Socket.Writeln(BuildResponseHeader(411,EnableKeepAlive));
|
|
Exit;
|
|
end;
|
|
|
|
while Length(HeaderInfo^.PostData)<HeaderInfo^.ContentLength do begin
|
|
HeaderInfo^.PostData := HeaderInfo^.PostData+
|
|
ClientThread.Socket.ReadStr(HeaderInfo^.ContentLength-Length(HeaderInfo^.PostData));
|
|
if ClientThread.Socket.DroppedConnection then begin // connection aborted!
|
|
EnableKeepAlive := False;
|
|
Exit;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
// now we handle the request!
|
|
CleanupNetscapeAndProxyRequests(HeaderInfo);
|
|
if HeaderInfo^.URI='' then HeaderInfo^.URI := '/'; // fix old Netscape!
|
|
|
|
try
|
|
req := TStringStream.Create(HeaderInfo^.PostData);
|
|
resp := TMemoryStream.Create;
|
|
transport := TROBPDXHTTPTransport.Create(ClientThread, HeaderInfo);
|
|
|
|
{ make sure you set the:
|
|
StatusCode to the result you want to send!
|
|
resp - is the page body, xml, html, etc.
|
|
MimeType - is the Content-Type: <value_only> e.g. text/html }
|
|
|
|
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 begin
|
|
s := '<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
|
|
resp.Write(s[1], length(s));
|
|
end;
|
|
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);
|
|
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);
|
|
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
|
|
s := GetRodlCss;
|
|
resp.Write(s[1], length(s));
|
|
transport.ContentType := 'text/css';
|
|
ok := true;
|
|
end else
|
|
if sub = 'xslt' then
|
|
begin
|
|
s := GetRodlStyleSheet;
|
|
resp.Write(s[1], length(s));
|
|
transport.ContentType := 'text/xml';
|
|
ok := true;
|
|
end else if sub = '' then
|
|
begin
|
|
lRodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
s := GetRodlWithStyleSheet(lRodl, '/doc/xslt');
|
|
resp.Write(s[1], length(s));
|
|
transport.ContentType := 'text/xml';
|
|
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 fServeInfoPage and (CompareStr(root, '/favicon.ico') = 0) then
|
|
begin
|
|
GetRodlFavIcon(resp);
|
|
transport.ContentType := 'image/x-icon';
|
|
ok := true;
|
|
end else if fServeInfoPage and (root = '/') then
|
|
begin
|
|
lrodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
s := GetRodlServerInfo(transport.PathInfo, lRodl, 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 ok or (not fSendExceptionsAs500) then
|
|
StatusCode:= HTTP_OK
|
|
else
|
|
StatusCode := HTTP_FAILED;
|
|
|
|
HeaderStr := BuildResponseHeader(StatusCode,EnableKeepAlive)+
|
|
id_UserAgent+': '+str_ProductName+#13#10+
|
|
id_ContentLength+': '+IntToStr(resp.Size)+#13#10+
|
|
id_ContentType+': '+transport.Headers[id_ContentType]+#13#10;
|
|
|
|
ClientThread.Socket.Writeln(HeaderStr);
|
|
|
|
if (HeaderInfo^.Method<>'HEAD') and (resp.Size>0) then begin
|
|
{$IFDEF VER100}
|
|
ClientThread.Socket.BlockWrite(resp.Memory,resp.Size);
|
|
{$ELSE}
|
|
ClientThread.Socket.Write(resp.Memory,resp.Size);
|
|
{$ENDIF}
|
|
end;
|
|
finally
|
|
req.Free;
|
|
resp.Free;
|
|
end;
|
|
end;
|
|
|
|
function TROBPDXHTTPServer.GetDispatchersClass : TROMessageDispatchersClass;
|
|
begin
|
|
result := TROHTTPMessageDispatchers
|
|
end;
|
|
|
|
|
|
function TROBPDXHTTPServer.GetSupportKeepAlive: Boolean;
|
|
begin
|
|
Result := BPDXServer.SupportKeepAlive;
|
|
end;
|
|
|
|
procedure TROBPDXHTTPServer.SetSupportKeepAlive(const Value: Boolean);
|
|
begin
|
|
BPDXServer.SupportKeepAlive := Value;
|
|
end;
|
|
|
|
function TROBPDXHTTPTransport.GetQueryString: string;
|
|
begin
|
|
result := fHeaderInfo^.QueryString
|
|
end;
|
|
|
|
constructor TROBPDXHTTPServer.Create(aOwner: TComponent);
|
|
begin
|
|
inherited;
|
|
fServeInfoPage := true;
|
|
fServeRodl := true;
|
|
fSendExceptionsAs500 := true;
|
|
end;
|
|
|
|
procedure TROBPDXHTTPTransport.SetPathInfo(const aValue: String);
|
|
begin
|
|
fOverriddenPathInfo := aValue;
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROBPDXHTTPServer);
|
|
finalization
|
|
UnregisterServerClass(TROBPDXHTTPServer);
|
|
end.
|