unit uROIpHttpServer;

{----------------------------------------------------------------------------}
{ 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, uIPAsyncHttpServer, uIPHttpHeaders,
  uROThreadPool, uROServerIntf, uRORes, uROClient, uROHtmlServerInfo, uRODL, uROHTTPTools;

type
  TROIpHTTPServer = class(TROServer)
  private
    fServeRodl, fServeInfoPage: Boolean;
    fSendExceptionsAs500: boolean;
    fServer: TIPAsyncHttpServer;
    fThreadPool: TROThreadPool;
    fOwnsThreadPool: Boolean;
    fOnManualBindSocket: TNotifyEvent;
    fOnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod;
    fSendClientAccessPolicyXml: TROClientAccessPolicyType;
    procedure SetThreadPool(const Value: TROThreadPool);
  protected
    procedure IntSetActive(const Value: boolean); override;
    function IntGetActive : boolean; override;

    function GetDispatchersClass : TROMessageDispatchersClass; override;


    function GetPort: Integer;
    procedure SetPort(const Value: Integer);
    procedure IntRequest(Sender: TObject; aContext: IIPAsyncContext);
  public
    constructor Create(aComponent: TComponent); override;
    destructor Destroy; override;

    property Server: TIPAsyncHttpServer read fServer;
  published
    property Port:Integer read GetPort write SetPort;
    property ServeInfoPage : Boolean read fServeInfoPage write fServeInfoPage default true;
    property ServeRodl : Boolean read fServeRodl write fServeRodl default true;
    property SendExceptionsAs500: boolean read fSendExceptionsAs500 write fSendExceptionsAs500 default true;
    property OnGetRODLReader;

    property ThreadPool: TROThreadPool read fThreadPool write SetThreadPool;

    property OnManualBindSocket: TNotifyEvent read fOnManualBindSocket write fOnManualBindSocket;
    property OnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod read fOnGetCustomClientAccessPolicy write fOnGetCustomClientAccessPolicy;
    property SendClientAccessPolicyXml: TROClientAccessPolicyType read fSendClientAccessPolicyXml write fSendClientAccessPolicyXml default captAllowNone;
  end;

implementation
uses
  uROHTTPDispatch, TypInfo, SysUtils, uROIpTcpServer, uROClasses;

type
  TROIpHttpWorker = class(TInterfacedObject, IROThreadPoolCallback, IROTransport, IROTCPTransport, IROHTTPTransport)
  private
    fOwner: TROIpHTTPServer;
    fContext: IIPAsyncContext;
    fQueryData: TStringList;
    function GetClientAddress: String;
    function GetTransportObject: TObject;
    function GetContentType: String;
    function GetHeaders(const aName: String): String;
    function GetLocation: String;
    function GetPathInfo: String;
    function GetQueryParameter(const aName: String): 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);
  public
    constructor Create(aOwner: TROIpHTTPServer; aContext: IIPAsyncContext);
    destructor Destroy; override;
    procedure Callback(Caller: TROThreadPool; aThread: TThread);
  end;

{ TROIpHTTPServer }

constructor TROIpHTTPServer.Create(aComponent: TComponent);
begin
  inherited Create(aComponent);

  fServer := TIPAsyncHttpServer.Create;
  fServer.OnRequest := IntRequest;
  fServer.Port := 8099;
  fServeInfoPage := true;
  fServeRodl := true;
end;

destructor TROIpHTTPServer.Destroy;
begin
  Active := false;
  fServer.Free;
  if fOwnsThreadPool then
    fThreadPool.Free;
  inherited Destroy;
end;

function TROIpHTTPServer.GetDispatchersClass: TROMessageDispatchersClass;
begin
  Result := TROHTTPMessageDispatchers;
end;

function TROIpHTTPServer.GetPort: Integer;
begin
  result := fServer.Port;
end;

function TROIpHTTPServer.IntGetActive: boolean;
begin
  result := fServer.Active;
end;

procedure TROIpHTTPServer.IntSetActive(const Value: boolean);
begin
  inherited;
  if Value = fserver.Active then exit;
  if Value then begin
    fServer.OnManualBind := fOnManualBindSocket;
    if fThreadPool = nil then begin
      fThreadPool := TROThreadPool.Create(nil);
      fOwnsThreadPool := true;
    end;
    fServer.Active := true;
  end else begin
    fServer.Active := false;
    
  end;
end;

procedure TROIpHTTPServer.SetPort(const Value: Integer);
begin
  fServer.Port := Value;
end;

