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
1147 lines
35 KiB
ObjectPascal
1147 lines
35 KiB
ObjectPascal
unit uROBaseSuperHttpServer;
|
|
|
|
interface
|
|
|
|
{$I RemObjects.inc}
|
|
|
|
uses
|
|
SysUtils, Classes, uROClientIntf, uROServer, uROServerIntf, uROClasses,
|
|
uIPHttpHeaders, uROThreadPool, uROThread, uROClient, uROEventRepository,
|
|
uROHtmlServerInfo, uRODL, uROHTTPDispatch, uROTypes, uROSessions;
|
|
|
|
type
|
|
TROSuperHttpWaitingConnection = class(TObject)
|
|
private
|
|
fChannel: IUnknown;
|
|
fTimeout: TDateTime;
|
|
public
|
|
constructor Create(aChannel: IUnknown);
|
|
property Timeout: TDateTime read fTimeout;
|
|
property Channel: IUnknown read fChannel;
|
|
end;
|
|
TROBaseSuperHttpServer = class;
|
|
TROSuperHttpServerConnection = class;
|
|
IROSuperHttpServerConnection = interface
|
|
['{48AF124A-38F5-43A4-BD82-684A74EDF77F}']
|
|
function GetSelf: TROSuperHttpServerConnection;
|
|
function GetGuid: TGuid;
|
|
function GuidMatches(const aGuid: TGuid): Boolean;
|
|
|
|
procedure DisposeData;
|
|
end;
|
|
TROSuperHttpServerConnection = class(TInterfacedObject, IROSuperHttpServerConnection, IROActiveEventServer)
|
|
private
|
|
fServer: TROBaseSuperHttpServer;
|
|
fLastTalk: TDateTime;
|
|
fRemoteMaxPackageLength: Integer;
|
|
fConnectionId: TGuid;
|
|
fSessionId: TGuid;
|
|
fResponseQueue: TInterfaceList;
|
|
fWaitingConnections: TThreadList;
|
|
fEventId: Integer;
|
|
protected
|
|
function GetSelf: TROSuperHttpServerConnection;
|
|
public
|
|
constructor Create(aServer: TROBaseSuperHttpServer);
|
|
destructor Destroy; override;
|
|
|
|
procedure DisposeData;
|
|
|
|
function GetGuid: TGuid;
|
|
function GuidMatches(const aGuid: TGuid): Boolean;
|
|
|
|
property Server: TROBaseSuperHttpServer read fServer;
|
|
property LastTalk: TDateTime read fLastTalk write fLastTalk;
|
|
property ResponseQueue: TInterfaceList read fResponseQueue;
|
|
property WaitingConnections: TThreadList read fWaitingConnections;
|
|
property RemoteMaxPackageLength: Integer read fRemoteMaxPackageLength write fRemoteMaxPackageLength;
|
|
property ConnectionId: TGuid read fConnectionId write fConnectionId;
|
|
property SessionId: TGUID read fSessionId write fSessionId;
|
|
procedure EventsRegistered(aSender: TObject; aClient: TGUID);
|
|
procedure DispatchEvent(anEventDataItem: TROEventData;
|
|
aSessionReference: TGUID; aSender: TObject);
|
|
end;
|
|
|
|
TROSuperHttpServerResponse = class;
|
|
IROSuperHttpServerResponse = interface
|
|
['{9C33C4C2-F6AA-452C-9E67-F49F75F292F2}']
|
|
function GetSelf: TROSuperHttpServerResponse;
|
|
end;
|
|
TROSuperHttpServerResponse = class(TInterfacedObject, IROSuperHttpServerResponse)
|
|
private
|
|
fHeaders: TIPHttpResponseHeaders;
|
|
fData: TDynamicByteArray;
|
|
fConnection: IROSuperHttpServerConnection;
|
|
fAttempt: Integer;
|
|
function GetSelf: TROSuperHttpServerResponse;
|
|
public
|
|
constructor Create(aConn: IROSuperHttpServerConnection; aHeaders: TIPHttpResponseHeaders);
|
|
destructor Destroy; override;
|
|
|
|
property Headers: TIPHttpResponseHeaders read fHeaders;
|
|
property Data: TDynamicByteArray read fData write fData;
|
|
property Connection: IROSuperHttpServerConnection read fConnection write fConnection;
|
|
property Attempt: Integer read fAttempt write fAttempt;
|
|
end;
|
|
TROBaseSuperHttpServer = class(TROServer)
|
|
private
|
|
fTimer: TROThreadTimer;
|
|
fThreadPool: TROThreadPool;
|
|
fOwnsThreadPool: boolean;
|
|
fMaxPackageSize: Integer;
|
|
fConnections: TInterfaceList;
|
|
fServeRodl,
|
|
fServeInfoPage: Boolean;
|
|
fActive: Boolean;
|
|
fEventRepository: TROEventRepository;
|
|
fConnectionTimeout: Integer;
|
|
|
|
function GetConnection(const aGuid: TGuid): IROSuperHttpServerConnection;
|
|
procedure KillConnection(aConnection: IROSuperHttpServerConnection);
|
|
procedure SendError(aTarget: IUnknown; anError: string);
|
|
procedure IncomingData(aTarget: IUnknown; aRequestHeaders: TIPHttpRequestHeaders; aData: TDynamicByteArray; aDispatcher: TROMessageDispatcher);
|
|
procedure SendRodl(ATarget: IUnknown; aRequest: TIPHttpRequestHeaders; aDispatcher: TROMessageDispatcher; const aTargetService: string);
|
|
procedure AddWaitingRequest(aTarget: IUnknown; aConnection: IROSuperHttpServerConnection);
|
|
procedure ProcessPackage(aTarget: IROSuperHttpServerConnection; aHeaders: TIPHttpRequestHeaders; aMessageDispatcher: TROMessageDispatcher; aId: Integer; aData: TDynamicByteArray);
|
|
procedure SendAsyncResponse(aTarget: IROSuperHttpServerConnection; lHeaders: TIPHttpResponseHeaders; aData: TDynamicByteArray);
|
|
procedure SetThreadPool(const Value: TROThreadPool);
|
|
procedure cbCleanup(CurrentTickCount : Cardinal);
|
|
protected
|
|
|
|
procedure CloseConnection(aConnection: IUnknown); virtual; abstract;
|
|
procedure SendResponse(aTarget: IUnknown; aHeaders: TIPHttpResponseHeaders; aData: TDynamicByteArray; UserData: IInterface); virtual; abstract;
|
|
function HandleUnknownRequest(aTarget: IUnknown; arequest: TIPHttpRequestHeaders; aData: TDynamicByteArray): Boolean; virtual; abstract;
|
|
procedure SetDefaultHeaders(aTarget: IUnknown; aHeaders: TIPHttpResponseHeaders); virtual; abstract;
|
|
|
|
procedure HandleRequest(aTarget: IUnknown; aRequestHeaders: TIPHttpRequestHeaders; aRequest: TDynamicByteArray);
|
|
procedure ResponseFailed(aUserData: IInterface);
|
|
procedure ResponseSucessful(aUserData: IInterface);
|
|
|
|
procedure DoActivate; virtual;
|
|
procedure DoDeactivate; virtual;
|
|
|
|
function IntGetActive: Boolean; override;
|
|
procedure IntSetActive(const Value: Boolean); override;
|
|
function GetDispatchersClass : TROMessageDispatchersClass; override;
|
|
public
|
|
constructor Create(aOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
published
|
|
property ServeRodl: Boolean read fServeRodl write fServeRodl default true;
|
|
property ServeInfoPage: Boolean read fServeInfoPage write fServeInfoPage default true;
|
|
|
|
property MaxPackageSize: Integer read fMaxPackageSize write fMaxPackageSize default 1 * 1024 * 1024;
|
|
property ConnectionTimeout: Integer read fConnectionTimeout write fConnectionTimeout default 5 * 60;
|
|
property ThreadPool: TROThreadPool read fThreadPool write SetThreadPool;
|
|
property EventRepository: TROEventRepository read fEventRepository write fEventRepository;
|
|
end;
|
|
|
|
const
|
|
ShHello = 0;
|
|
ShGoodbye = 1;
|
|
ShPackage = 2;
|
|
ShError = 3;
|
|
ShError_InvalidClientId = 0;
|
|
ShError_QueueFull = 1;
|
|
ShError_UnknownOption = 2;
|
|
ShOptions = 4;
|
|
ShAsyncWait = 5;
|
|
|
|
|
|
implementation
|
|
|
|
{ TROSuperHttpWaitingConnection }
|
|
|
|
constructor TROSuperHttpWaitingConnection.Create(aChannel: IUnknown);
|
|
begin
|
|
fChannel := aChannel;
|
|
end;
|
|
|
|
{ TROSuperHttpServerResponse }
|
|
|
|
constructor TROSuperHttpServerResponse.Create(aConn: IROSuperHttpServerConnection; aHeaders: TIPHttpResponseHeaders);
|
|
begin
|
|
inherited Create;
|
|
fHeaders := aHeaders;
|
|
if fHeaders = nil then fhEaders := TIPHttpResponseHeaders.Create;
|
|
fConnection := aConn;
|
|
end;
|
|
|
|
destructor TROSuperHttpServerResponse.Destroy;
|
|
begin
|
|
fHeaders.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROSuperHttpServerResponse.GetSelf: TROSuperHttpServerResponse;
|
|
begin
|
|
result := Self;
|
|
end;
|
|
|
|
{ TROSuperHttpServerConnection }
|
|
|
|
procedure TROSuperHttpServerConnection.DisposeData;
|
|
var
|
|
i: Integer;
|
|
lConn: TROSuperHttpWaitingConnection;
|
|
lList: TList;
|
|
begin
|
|
FreeAndNil(fResponseQueue);
|
|
lList := fWaitingConnections.LockList;
|
|
for i := 0 to lList.Count -1 do
|
|
begin
|
|
lConn := TROSuperHttpWaitingConnection(lList[i]);
|
|
fServer.CloseConnection(lConn.Channel);
|
|
lConn.Free;
|
|
end;
|
|
fWaitingConnections.UnlockList;
|
|
FreeAndNil(fWaitingConnections);
|
|
end;
|
|
|
|
constructor TROSuperHttpServerConnection.Create(
|
|
aServer: TROBaseSuperHttpServer);
|
|
begin
|
|
fServer := aServer;
|
|
fResponseQueue := TInterfaceList.Create;
|
|
fWaitingConnections := TThreadList.Create;
|
|
end;
|
|
|
|
destructor TROSuperHttpServerConnection.Destroy;
|
|
begin
|
|
fResponseQueue.Free;
|
|
fWaitingConnections.Free;
|
|
inherited;
|
|
end;
|
|
|
|
function TROSuperHttpServerConnection.GetSelf: TROSuperHttpServerConnection;
|
|
begin
|
|
result := self;
|
|
end;
|
|
|
|
procedure TROSuperHttpServerConnection.DispatchEvent(
|
|
anEventDataItem: TROEventData; aSessionReference: TGUID; aSender: TObject);
|
|
var
|
|
lId: Integer;
|
|
lData: TDynamicByteArray;
|
|
begin
|
|
fResponseQueue.Lock;
|
|
fEventId := fEventId - 1;
|
|
if fEventId > 0 then fEventId := -1;
|
|
lId := fEventId;
|
|
fResponseQueue.Unlock;
|
|
|
|
SetLength(lData, anEventDataItem.Data.size + 5);
|
|
lData[0] := ShPackage;
|
|
lData[1] := lId;
|
|
lData[2] := lId shr 8;
|
|
lData[3] := lId shr 16;
|
|
lData[4] := lId shr 24;
|
|
anEventDataItem.Data.Seek(0, soFromBeginning);
|
|
anEventDataItem.Data.Read(lData[5], Length(lData) -5);
|
|
fServer.SendAsyncResponse(self, nil, lData);
|
|
end;
|
|
|
|
function TROSuperHttpServerConnection.GetGuid: TGuid;
|
|
begin
|
|
result := fConnectionId;
|
|
end;
|
|
|
|
function TROSuperHttpServerConnection.GuidMatches(
|
|
const aGuid: TGuid): Boolean;
|
|
begin
|
|
result := (fConnectionId.D1 = aGuid.D1) and
|
|
(fConnectionId.D2 = aGuid.D2) and
|
|
(fConnectionId.D3 = aGuid.D3) and
|
|
(fConnectionId.D4[0] = aGuid.D4[0]) and
|
|
(fConnectionId.D4[1] = aGuid.D4[1]) and
|
|
(fConnectionId.D4[2] = aGuid.D4[2]) and
|
|
(fConnectionId.D4[3] = aGuid.D4[3]) and
|
|
(fConnectionId.D4[4] = aGuid.D4[4]) and
|
|
(fConnectionId.D4[5] = aGuid.D4[5]) and
|
|
(fConnectionId.D4[6] = aGuid.D4[6]) and
|
|
(fConnectionId.D4[7] = aGuid.D4[7]);
|
|
end;
|
|
|
|
procedure TROSuperHttpServerConnection.EventsRegistered(aSender: TObject;
|
|
aClient: TGUID);
|
|
begin
|
|
// do nothing.
|
|
end;
|
|
|
|
{ TROBaseSuperHttpServer }
|
|
|
|
procedure TROBaseSuperHttpServer.AddWaitingRequest(aTarget: IUnknown;
|
|
aConnection: IROSuperHttpServerConnection);
|
|
var
|
|
lRealConnection: TROSuperHttpServerConnection;
|
|
lResp: IROSuperHttpServerResponse;
|
|
begin
|
|
lRealConnection := aConnection.GetSelf;
|
|
lRealConnection.ResponseQueue.Lock;
|
|
try
|
|
if lRealConnection.ResponseQueue.Count > 0 then begin
|
|
lResp := IROSuperHttpServerResponse(lRealConnection.ResponseQueue[0]);
|
|
lRealConnection.ResponseQueue.Delete(0);
|
|
|
|
Sendresponse(aTarget, lResp.GetSelf.Headers, lResp.GetSelf.Data, lResp);
|
|
exit;
|
|
end;
|
|
finally
|
|
lRealConnection.ResponseQueue.Unlock;
|
|
end;
|
|
lRealConnection.WaitingConnections.Add(TROSuperHttpWaitingConnection.Create(aTarget));
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.cbCleanup(CurrentTickCount: Cardinal);
|
|
var
|
|
lTimeoutTime, lConnTimeout: TDateTime;
|
|
i: Integer;
|
|
lList: TList;
|
|
lConn: IROSuperHttpServerConnection;
|
|
begin
|
|
lTimeoutTime := Now - (90 * (1.0 / (24 * 60 * 60)));
|
|
lConnTimeout := Now - (fConnectionTimeout * (1.0 / (24 * 60 * 60)));
|
|
fConnections.Lock;
|
|
try
|
|
for i := fconnections.Count -1 downto 0 do begin
|
|
lConn := IROSuperHttpServerconnection(fConnections[i]);
|
|
if lConn.GetSelf.fLastTalk < lConnTimeout then begin
|
|
KillConnection(lConn);
|
|
continue;
|
|
end;
|
|
|
|
lList := lConn.GetSelf.fWaitingConnections.LockList;
|
|
while lList.Count > 0 do
|
|
begin
|
|
if TROSuperHttpWaitingConnection(lList[0]).Timeout < lTimeoutTime then begin
|
|
SendResponse(TROSuperHttpWaitingConnection(lList[0]).fChannel, nil, nil, nil);
|
|
TROSuperHttpWaitingConnection(lList[0]).Free;
|
|
lList.Delete(0);
|
|
end else break;
|
|
end;
|
|
lConn.GetSelf.fWaitingConnections.UnlockList;
|
|
end;
|
|
finally
|
|
fConnections.Unlock;
|
|
end;
|
|
end;
|
|
|
|
constructor TROBaseSuperHttpServer.Create(aOwner: TComponent);
|
|
begin
|
|
inherited Create(aOwner);
|
|
fMaxPackageSize := 1024 *1024 * 1;
|
|
fServeRodl := true;
|
|
fServeInfoPage := true;
|
|
fConnections := TInterfaceList.Create;
|
|
fConnectionTimeout := 5 * 60;
|
|
end;
|
|
|
|
destructor TROBaseSuperHttpServer.Destroy;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Active := False;
|
|
if fTimer <> nil then FreeAndNil(fTimer);
|
|
if fOwnsThreadPool then FreeAndNil(fThreadPool);
|
|
|
|
fConnections.Lock;
|
|
try
|
|
for i := fConnections.Count -1 downto 0 do begin
|
|
IROSuperHttpServerConnection(fConnections[i]).DisposeData;
|
|
end;
|
|
finally
|
|
fConnections.Unlock;
|
|
end;
|
|
fConnections.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.DoActivate;
|
|
begin
|
|
if fTimer <> nil then
|
|
fTimer.Free;
|
|
fTimer := TROThreadTimer.Create(cbCleanup, 30000);
|
|
if fThreadPool = nil then begin
|
|
fThreadPool := TROThreadPool.Create(self);
|
|
fOwnsThreadPool := true;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.DoDeactivate;
|
|
begin
|
|
if fTimer <> nil then
|
|
fTimer.Free;
|
|
fTimer := nil;
|
|
end;
|
|
|
|
function TROBaseSuperHttpServer.GetConnection(
|
|
const aGuid: TGuid): IROSuperHttpServerConnection;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
fConnections.Lock;
|
|
try
|
|
for i := fConnections.Count -1 downto 0 do begin
|
|
Result := IROSuperHttpServerConnection(fConnections[i]);
|
|
if Result.GuidMatches(aGuid) then exit;
|
|
end;
|
|
finally
|
|
fConnections.Unlock;
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
function TROBaseSuperHttpServer.IntGetActive: Boolean;
|
|
begin
|
|
result := fActive;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.IntSetActive(const Value: Boolean);
|
|
begin
|
|
inherited;
|
|
if fActive <> Value then begin
|
|
fActive := Value;
|
|
if value then
|
|
DoActivate
|
|
else
|
|
DoDeactivate;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.KillConnection(
|
|
aConnection: IROSuperHttpServerConnection);
|
|
var
|
|
fListener: IROSessionsChangesListener;
|
|
begin
|
|
fConnections.Remove(aConnection);
|
|
if Supports(fEventRepository, IROSessionsChangesListener, fListener) then
|
|
flistener.SessionsChangedNotification(aConnection.GetSelf.SessionId, saRemoveActiveListener, aConnection.GetSelf);
|
|
aConnection.DisposeData;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.SendError(aTarget: IUnknown;
|
|
anError: string);
|
|
var
|
|
lData: TDynamicByteArray;
|
|
lHeaders: TIPHttpResponseHeaders;
|
|
begin
|
|
anError := '<html><head><title>Internal Server Error</title></head><body><h1>Internal Server Error</h1>'+anError+'</body></html>';
|
|
lHeaders := TIPHttpResponseHeaders.Create;
|
|
try
|
|
lHeaders.Code := 500;
|
|
lHeaders.Reason := 'Internal Error';
|
|
lHeaders.Headers.Values['Content-Type'] := 'text/html';
|
|
SetLength(lData, Length(anError));
|
|
Move(anError[1], lData[0], Length(anError));
|
|
SendResponse(aTarget, lHeaders, lData, nil);
|
|
finally
|
|
lHeaders.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.SendRodl(ATarget: IUnknown;
|
|
aRequest: TIPHttpRequestHeaders; aDispatcher: TROMessageDispatcher;
|
|
const aTargetService: string);
|
|
var
|
|
lResponse: TMemoryStream;
|
|
moduleinfo: IROModuleInfo;
|
|
aFormat: string;
|
|
lData: TDynamicByteArray;
|
|
lHeaders: TIPHttpResponseHeaders;
|
|
begin
|
|
lResponse := TMemoryStream.Create;
|
|
try
|
|
aFormat := 'text/xml';
|
|
if Supports(aDispatcher, IROModuleInfo, moduleinfo) then
|
|
moduleinfo.GetModuleInfo(lResponse, nil, aFormat)
|
|
else
|
|
GetRodl(lResponse, nil, aformat, GetRODLReader);
|
|
SetLength(lData, lResponse.Size);
|
|
lResponse.Seek(0, soFromBeginning);
|
|
lResponse.Read(lData[0], Length(lData));
|
|
|
|
except
|
|
SendError(aTarget, 'Error retrieving RODL file');
|
|
exit;
|
|
end;
|
|
lHeaders := TIPHttpResponseHeaders.Create;
|
|
try
|
|
SetDefaultHeaders(aTarget, lHeaders);
|
|
lHeaders.Headers.Values['Content-Type'] := aFormat;
|
|
SendResponse(ATarget, lHeaders, lData, nil);
|
|
finally
|
|
lHeaders.Free;
|
|
end;
|
|
end;
|
|
|
|
function SameGuid(const g1, g2: TGuid): Boolean;
|
|
begin
|
|
result := (g1.D1 = g2.D1) and
|
|
(g1.D2 = g2.D2) and
|
|
(g1.D3 = g2.D3) and
|
|
(g1.D4[0] = g2.D4[0]) and
|
|
(g1.D4[1] = g2.D4[1]) and
|
|
(g1.D4[2] = g2.D4[2]) and
|
|
(g1.D4[3] = g2.D4[3]) and
|
|
(g1.D4[4] = g2.D4[4]) and
|
|
(g1.D4[5] = g2.D4[5]) and
|
|
(g1.D4[6] = g2.D4[6]) and
|
|
(g1.D4[7] = g2.D4[7]);
|
|
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.IncomingData(aTarget: IUnknown;
|
|
aRequestHeaders: TIPHttpRequestHeaders; aData: TDynamicByteArray;
|
|
aDispatcher: TROMessageDispatcher);
|
|
var
|
|
lClientId: TGuid;
|
|
lResp: TDynamicByteArray;
|
|
lConnection: IROSuperHttpServerConnection;
|
|
i: Integer;
|
|
begin
|
|
if Length(aData) < 17 then begin
|
|
SendError(aTarget, 'Invalid Request');
|
|
exit;
|
|
end;
|
|
Move(aData[0], lClientId, Sizeof(lClientID));
|
|
case aData[16] of
|
|
ShHello:
|
|
begin
|
|
if Length(aData) <> (16 { cid:guid } + 1 { cmd } + 8 { hello command } +
|
|
4 { max package } + 16 { session guid }) then begin
|
|
SendError(aTarget, 'Invalid Request');
|
|
exit;
|
|
end;
|
|
if (aData[17] <> ord('R')) or (aData[18] <> ord('O')) or (aData[19] <> ord('S')) or
|
|
(aData[20] <> ord('H')) then begin
|
|
SendError(aTarget, 'Invalid Request');
|
|
exit;
|
|
end;
|
|
fConnections.Lock;
|
|
try
|
|
lConnection := GetConnection(lClientId);
|
|
if lConnection <> nil then begin
|
|
SetLength(lResp, 6);
|
|
lResp[0] := shError;
|
|
lResp[5] := shError_InvalidClientId;
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
exit;
|
|
end;
|
|
lConnection := TROSuperHttpServerConnection.Create(self);
|
|
lConnection.GetSelf.ConnectionId := lClientId;
|
|
lConnection.GetSelf.LastTalk := Now;
|
|
lConnection.GetSelf.RemoteMaxPackageLength :=
|
|
aData[25] or
|
|
(Integer(aData[26]) shl 8) or
|
|
(Integer(aData[27]) shl 16) or
|
|
(Integer(aData[28]) shl 24);
|
|
lConnection.GetSelf.SessionId := TGuid((@aData[29])^);
|
|
fConnections.Add(lConnection);
|
|
if SameGuid(lConnection.GetSelf.SessionId, EmptyGUID) then
|
|
lConnection.GetSelf.SessionId := NewGuid();
|
|
|
|
if fEventRepository <> nil then begin
|
|
fEventRepository.AddSession(lConnection.GetSelf.SessionId, lConnection.GetSelf);
|
|
end;
|
|
finally
|
|
fconnections.Unlock;
|
|
end;
|
|
SetLength(lResp, 8 + 4 + 16);
|
|
lResp[0] :=ord('R');
|
|
lResp[1] := ord('O');
|
|
lResp[2] := ord('S');
|
|
lResp[3] :=ord('H');
|
|
lResp[4] := ord('1');
|
|
lResp[5] := ord('0');
|
|
lResp[6] := ord('0');
|
|
lResp[7] := ord('0');
|
|
lResp[8] := fMaxPackageSize;
|
|
lResp[9] := fMaxPackageSize shr 8;
|
|
lResp[10] := fMaxPackageSize shr 16;
|
|
lResp[11] := fMaxPackageSize shr 24;
|
|
Move(lConnection.GetSelf.SessionId, lResp[12], Sizeof(TGuid));
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
exit;
|
|
end;
|
|
ShGoodbye:
|
|
begin
|
|
lConnection := GetConnection(lClientId);
|
|
if lConnection = nil then begin
|
|
SetLength(lResp, 6);
|
|
lResp[0] := ShError;
|
|
lResp[5] := ShError_InvalidClientId;
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
|
|
exit;
|
|
end;
|
|
KillConnection(lConnection);
|
|
SendResponse(aTarget, nil, nil, nil);
|
|
exit;
|
|
end;
|
|
ShPackage:
|
|
begin
|
|
lConnection := GetConnection(lClientId);
|
|
if lConnection = nil then begin
|
|
SetLength(lResp, 6);
|
|
lResp[0] := ShError;
|
|
lResp[5] := ShError_InvalidClientId;
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
|
|
exit;
|
|
end;
|
|
|
|
lConnection.GetSelf.LastTalk := Now;
|
|
if Length(aData) < 16 + 1 + 4 then begin
|
|
SendError(aTarget, 'Invalid Request');
|
|
exit;
|
|
end;
|
|
|
|
i := aData[17] or (Integer(aData[18]) shl 8) or (Integer(aData[19]) shl 16) or (Integer(aData[20]) shl 24);
|
|
SetLength(lResp, Length(aData)-21);
|
|
Move(aData[21], lResp[0], Length(lResp));
|
|
try
|
|
ProcessPackage(lConnection, aRequestHeaders, aDispatcher, i, lResp);
|
|
except
|
|
SetLength(lResp, 6);
|
|
lResp[0] := ShError;
|
|
lResp[5] := ShError_QueueFull;
|
|
lResp[1] := aData[0];
|
|
lResp[2] := aData[1];
|
|
lResp[3] := aData[2];
|
|
lResp[4] := aData[3];
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
exit;
|
|
end;
|
|
SendResponse(aTarget, nil, nil, nil);
|
|
exit;
|
|
end;
|
|
ShError:
|
|
begin
|
|
SendResponse(aTarget, nil, nil, nil);
|
|
exit;
|
|
end;
|
|
ShOptions:
|
|
begin
|
|
lConnection := GetConnection(lClientId);
|
|
if lConnection = nil then begin
|
|
SetLength(lResp, 6);
|
|
lResp[0] := shError;
|
|
lResp[5] := ShError_InvalidClientId;
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
exit;
|
|
end
|
|
else begin
|
|
SetLength(lResp, 6);
|
|
lResp[0] := shError;
|
|
lResp[5] := ShError_InvalidClientId;
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
lConnection.GetSelf.LastTalk := Now;
|
|
exit;
|
|
end;
|
|
end;
|
|
ShAsyncWait:
|
|
begin
|
|
lConnection := GetConnection(lClientId);
|
|
if lConnection = nil then begin
|
|
SetLength(lResp, 6);
|
|
lResp[0] := shError;
|
|
lResp[5] := ShError_InvalidClientId;
|
|
SendResponse(aTarget, nil, lResp, nil);
|
|
exit;
|
|
end;
|
|
lConnection.GetSelf.LastTalk := Now;
|
|
|
|
AddWaitingRequest(aTarget, lConnection);
|
|
exit;
|
|
end;
|
|
else
|
|
SendError(aTarget, 'Invalid Request');
|
|
end;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.HandleRequest(aTarget: IUnknown;
|
|
aRequestHeaders: TIPHttpRequestHeaders; aRequest: TDynamicByteArray);
|
|
var
|
|
lMd: TROMessageDispatcher;
|
|
lTempStr: TMemoryStream;
|
|
lQueryString,
|
|
lServiceName,
|
|
s,
|
|
lSubPath,
|
|
lDispatcher: string;
|
|
lResponseHeaders: TIPHttpResponseHeaders;
|
|
lResponse: TDynamicByteArray;
|
|
lRodl: TRODLLibrary;
|
|
begin
|
|
try
|
|
lDispatcher := aRequestHeaders.Path;
|
|
if Pos('?', lDispatcher) >0 then begin
|
|
lQueryString := copy(lDispatcher, pos('?', lDispatcher)+1, MaxInt);
|
|
Delete(lDispatcher, pos('?', lDispatcher), MaxInt);
|
|
end else
|
|
lQueryString := '';
|
|
|
|
if (lDispatcher <> '') and (lDispatcher[1] = '/') then delete(lDispatcher, 1,1);
|
|
if pos('/', lDispatcher) > 0 then
|
|
begin
|
|
lSubPath := copy(lDispatcher, pos('/', lDispatcher)+1, MaxInt);
|
|
lDispatcher := '/' + copy(lDispatcher, 1, pos('/', lDispatcher) - 1);
|
|
end else
|
|
begin
|
|
lDispatcher := '/' + lDispatcher;
|
|
lSubPath := '';
|
|
end;
|
|
|
|
if lQueryString <> '' then begin
|
|
if copy(lQueryString, 1, 8) = 'service=' then begin
|
|
lServiceName := copy(lQueryString, 9, MaxInt);
|
|
end else if pos('&service=', lQueryString) > 0 then begin
|
|
lServiceName := Copy(lQueryString, pos('&service=', lQueryString)+10, MaxInt);
|
|
end;
|
|
if pos('&', lServiceName) >0 then Delete(lServiceName, pos('&', lServiceName), MaxInt);
|
|
end;
|
|
|
|
lMd := TROHTTPMessageDispatchers(Dispatchers).GetDispatcherByPath(lDispatcher) as TROHTTPDispatcher;
|
|
|
|
if lmd = nil then begin
|
|
if HandleUnknownRequest(aTarget, aRequestHeaders, aRequest) then
|
|
exit
|
|
else
|
|
begin
|
|
if (lDispatcher = '/') and (fServeInfoPage) then begin
|
|
lResponseHeaders := TIPHttpResponseHeaders.Create;
|
|
try
|
|
SetDefaultHeaders(aTarget, lResponseHeaders);
|
|
lResponseHeaders.Headers.Values['Content-Type'] := 'text/html; charset=utf-8';
|
|
|
|
lrodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
s := GetRodlServerInfo('', lRodl, Dispatchers);
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
SetLength(lResponse, length(s));
|
|
Move(s[1], lResponse[0], Length(S));
|
|
SendResponse(aTarget, lResponseHeaders, lResponse, nil);
|
|
finally
|
|
lResponseHeaders.Free;
|
|
end;
|
|
exit;
|
|
end
|
|
else if (Lowercase(lDispatcher) = '/doc')and (fServeInfoPage) then begin
|
|
lResponseHeaders := TIPHttpResponseHeaders.Create;
|
|
try
|
|
SetDefaultHeaders(aTarget, lResponseHeaders);
|
|
if lSubPath = 'css' then
|
|
begin
|
|
s := GetRodlCss;
|
|
lResponseHeaders.Headers.Values['Content-Type'] := 'text/css';
|
|
end else
|
|
if lSubPath = 'xslt' then
|
|
begin
|
|
s := GetRodlStyleSheet;
|
|
lResponseHeaders.Headers.Values['Content-Type'] := 'text/xml';
|
|
end else if lSubPath = '' then
|
|
begin
|
|
lRodl := GetRodlLibrary(GetRODLReader);
|
|
try
|
|
lResponseHeaders.Headers.Values['Content-Type'] := 'text/xml';
|
|
s := GetRodlWithStyleSheet(lRodl, '/doc/xslt');
|
|
finally
|
|
lRodl.Free;
|
|
end;
|
|
end else
|
|
begin
|
|
SendError(aTarget, 'Invalid Path');
|
|
exit;
|
|
end;
|
|
SetLength(lResponse, length(s));
|
|
Move(s[1], lResponse[0], Length(S));
|
|
SendResponse(aTarget, lResponseHeaders, lResponse, nil);
|
|
finally
|
|
lResponseHeaders.Free;
|
|
end;
|
|
exit;
|
|
end
|
|
else if (LowerCase(lDispatcher) = '/favicon.ico') and (fServeInfoPage) then begin
|
|
lResponseHeaders := TIPHttpResponseHeaders.Create;
|
|
try
|
|
SetDefaultHeaders(aTarget, lResponseHeaders);
|
|
lResponseHeaders.Headers.Values['Content-Type'] := 'image/x-icon';
|
|
lTempStr := TMemoryStream.Create;
|
|
try
|
|
GetRodlFavIcon(lTempStr);
|
|
SetLengtH(lResponse, lTempStr.Size);
|
|
lTempStr.Position := 0;
|
|
lTempstr.Read(lResponse[0], Length(lResponse));
|
|
finally
|
|
lTempStr.Free;
|
|
end;
|
|
SendResponse(aTarget, lResponseHeaders, lResponse, nil);
|
|
finally
|
|
lResponseHeaders.Free;
|
|
end;
|
|
exit;
|
|
end
|
|
else if (Lowercase(lDispatcher) = '/rodl') and (fServeRodl) then begin
|
|
SendRodl(aTarget, aRequestHeaders, lMd, lServiceName);
|
|
exit;
|
|
end else begin
|
|
SendError(aTarget, 'No dispatcher configured for "'+lDispatcher+'".');
|
|
exit;
|
|
end;
|
|
end;
|
|
end;
|
|
if not lMd.Enabled then begin
|
|
SendError(aTarget, 'Dispatcher for "'+lDispatcher+'" is disabled.');
|
|
exit;
|
|
end;
|
|
if lMd.Message = nil then begin
|
|
SendError(aTarget, 'Message for dispatcher "'+lDispatcher+'" is has not been assigned.');
|
|
exit;
|
|
end;
|
|
|
|
if ((aRequestHeaders.Method = 'GET') or
|
|
(Length(aRequest) = 4)) and(fServeRodl) then begin
|
|
if (lSubPath = '') or (lSubPath = 'rodl') then begin
|
|
SendRodl(aTarget, aRequestHeaders, lmd, lServiceName);
|
|
exit;
|
|
end
|
|
else begin
|
|
SendError(aTarget, 'Message for dispatcher "'+lDispatcher+'" is has not been assigned.');
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
IncomingData(aTarget, aRequestHeaders, aRequest, lmd);
|
|
except
|
|
on e: Exception do
|
|
SendError(aTarget, e.Message);
|
|
end;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.SendAsyncResponse(
|
|
aTarget: IROSuperHttpServerConnection; lHeaders: TIPHttpResponseHeaders;
|
|
aData: TDynamicByteArray);
|
|
var
|
|
lResponse: IROSuperHttpServerResponse;
|
|
lList: TList;
|
|
lWc: TROSuperHttpWaitingConnection;
|
|
begin
|
|
lResponse := TROSuperHttpServerResponse.Create(aTarget.GetSelf, lHeaders);
|
|
lResponse.GetSelf.fData := aData;
|
|
lResponse.GetSelf.fConnection := aTarget.GetSelf;
|
|
lList := aTarget.GetSelf.WaitingConnections.LockList;
|
|
try
|
|
if lList.Count > 0 then begin
|
|
lResponse.GetSelf.Attempt :=lResponse.GetSelf.Attempt + 1;
|
|
lWc := lList[0];
|
|
lList.Delete(0);
|
|
SendResponse(lWc.Channel, lResponse.GetSelf.Headers, lResponse.GetSelf.Data, lResponse);
|
|
lWc.Free;
|
|
exit;
|
|
end;
|
|
aTarget.GetSelf.ResponseQueue.Add(lResponse);
|
|
finally
|
|
aTarget.GetSelf.WaitingConnections.UnlockList;
|
|
end;
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.SetThreadPool(const Value: TROThreadPool);
|
|
begin
|
|
if fOwnsThreadPool then
|
|
FreeAndNil(fThreadPool);
|
|
fOwnsThreadPool := false;
|
|
fThreadPool := Value;
|
|
end;
|
|
|
|
type
|
|
TQueueItem = class(TInterfacedObject, IROThreadPoolCallback, IROTransport, IROHTTPTransport)
|
|
private
|
|
fTarget: IROSuperHttpServerConnection;
|
|
fHeaders: TIPHttpRequestHeaders;
|
|
fMessageDispatcher: TROMessageDispatcher;
|
|
fId: Integer;
|
|
fData: TDynamicByteArray;
|
|
fOwner: TROBaseSuperHttpServer;
|
|
public
|
|
constructor Create(aOwner: TROBaseSuperHttpServer; aTarget: IROSuperHttpServerConnection; aHeaders: TIPHttpRequestHeaders;
|
|
aMessageDispatcher: TROMessageDispatcher; aId: Integer;
|
|
aData: TDynamicByteArray);
|
|
destructor Destroy; override;
|
|
procedure Callback(Caller: TROThreadPool; aThread: TThread);
|
|
function GetTransportObject: TObject;
|
|
function GetContentType: String;
|
|
function GetHeaders(const aName: String): String;
|
|
function GetLocation: String;
|
|
function GetPathInfo: 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);
|
|
function GetClientAddress: String;
|
|
end;
|
|
|
|
|
|
procedure TROBaseSuperHttpServer.ProcessPackage(
|
|
aTarget: IROSuperHttpServerConnection; aHeaders: TIPHttpRequestHeaders;
|
|
aMessageDispatcher: TROMessageDispatcher; aId: Integer;
|
|
aData: TDynamicByteArray);
|
|
begin
|
|
fThreadPool.QueueItem(TQueueItem.Create(self, aTarget, aHeaders, aMessageDispatcher, aId, aData));
|
|
end;
|
|
|
|
|
|
|
|
procedure TROBaseSuperHttpServer.ResponseFailed(aUserData: IInterface);
|
|
var
|
|
lData: IROSuperHttpServerResponse;
|
|
lConn: IROSuperHttpServerConnection;
|
|
lList: TList;
|
|
lWc: TROSuperHttpWaitingConnection;
|
|
|
|
begin
|
|
if aUserData = nil then exit;
|
|
|
|
lData := IROSuperHttpServerResponse(aUserData);
|
|
if lData.GetSelf.Attempt = 16 then exit; // it won't arrive after 16 tries.
|
|
|
|
lConn := lData.GetSelf.Connection;
|
|
lList := lConn.GetSelf.WaitingConnections.LockList;
|
|
try
|
|
if lList.Count > 0 then begin
|
|
lData.GetSelf.Attempt := lData.GetSelf.Attempt + 1;
|
|
lWc := TROSuperHttpWaitingConnection(lList[0]);
|
|
lList.Delete(0);
|
|
SendResponse(lWc.Channel, lData.GetSelf.Headers, lData.GetSelf.Data, lData);
|
|
lWc.Free;
|
|
exit;
|
|
end;
|
|
lConn.GetSelf.ResponseQueue.Add(lData);
|
|
finally
|
|
lConn.GetSelf.WaitingConnections.UnlockList;
|
|
end;
|
|
|
|
|
|
end;
|
|
|
|
procedure TROBaseSuperHttpServer.ResponseSucessful(aUserData: IInterface);
|
|
begin
|
|
// nothing to do here.
|
|
end;
|
|
|
|
function TROBaseSuperHttpServer.GetDispatchersClass: TROMessageDispatchersClass;
|
|
begin
|
|
Result := TROHTTPMessageDispatchers;
|
|
end;
|
|
|
|
type
|
|
TByteArrayStream = class(TStream)
|
|
private
|
|
fPos: Integer;
|
|
fData: TDynamicByteArray;
|
|
protected
|
|
{$IFDEF DELPHI7UP}
|
|
function GetSize: Int64; override;
|
|
{$ENDIF}
|
|
public
|
|
constructor Create(aData: TDynamicByteArray);
|
|
function Write(const Buffer; Count: Integer): Integer; override;
|
|
function Read(var Buffer; Count: Integer): Integer; override;
|
|
function Seek(Offset: Integer; Origin: Word): Integer; override;
|
|
end;
|
|
|
|
{ TQueueItem }
|
|
|
|
procedure TQueueItem.Callback(Caller: TROThreadPool; aThread: TThread);
|
|
var
|
|
lStream, lResponse: TStream;
|
|
lResp: TDynamicByteArray;
|
|
begin
|
|
lStream := nil;
|
|
lResponse := TMemoryStream.Create;
|
|
try
|
|
if assigned(fOwner.OnReadFromStream) then begin
|
|
lStream := TMemoryStream.Create;
|
|
lStream.Write(fData[0], Length(fData));
|
|
lstream.Position := 0;
|
|
fOwner.OnReadFromStream(lStream);
|
|
end
|
|
else
|
|
lStream := TByteArrayStream.Create(fData);
|
|
fData := nil;
|
|
|
|
fOwner.DispatchMessage(self, lStream, lResponse);
|
|
|
|
if assigned(fOwner.OnWriteToStream) then
|
|
fOwner.OnWriteToStream(lResponse);
|
|
|
|
lResponse.Position := 0;
|
|
|
|
SetLength(lResp, lResponse.Size + 5);
|
|
lResp[0] := ShPackage;
|
|
lResp[1] := fId;
|
|
lResp[2] := fId shr 8;
|
|
lResp[3] := fId shr 16;
|
|
lResp[4] := fId shr 24;
|
|
lResponse.Read(lResp[5], lResponse.Size);
|
|
fOwner.SendAsyncResponse(fTarget, nil, lResp);
|
|
except
|
|
on E: Exception do begin
|
|
setLength(lResp, 4 + 1 + 1);
|
|
lResp[0] := ShError;
|
|
lResp[1] := fId;
|
|
lResp[2] := fId shr 8;
|
|
lResp[3] := fId shr 16;
|
|
lResp[4] := fId shr 24;
|
|
lResp[5] := ShError_QueueFull;
|
|
fOwner.SendAsyncResponse(fTarget, nil, lResp);
|
|
end;
|
|
end;
|
|
lStream.Free;
|
|
lResponse.Free;
|
|
end;
|
|
|
|
constructor TQueueItem.Create(aOwner: TROBaseSuperHttpServer;
|
|
aTarget: IROSuperHttpServerConnection; aHeaders: TIPHttpRequestHeaders;
|
|
aMessageDispatcher: TROMessageDispatcher; aId: Integer;
|
|
aData: TDynamicByteArray);
|
|
begin
|
|
inherited Create;
|
|
fOwner := aOwner;
|
|
fTarget := aTarget;
|
|
fHeaders := TIPHttpRequestHeaders.Create;
|
|
fHeaders.Headers.Assign(aHeaders.Headers);
|
|
fHeaders.Method := aHeaders.Method;
|
|
fHeaders.Version := aHeaders.Version;
|
|
fHeaders.Path := aHeaders.Path;
|
|
|
|
fMessageDispatcher := aMessageDispatcher;
|
|
fId := aId;
|
|
fData := aData;
|
|
end;
|
|
|
|
destructor TQueueItem.Destroy;
|
|
begin
|
|
fHeaders.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TQueueItem.GetClientAddress: String;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TQueueItem.GetContentType: String;
|
|
begin
|
|
result := fHeaders.ContentType;
|
|
end;
|
|
|
|
function TQueueItem.GetHeaders(const aName: String): String;
|
|
begin
|
|
result := fHeaders.Headers.Values[aName];
|
|
end;
|
|
|
|
function TQueueItem.GetLocation: String;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TQueueItem.GetPathInfo: String;
|
|
begin
|
|
result := fHeaders.Path;
|
|
end;
|
|
|
|
function TQueueItem.GetQueryString: String;
|
|
begin
|
|
result := fHeaders.Path;
|
|
if pos('?', Result) <> 0 then
|
|
result := copy(Result, pos('?', Result) + 1 ,MaxInt)
|
|
else
|
|
result := '';
|
|
end;
|
|
|
|
function TQueueItem.GetTargetURL: String;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
function TQueueItem.GetTransportObject: TObject;
|
|
begin
|
|
result := fOwner;
|
|
end;
|
|
|
|
function TQueueItem.GetUserAgent: String;
|
|
begin
|
|
result := fHeaders.Headers.Values['User-Agent'];
|
|
end;
|
|
|
|
procedure TQueueItem.SetContentType(const aValue: String);
|
|
begin
|
|
end;
|
|
|
|
procedure TQueueItem.SetHeaders(const aName, aValue: String);
|
|
begin
|
|
fHeaders.Headers.Values[aName] := aValue;
|
|
end;
|
|
|
|
procedure TQueueItem.SetPathInfo(const aValue: String);
|
|
begin
|
|
end;
|
|
|
|
procedure TQueueItem.SetTargetURL(const aValue: String);
|
|
begin
|
|
end;
|
|
|
|
procedure TQueueItem.SetUserAgent(const aValue: String);
|
|
begin
|
|
end;
|
|
|
|
{ TByteArrayStream }
|
|
|
|
constructor TByteArrayStream.Create(aData: TDynamicByteArray);
|
|
begin
|
|
inherited Create;
|
|
fData := aData;
|
|
fPos := 0;
|
|
end;
|
|
|
|
{$IFDEF DELPHI7UP}
|
|
function TByteArrayStream.GetSize: Int64;
|
|
begin
|
|
result := Length(fData);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TByteArrayStream.Read(var Buffer; Count: Integer): Integer;
|
|
begin
|
|
if fPos + Count >= Length(fData) then Count := Length(fData) - fPos;
|
|
Move(fData[fPos], Buffer, Count);
|
|
fPos := fPos + Count;
|
|
result := Count;
|
|
end;
|
|
|
|
function TByteArrayStream.Seek(Offset: Integer; Origin: Word): Integer;
|
|
begin
|
|
case Origin of
|
|
soFromBeginning: fPos := Offset;
|
|
soFromCurrent: fPos := fPos + Offset;
|
|
soFromEnd: fPos := Length(fData) + Offset;
|
|
end;
|
|
if fPos < 0 then fPos := 0;
|
|
if fPos >= Length(fData) then fPos := Length(fData) -1;
|
|
Result := fPos;
|
|
end;
|
|
|
|
function TByteArrayStream.Write(const Buffer; Count: Integer): Integer;
|
|
begin
|
|
raise Exception.Create('Readonly stream cannot be written to');
|
|
end;
|
|
|
|
end.
|