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.