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.