449 lines
12 KiB
ObjectPascal
449 lines
12 KiB
ObjectPascal
unit uROIpTcpServer;
|
|
|
|
{----------------------------------------------------------------------------}
|
|
{ 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,
|
|
uROThreadPool;
|
|
|
|
type
|
|
TROIpTcpServer = class(TROServer)
|
|
private
|
|
fServeRodl: Boolean;
|
|
fSocket4,
|
|
fSocket6: TIPAsyncSocket;
|
|
fThreadPool: TROThreadPool;
|
|
fPort: Integer;
|
|
fOwnsThreadPool: Boolean;
|
|
fOnManualBindSocket: TNotifyEvent;
|
|
fActive: Boolean;
|
|
fBindV4,
|
|
fBindV6: Boolean;
|
|
fClients: TInterfaceList;
|
|
fMaxRequestsize: Integer;
|
|
fTimeout: Integer;
|
|
procedure cbAccept(aSender: TIPBaseAsyncSocket);
|
|
procedure SetThreadPool(const Value: TROThreadPool);
|
|
procedure DisconnectClients;
|
|
protected
|
|
procedure IntSetActive(const Value: boolean); override;
|
|
function IntGetActive : boolean; override;
|
|
|
|
function GetPort: Integer;
|
|
procedure SetPort(const Value: Integer);
|
|
public
|
|
constructor Create(aComponent: TComponent); override;
|
|
destructor Destroy; override;
|
|
|
|
property SocketV4: TIPAsyncSocket read fSocket4;
|
|
property SocketV6: TIPAsyncSocket read fSocket6;
|
|
published
|
|
property Port:Integer read GetPort write SetPort;
|
|
property BindV6: Boolean read fBindV6 write fBindV6 default true;
|
|
property BindV4: Boolean read fBindV4 write fBindV4 default true;
|
|
property ServeRodl : Boolean read fServeRodl write fServeRodl default true;
|
|
property OnGetRODLReader;
|
|
property MaxRequestSize: Integer read fMaxRequestSize write fMaxRequestSize default 5 * 1024 * 1024;
|
|
property Timeout: Integer read fTimeout write fTimeout default 120;
|
|
|
|
property ThreadPool: TROThreadPool read fThreadPool write SetThreadPool;
|
|
|
|
property OnManualBindSocket: TNotifyEvent read fOnManualBindSocket write fOnManualBindSocket;
|
|
end;
|
|
TByteArray = array of Byte;
|
|
TByteArrayWrapper = class(TStream)
|
|
private
|
|
fPosition: Integer;
|
|
fData: TByteArray;
|
|
protected
|
|
{$IFDEF DELPHI7UP}
|
|
function GetSize: Int64; override;
|
|
{$ENDIF}
|
|
public
|
|
constructor Create(const aData: TByteArray);
|
|
function Read(var Buffer; Count: Integer): Integer; override;
|
|
function Write(const Buffer; Count: Integer): Integer; override;
|
|
function Seek(Offset: Integer; Origin: Word): Integer; override;
|
|
end;
|
|
|
|
|
|
implementation
|
|
uses
|
|
uROHTTPTools, uROHTTPDispatch, SysUtils;
|
|
type
|
|
TIPTCPContext = class;
|
|
IIPTCPContext = interface
|
|
['{EC581981-DF92-4929-8480-D738E2519175}']
|
|
function GetSelf: TIPTCPContext;
|
|
end;
|
|
TIPTCPContext = class(TInterfacedObject, IIPTCPContext, IROTransport, IROTCPTransport)
|
|
private
|
|
fConnection: TIPBaseAsyncSocket;
|
|
fDisconnected: Boolean;
|
|
fOwner: TROIPTCPServer;
|
|
fRequestData: TByteArray;
|
|
fResponseData: TMemoryStream;
|
|
procedure cbDisconnect(sender: TIPBaseAsyncSocket);
|
|
procedure cbRequestSize(sender: TIPBaseAsyncSocket);
|
|
procedure cbRequest(sender: TIPBaseAsyncSocket);
|
|
procedure cbResponseSent(Sender: TIPBaseAsyncSocket);
|
|
public
|
|
constructor Create(aOwner: TROIPTCPServer; aConnection: TIPBaseAsyncSocket);
|
|
destructor Destroy; override;
|
|
procedure Disconnect;
|
|
procedure SendResponse;
|
|
function GetSelf: TIPTCPContext;
|
|
property Connection: TIPBaseAsyncSocket read fConnection write fConnection;
|
|
property Owner: TROIPTCPServer read fOwner;
|
|
property ResponseData: TMemoryStream read fResponseData;
|
|
function GetClientAddress: String;
|
|
function GetTransportObject: TObject;
|
|
end;
|
|
|
|
|
|
{ TROIPTCPServer }
|
|
|
|
constructor TROIPTCPServer.Create(aComponent: TComponent);
|
|
begin
|
|
inherited Create(aComponent);
|
|
fMaxRequestsize := 5 * 1024 * 1024;
|
|
fPort := 8090;
|
|
fBindV4 := true;
|
|
fBindV6 := true;
|
|
fClients := TInterfaceList.Create;
|
|
end;
|
|
|
|
destructor TROIPTCPServer.Destroy;
|
|
begin
|
|
Active := false;
|
|
fSocket4.Free;
|
|
fSocket6.Free;
|
|
fClients.Free;
|
|
if fOwnsThreadPool then
|
|
fThreadPool.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TROIPTCPServer.GetPort: Integer;
|
|
begin
|
|
result := fPort;
|
|
end;
|
|
|
|
function TROIPTCPServer.IntGetActive: boolean;
|
|
begin
|
|
result := fActive;
|
|
end;
|
|
|
|
procedure TROIPTCPServer.DisconnectClients;
|
|
var
|
|
i: integer;
|
|
ctx: IIPTCPContext;
|
|
begin
|
|
fClients.Lock;
|
|
try
|
|
for i := 0 to fClients.Count -1 do begin
|
|
ctx := IIPTCPContext(fClients[i]);
|
|
ctx.GetSelf.fOwner := nil;
|
|
ctx.GetSelf.Disconnect;
|
|
end;
|
|
finally
|
|
fClients.Unlock;
|
|
end;
|
|
fClients.Clear;
|
|
end;
|
|
|
|
|
|
procedure TROIPTCPServer.IntSetActive(const Value: boolean);
|
|
begin
|
|
inherited;
|
|
if Value = fActive then exit;
|
|
fActive := value;
|
|
if Value then begin
|
|
if fThreadPool = nil then begin
|
|
fThreadPool := TROThreadPool.Create(nil);
|
|
fOwnsThreadPool := true;
|
|
end;
|
|
if fBindV4 then begin
|
|
fSocket4 := TIPAsyncSocket.Create(rsmTCPIP4);
|
|
if not assigned(fOnManualBindSocket) then
|
|
fSocket4.Bind('0.0.0.0', fPort);
|
|
end;
|
|
if fBindV6 then begin
|
|
fSocket6 := TIPAsyncSocket.Create(rsmTCPIP6);
|
|
if not assigned(fOnManualBindSocket) then
|
|
fSocket6.Bind('::', fPort);
|
|
end;
|
|
if assigned(fOnManualBindSocket) then fOnManualBindSocket(self);
|
|
if assigned(fSocket4) then begin
|
|
fSocket4.Listen(10);
|
|
fSocket4.BeginAccept(cbAccept);
|
|
end;
|
|
if assigned(fSocket6) then begin
|
|
fSocket6.Listen(10);
|
|
fSocket6.BeginAccept(cbAccept);
|
|
end;
|
|
end else begin
|
|
DisconnectClients;
|
|
fSocket4.Free;
|
|
fSocket6.Free;
|
|
fSocket4 := nil;
|
|
fSocket6 := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TROIPTCPServer.SetPort(const Value: Integer);
|
|
begin
|
|
fPort := Value;
|
|
end;
|
|
|
|
procedure TROIPTCPServer.SetThreadPool(const Value: TROThreadPool);
|
|
begin
|
|
if fOwnsThreadPool then begin
|
|
FreeAndNil(fThreadPool);
|
|
end;
|
|
fOwnsThreadPool := false;
|
|
fThreadPool := Value;
|
|
end;
|
|
|
|
procedure TROIPTCPServer.cbAccept(aSender: TIPBaseAsyncSocket);
|
|
var
|
|
lSock: TIPBaseAsyncSocket;
|
|
lContext: IIPTCPContext;
|
|
begin
|
|
try
|
|
lSock := aSender.EndAccept;
|
|
except
|
|
on e: EIPSocketError do
|
|
exit;
|
|
// We're shutting down, exit now.
|
|
end;
|
|
lContext := TIPTCPContext.Create(self, lSock);
|
|
lSock.NoDelay := true;
|
|
fClients.Add(lContext);
|
|
aSender.BeginAccept(cbAccept);
|
|
end;
|
|
|
|
{ TIPTCPContext }
|
|
|
|
procedure TIPTCPContext.cbDisconnect(sender: TIPBaseAsyncSocket);
|
|
var
|
|
lConn: TIPBaseAsyncSocket;
|
|
begin
|
|
fDisconnected := true;
|
|
lConn := fConnection;
|
|
fConnection := nil;
|
|
if lConn <> nil then begin
|
|
lConn.EndDisconnect;
|
|
lConn.Free;
|
|
end;
|
|
if assigned(fOwner) then begin
|
|
fOwner.fClients.Remove(IIPTCPContext(self));
|
|
end;
|
|
end;
|
|
|
|
procedure TIPTCPContext.cbRequestSize(sender: TIPBaseAsyncSocket);
|
|
var
|
|
lRequest: Integer;
|
|
begin
|
|
if sender.EndReceive <> 4 then begin
|
|
cbDisconnect(sender);
|
|
exit;
|
|
end;
|
|
lRequest := fRequestData[3] or
|
|
(fRequestData[2] shl 8) or
|
|
(fRequestData[1] shl 16) or
|
|
(fRequestData[0] shl 24);
|
|
if lRequest > fOwner.MaxRequestSize then begin
|
|
cbDisconnect(sender);
|
|
exit;
|
|
end;
|
|
SetLength(fRequestData, lRequest);
|
|
fConnection.BeginReceive(@fRequestData[0], 0, lRequest, cbRequest);
|
|
end;
|
|
|
|
type
|
|
TIPTCPWorker = class(TInterfacedObject, IROThreadPoolCallback)
|
|
private
|
|
fContext: IIPTCPContext;
|
|
public
|
|
constructor Create(aContext: IIPTCPContext);
|
|
procedure Callback(Caller: TROThreadPool; aThread: TThread);
|
|
end;
|
|
|
|
procedure TIPTCPContext.cbRequest(sender: TIPBaseAsyncSocket);
|
|
begin
|
|
if sender.EndReceive <> Length(fRequestData) then begin
|
|
cbDisconnect(sender);
|
|
exit;
|
|
end;
|
|
try
|
|
fOwner.fThreadPool.QueueItem(TIPTCPWorker.Create(Self));
|
|
except
|
|
cbDisconnect(sender);
|
|
exit;
|
|
end;
|
|
end;
|
|
|
|
constructor TIPTCPContext.Create(aOwner: TROIPTCPServer;
|
|
aConnection: TIPBaseAsyncSocket);
|
|
begin
|
|
fOwner := aOwner;
|
|
fConnection := aConnection;
|
|
fconnection.Buffered := true;
|
|
fConnection.OnTimeout := cbDisconnect;
|
|
fConnection.OnDisconnected := cbDisconnect;
|
|
fConnection.IdleTimeout := fOwner.Timeout;
|
|
SetLength(fRequestData, 4);
|
|
fResponseData := TMemoryStream.Create;
|
|
fConnection.BeginReceive(@fRequestData[0], 0, 4, cbRequestSize);
|
|
end;
|
|
|
|
destructor TIPTCPContext.Destroy;
|
|
begin
|
|
fResponseData.Free;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TIPTCPContext.Disconnect;
|
|
begin
|
|
fDisconnected := true;
|
|
|
|
if assigned(fConnection) then
|
|
fConnection.BeginDisconnect(cbDisconnect);
|
|
end;
|
|
|
|
function TIPTCPContext.GetSelf: TIPTCPContext;
|
|
begin
|
|
result := self;
|
|
end;
|
|
|
|
procedure TIPTCPContext.SendResponse;
|
|
var
|
|
lLength: Integer;
|
|
begin
|
|
lLength := fResponseData.Size;
|
|
fResponseData.Position := 0;
|
|
if fResponseData.Size < 1020 then begin
|
|
SetLength(fRequestData, 4 + fResponseData.Size);
|
|
end else
|
|
SetLength(fRequestData, 1024);
|
|
fRequestData[3] := Byte(lLength);
|
|
fRequestData[2] := Byte(Integer(lLength shr 8));
|
|
fRequestData[1] := Byte(Integer(lLength shr 16));
|
|
fRequestData[0] := Byte(Integer(lLength shr 24));
|
|
fResponseData.Read(fRequestData[4], Length(fRequestData)-4);
|
|
fConnection.BeginSend(@fRequestData[0], 0, Length(fRequestData), cbResponseSent);
|
|
end;
|
|
|
|
procedure TIPTCPContext.cbResponseSent(Sender: TIPBaseAsyncSocket);
|
|
var
|
|
lLength: Integer;
|
|
begin
|
|
if fConnection.EndSend <= 0 then begin
|
|
cbDisconnect(fConnection);
|
|
exit;
|
|
end;
|
|
|
|
lLength := fResponseData.Read(fRequestData[0], 1024);
|
|
if lLength = 0 then begin
|
|
if Length(fRequestData) < 4 then SetLength(fRequestData, 4);
|
|
fResponseData.Clear;
|
|
fConnection.BeginReceive(@fRequestData[0], 0, 4, cbRequestSize);
|
|
end else begin
|
|
fConnection.BeginSend(@fRequestData[0], 0, lLength, cbResponseSent);
|
|
end;
|
|
end;
|
|
|
|
function TIPTCPContext.GetClientAddress: String;
|
|
begin
|
|
Result := fConnection.GetRemoteIp;
|
|
end;
|
|
|
|
function TIPTCPContext.GetTransportObject: TObject;
|
|
begin
|
|
Result := fOwner;
|
|
end;
|
|
|
|
{ TIPTCPWorker }
|
|
|
|
procedure TIPTCPWorker.Callback(Caller: TROThreadPool; aThread: TThread);
|
|
var
|
|
lWrapper: TByteArrayWrapper;
|
|
begin
|
|
lWrapper := TByteArrayWrapper.Create(fContext.GetSelf.fRequestData);
|
|
try
|
|
if (fContext.GetSelf.fOwner.ServeRodl) or ((lWrapper.Size <> 0) and (lWrapper.Size <> 4)) then
|
|
fContext.GetSelf.fOwner.DispatchMessage(fContext.GetSelf, lWrapper, fContext.GetSelf.ResponseData);
|
|
fContext.GetSelf.SendResponse;
|
|
except
|
|
// can't have exceptions escape
|
|
end;
|
|
lWrapper.Free;
|
|
end;
|
|
|
|
constructor TIPTCPWorker.Create(aContext: IIPTCPContext);
|
|
begin
|
|
fContext := aContext;
|
|
end;
|
|
|
|
{ TByteArrayWrapper }
|
|
|
|
constructor TByteArrayWrapper.Create(const aData: TByteArray);
|
|
begin
|
|
inherited Create;
|
|
fData := aData;
|
|
end;
|
|
|
|
{$IFDEF DELPHI7UP}
|
|
function TByteArrayWrapper.GetSize: Int64;
|
|
begin
|
|
result := Length(fData);
|
|
end;
|
|
{$ENDIF}
|
|
|
|
function TByteArrayWrapper.Read(var Buffer; Count: Integer): Integer;
|
|
begin
|
|
if fPosition + Count > Length(fData) then
|
|
Count := Length(fData) - fPosition;
|
|
Move(fData[fPosition], Buffer, Count);
|
|
fPosition := fPosition + Count;
|
|
result := Count;
|
|
end;
|
|
|
|
function TByteArrayWrapper.Seek(Offset: Integer; Origin: Word): Integer;
|
|
begin
|
|
case Origin of
|
|
soFromBeginning: fPosition := Offset;
|
|
soFromCurrent: fPosition := fPosition + Offset;
|
|
soFromEnd: fPosition := Length(fData) + Offset;
|
|
end;
|
|
if fPosition < 0 then fPosition := 0 else
|
|
if fPosition > Length(fData) then fPosition := Length(fData);
|
|
result := fPosition;
|
|
end;
|
|
|
|
function TByteArrayWrapper.Write(const Buffer; Count: Integer): Integer;
|
|
begin
|
|
raise Exception.Create('Not Implemented');
|
|
end;
|
|
|
|
initialization
|
|
RegisterServerClass(TROIPTCPServer);
|
|
finalization
|
|
UnregisterServerClass(TROIPTCPServer);
|
|
end.
|