procedure TROIpHTTPServer.SetThreadPool(const Value: TROThreadPool);
begin
  if fOwnsThreadPool then begin
    FreeAndNil(fThreadPool);
  end;
  fOwnsThreadPool := false;
  fThreadPool := Value;
end;

procedure TROIpHTTPServer.IntRequest(Sender: TObject;
  aContext: IIPAsyncContext);
begin
  try
    fThreadPool.QueueItem(TROIpHttpWorker.Create(self, aContext));
  except
    aContext.GetSelf.Disconnect;
  end;
end;


{ TROIpHttpWorker }

procedure TROIpHttpWorker.Callback(Caller: TROThreadPool;
  aThread: TThread);

  procedure WriteError(resp : TMemoryStream);
  var
    s: ansistring;
  begin
    s := '<font size="7">500 Invalid Path</font><br />'+{$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(err_CannotFindMessageDispatcher);
    resp.Write(s[1], Length(s));
  end;

var
  Req: TByteArrayWrapper;
  lRodl: TRODLLibrary;
  root,
  sub: string;
  data: TDynamicByteArray;
  disp: TROHTTPDispatcher;
  ok: Boolean;
  resp: TMemoryStream;
  lIgnore: TROResponseOptions;
  s: ansistring;
  s1: string;
  info: IRONamedModuleInfo;
  lPolicyContent: AnsiString;
begin
  req := TByteArrayWrapper.Create(TByteArray(fContext.RequestData));
  resp := TMemoryStream.Create;
  fcontext.Response.Headers.Values['Content-Type'] := fContext.Request.ContentType;
  fcontext.Response.Code := 200;
  fcontext.Response.Reason := 'OK';
  ok := False;
  try
    root := fContext.Request.Path;
    if Pos('?', Root) > 0 then Delete(Root, pos('/', root), MaxInt);
    if (root <> '') and (root[1] = '/') then delete(root, 1,1);
    if pos('/', root) > 0 then
    begin
      sub := copy(root, pos('/', root)+1, maxint);
      root := '/' + copy(root, 1, pos('/', root) - 1);
    end else
    begin
      root := '/' + root;
      sub := '';
    end;

    disp := TROHTTPMessageDispatchers(fOwner.Dispatchers).GetDispatcherByPath(root) as TROHTTPDispatcher;

    if disp <> nil then
    begin
      if (req.Size = 0) then begin
        ok := fOwner.fServeRodl;
        if ok then
          ok := fOwner.IntDispatchMessage(disp, self, req, resp, lIgnore)
        else begin
          WriteError(resp);
          SetContentType('text/html');
        end;
      end else if (sub = '')  then
        ok := fOwner.IntDispatchMessage(disp, self, req, resp, lIgnore)
      else if (CompareText(sub, 'rodl') = 0) and fOwner.fServeRodl then
      begin
        if copy(disp.PathInfo, 1, 1) = '/' then SetPathInfo(disp.PathInfo) else SetPathInfo('/'+disp.PathInfo);
        GetRodl(resp, self, s1, fOwner.GetRODLReader);
        SetContentType(s1);

        ok := true;
      end else if Supports(disp.Message, IRONamedModuleInfo, info) and (CompareText(info.ModuleInfoName, sub) = 0) and fOwner.fServeRodl then
      begin
        if copy(disp.PathInfo, 1, 1) = '/' then SEtPathInfo(disp.PathInfo) else SetPathInfo('/'+disp.PathInfo);
        info.GetModuleInfo(resp, self, s1);
        SetContentType(s1);
        ok := true;
      end else
      begin
        ok := fOwner.IntDispatchMessage(disp, self, req, resp, lIgnore)
      end;
    end else if (CompareText(root, '/rodl') = 0) and (sub = '') and fOwner.fServeRodl then
    begin
      GetRodl(resp, self, s1, fOwner.GetRODLReader);
      SetContentType(s1);
      ok := true;
    end else if fOwner.fServeInfoPage and (CompareText(root, '/doc') = 0) then
    begin
      if sub = 'css' then
      begin
        s := GetRodlCss;
        resp.Write(s[1], Length(s));
        SetContentType('text/css');
        ok := true;
      end else
      if sub = 'xslt' then
      begin
        s := GetRodlStyleSheet;
        resp.Write(s[1], Length(s));
        SetContentType('text/xml');
        ok := true;
      end else if sub = '' then
      begin
        lRodl := GetRodlLibrary(fOwner.GetRODLReader);
        try
          SetContentType('text/xml');
          s := GetRodlWithStyleSheet(lRodl, '/doc/xslt');
          resp.Write(s[1], Length(s));
        finally
          lRodl.Free;
        end;
        ok := true;
      end else
      begin
        WriteError(resp);
        ok := false;
      end;
    end else if fOwner.fServeInfoPage and (CompareStr(root, '/favicon.ico') = 0) then
    begin
      GetRodlFavIcon(resp);
      SetContentType('image/x-icon');
      ok := true;
    end else if fOwner.fServeInfoPage and (root = '/') then
    begin
      lrodl := GetRodlLibrary(fOwner.GetRODLReader);
      try
        s := GetRodlServerInfo('/', lRodl, fOwner.Dispatchers);
        resp.Write(s[1], Length(s));
      finally
        lRodl.Free;
      end;
      ok := true;
    end else
    if CompareText(root, '/clientaccesspolicy.xml') = 0 then begin
      case fOwner.fSendClientAccessPolicyXml of
        captAllowAll: begin
          lPolicyContent := GetClientAccessPolicy;
        end;
        captCustom: begin
          if Assigned(fOwner.fOnGetCustomClientAccessPolicy) then
            fOwner.fOnGetCustomClientAccessPolicy(fOwner, lPolicyContent);
        end;
      end;
      if lPolicyContent <> '' then begin
        SetContentType('text/xml');
        resp.Write(lPolicyContent[1], Length(lPolicyContent));
      end;
    end  else
    begin
      WriteError(resp);
      ok := false;
    end;

    if not (ok or fOwner.fSendExceptionsAs500) then begin
      fcontext.Response.Code := 500;
      fcontext.Response.Reason := 'Internal Server Error';
    end;
  except
  end;
  req.Free;
  try
    SetLength(data, resp.Size);
    resp.position := 0;
    resp.Read(data[0], Length(data));
    fContext.ResponseData := data;
    fContext.SendResponse;
  finally
    resp.Free;
  end;
end;

constructor TROIpHttpWorker.Create(aOwner: TROIpHTTPServer;
  aContext: IIPAsyncContext);
begin
  inherited Create;
  fOwner := aOwner;
  fContext := aContext;
end;

destructor TROIpHttpWorker.Destroy;
begin
  fQueryData.Free;
  inherited;
end;

function TROIpHttpWorker.GetClientAddress: String;
begin
  result := fContext.Request.ClientAddress;
end;

function TROIpHttpWorker.GetContentType: String;
begin
  result := fContext.Request.ContentType;
end;

function TROIpHttpWorker.GetHeaders(const aName: String): String;
begin
  result := fContext.Request.Headers.Values[aname];
end;

function TROIpHttpWorker.GetLocation: String;
begin
  Result := '';
end;

function TROIpHttpWorker.GetPathInfo: String;
begin
  result := '';
end;

function TROIpHttpWorker.GetQueryParameter(const aName: String): String;
begin
  if fQueryData = nil then begin
    fQueryData := TStringList.Create;
    fQueryData.Delimiter := '&';
    fQueryData.DelimitedText := GetQueryString;
  end;
  result := fqueryData.Values[aName];
end;

function TROIpHttpWorker.GetQueryString: String;
begin
  result := fContext.Request.Path;
  if Pos('?', result) = 0 then result := '' else
    result := Copy(Result, Pos('?', result)+1, MaxInt);
end;

function TROIpHttpWorker.GetTargetURL: String;
begin
  result := '';
end;

function TROIpHttpWorker.GetTransportObject: TObject;
begin
  result := FOwner;
end;

function TROIpHttpWorker.GetUserAgent: String;
begin
  Result := fContext.Request.Headers.Values['User-Agent'];
end;

procedure TROIpHttpWorker.SetContentType(const aValue: String);
begin
  fContext.Response.Headers.Values['Content-Type'] := aValue;
end;

procedure TROIpHttpWorker.SetHeaders(const aName, aValue: String);
begin
  fContext.Response.Headers.Values[aName] := aValue;
end;

procedure TROIpHttpWorker.SetPathInfo(const aValue: String);
begin
end;

procedure TROIpHttpWorker.SetTargetURL(const aValue: String);
begin

end;

procedure TROIpHttpWorker.SetUserAgent(const aValue: String);
begin
  fContext.Response.Headers.Values['User-Agent'] := aValue;

end;

initialization
  RegisterServerClass(TROIpHTTPServer);
finalization
  UnregisterServerClass(TROIpHTTPServer);
end.