unit uROIndyHTTPServer;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Indy 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}

{TODO: Do like in the webmodule. Save a pointer to the user's OnCOmmandGet and fire it }

interface

uses
  {$IFDEF REMOBJECTS_TRIAL}uROTrial,{$ENDIF}
  {$IFNDEF RemObjects_INDY8}IdCustomHTTPServer,{$ENDIF}
  {$IFDEF RemObjects_INDY10}IdContext, IdSocketHandle,{$ELSE}IdThreadMgr,{$ENDIF}
  Classes, uROServer, uROIndyTCPServer, IdTCPServer,
  IdHTTPServer, uROClientIntf;

type
  { TIndyHTTPTransport }
  TIndyHTTPTransport = class(TInterfacedObject, IROTransport, IROTCPTransport, IROHTTPTransport)
  private
    fRequestInfo: TIdHTTPRequestInfo;
    fResponseInfo : TIdHTTPResponseInfo;
    fOverriddenPathInfo : string;
  protected
    { IROHTTPTransport }
    procedure SetHeaders(const aName, aValue : string);
    function GetHeaders(const aName : string) : string;
    function GetContentType : string;
    procedure SetContentType(const aValue : string);
    function GetUserAgent : string;
    procedure SetUserAgent(const aValue : string);
    function GetTargetURL : string;
    procedure SetTargetURL(const aValue : string);

    function GetPathInfo : string;
    procedure SetPathInfo(const aValue: String);
    function GetQueryString : string;

    function GetLocation : string;

    { IROTransport }
    function GetTransportObject : TObject;
    function GetClientAddress : string;

  public
    constructor Create(aRequestInfo: TIdHTTPRequestInfo; aResponseInfo : TIdHTTPResponseInfo);

    property RequestInfo: TIdHTTPRequestInfo read fRequestInfo;
    property ResponseInfo : TIdHTTPResponseInfo read fResponseInfo;
  end;

  { TROIdHTTPServer }
  TROIdHTTPServer = class(TIdHTTPServer)
  private
    function GetActive: boolean;

  public
    procedure IndySetActive(Value : boolean);

  published
    property Active : boolean read GetActive;
  end;

  { TROIndyHTTPServer }
  TROIndyHTTPServer = class(TROCustomIndyTCPServer)
  private
    fServeRodl, fServeInfoPage: Boolean;
    fSendExceptionsAs500: boolean;
    function GetIndyServer: TROIdHTTPServer;

  protected
    procedure InternalServerCommandGet(AThread: TIdThreadClass;
      RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo); virtual;


    function CreateIndyServer : TComponent; override;
    procedure IntSetActive(const Value: boolean); override;
    function IntGetActive : boolean; override;

    function GetDispatchersClass : TROMessageDispatchersClass; override;

    function GetKeepAlive: boolean; override;
    procedure SetKeepAlive(const Value: boolean); override;

    function GetDisableNagle: boolean; override;
    procedure SetDisableNagle(const Value: boolean); override;

  public
    constructor Create(aComponent: TComponent); override;

  published
    property IndyServer : TROIdHTTPServer read GetIndyServer;
    property Port:Integer read GetPort write SetPort;
    property KeepAlive : boolean read GetKeepAlive write SetKeepAlive default false;
    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;
  end;

implementation

uses SysUtils, IdGlobal, uRORes, uROHTTPTools, uROHTTPDispatch, uROServerIntf,
  uROClient, uROHtmlServerInfo, uRODL;

{ TROIndyHTTPServer }
constructor TROIndyHTTPServer.Create(aComponent: TComponent);
begin
  inherited;
  fServeRodl := true;
  fServeInfoPage := true;
  fSendExceptionsAs500 := true;
end;

function TROIndyHTTPServer.CreateIndyServer: TComponent;
begin
  result := TROIdHTTPServer.Create(Self);//TIdHTTPServer.Create(Self);
  TROIdHTTPServer(result).OnCommandGet := InternalServerCommandGet;
  TROIdHTTPServer(result).DefaultPort := 8099;
end;

function TROIndyHTTPServer.IntGetActive: boolean;
begin
  result := GetIndyServer.Active
end;

procedure TROIndyHTTPServer.IntSetActive(const Value: boolean);
begin
  {$IFDEF RemObjects_INDY10B}
  if (Value) and (IndyServer.Bindings.Count = 0) then begin
    with IndyServer.Bindings.Add do begin
      Ip := '';
      Port := Self.Port;
      IPVersion := Id_IPv4;
    end;
  end;
  {$ENDIF}
  GetIndyServer.IndySetActive(Value);
  if not Value
    then IndyServer.Bindings.Clear;
end;

function TROIndyHTTPServer.GetIndyServer: TROIdHTTPServer;
begin
  //result := TROIdHTTPServer(inherited IndyServer);
  result := TObject(inherited IndyServer) as TROIdHTTPServer;
end;

procedure TROIndyHTTPServer.InternalServerCommandGet(AThread: TIdThreadClass;
  RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var req, resp : TStringStream;
    transport : IROHTTPTransport;
    ok : boolean;
    disp : TROHTTPDispatcher;
    root, sub, reqdata : string;
    lIgnore: TROResponseOptions;
    format: TDataFormat;
    info: IRONamedModuleInfo;
    lRodl: TRODLLibrary;
begin
  req := NIL;
  transport := TIndyHTTPTransport.Create(RequestInfo, ResponseInfo);

  resp := TStringStream.Create('');

  try
    {$IFDEF RemObjects_INDY8}
    req := TStringStream.Create(RequestInfo.UnparsedParams);
    {$ELSE}
    { This was introduced to support URLs with parameters for partial WSDLs.
      When a browser sends a URL such as "http://localhost:8099/SOAP?Service=TestService", Indy
      puts the value "Service=TestService" in the UnparsedParams. This is not what we want as we
      expect UnparsedParams as the data of the HTTP request. }
    if (RequestInfo.QueryParams=RequestInfo.UnparsedParams)
      then reqdata := ''
      else reqdata := RequestInfo.UnparsedParams;

    req := TStringStream.Create(reqdata);
    {$ENDIF}

    root := transport.PathInfo;
    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(Dispatchers).GetDispatcherByPath(root) as TROHTTPDispatcher;

    if disp <> nil then
    begin
      if (req.Size = 0) then begin
        ok := fServeRodl;
        if ok then
          ok := IntDispatchMessage(disp, transport, req, resp, lIgnore)
        else
          resp.WriteString('<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher);
      end else if (sub = '')  then
        ok := IntDispatchMessage(disp, transport, req, resp, lIgnore)
      else if (CompareText(sub, 'rodl') = 0) and fServeRodl then
      begin
        if copy(disp.PathInfo, 1, 1) = '/' then transport.PathInfo := disp.PathInfo else transport.PathInfo := '/'+disp.PathInfo;
        GetRodl(resp, transport, format, GetRODLReader);
        ResponseInfo.ContentType := format;
        ok := true;
      end else if Supports(disp.Message, IRONamedModuleInfo, info) and (CompareText(info.ModuleInfoName, sub) = 0) and fServeRodl then
      begin
        if copy(disp.PathInfo, 1, 1) = '/' then transport.PathInfo := disp.PathInfo else transport.PathInfo := '/'+disp.PathInfo;
        info.GetModuleInfo(resp, transport, format);
        ResponseInfo.ContentType := format;
        ok := true;
      end else
      begin
        ok := IntDispatchMessage(disp, transport, req, resp, lIgnore)
      end;
    end else if (CompareText(root, '/rodl') = 0) and (sub = '') and fServeRodl then
    begin
      GetRodl(resp, transport, format, GetRODLReader);
      ok := true;
    end else if fServeInfoPage and (CompareText(root, '/doc') = 0) then
    begin
      if sub = 'css' then
      begin
        resp.Writestring(GetRodlCss);
        ResponseInfo.ContentType := 'text/css';
        ok := true;
      end else
      if sub = 'xslt' then
      begin
        resp.WriteString(GetRodlStyleSheet);
        ResponseInfo.ContentType := 'text/xml';
        ok := true;
      end else if sub = '' then
      begin
        lRodl := GetRodlLibrary(GetRODLReader);
        try
          ResponseInfo.ContentType := 'text/xml';
          resp.WriteString(GetRodlWithStyleSheet(lRodl, '/doc/xslt'));
        finally
          lRodl.Free;
        end;
        ok := true;
      end else
      begin
        resp.WriteString('<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher);
        ok := false;
      end;
    end else if fServeInfoPage and (CompareStr(root, '/favicon.ico') = 0) then
    begin
      GetRodlFavIcon(resp);
      ResponseInfo.ContentType := 'image/x-icon';
      ok := true;
    end else if fServeInfoPage and (root = '/') then
    begin
      lrodl := GetRodlLibrary(GetRODLReader);
      try
        resp.WriteString(GetRodlServerInfo('/', lRodl, Dispatchers));
      finally
        lRodl.Free;
      end;
      ok := true;
    end else
    begin
      resp.WriteString('<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher);
      ok := false;
    end;

    if ok or not fSendExceptionsAs500 then
      ResponseInfo.ResponseNo := HTTP_OK
    else
      ResponseInfo.ResponseNo := HTTP_FAILED;

    ResponseInfo.ContentText := resp.DataString;
  finally
    req.Free;
    resp.Free;
  end;
end;


function TROIndyHTTPServer.GetDispatchersClass : TROMessageDispatchersClass; 
begin
  result := TROHTTPMessageDispatchers
end;

function TROIndyHTTPServer.GetKeepAlive: Boolean;
begin
  {$IFDEF RemObjects_INDY8}
  Result := false;
  {$ELSE}
  Result := IndyServer.KeepAlive;
  {$ENDIF}
end;

procedure TROIndyHTTPServer.SetKeepAlive(const Value: Boolean);
begin
  {$IFDEF RemObjects_INDY8}
  // keepalive not supported on Indy 8
  {$ELSE}
  IndyServer.KeepAlive := Value;
  {$ENDIF}
end;

function TROIndyHTTPServer.GetDisableNagle: boolean;
begin
  result := FALSE;
end;

procedure TROIndyHTTPServer.SetDisableNagle(const Value: boolean);
begin
  // Not supported in the HTTP channels
end;

{ TIndyHTTPTransport }

constructor TIndyHTTPTransport.Create(
  aRequestInfo: TIdHTTPRequestInfo; aResponseInfo: TIdHTTPResponseInfo);
begin
  inherited Create;
  fRequestInfo := aRequestInfo;
  fResponseInfo := aResponseInfo;
end;

function TIndyHTTPTransport.GetClientAddress: string;
begin
  result := fRequestInfo.RemoteIP;
end;

function TIndyHTTPTransport.GetContentType: string;
begin
  result := fResponseInfo.ContentType;
end;

function TIndyHTTPTransport.GetHeaders(const aName: string): string;
begin
  {$IFDEF RemObjects_INDY8}
  result := GetHeaderValue(fRequestInfo.Headers, aName);
  {$ELSE}
  result := GetHeaderValue(fRequestInfo.RawHeaders, aName);
  {$ENDIF}
end;

function TIndyHTTPTransport.GetPathInfo: string;
begin
  if fOverriddenPathInfo <> '' then
    result := fOverriddenPathInfo
  else
    result := RequestInfo.Document
end;

function TIndyHTTPTransport.GetLocation: string;
begin
  result := 'http://'+fRequestInfo.Host
end;

function TIndyHTTPTransport.GetTargetURL: string;
begin
  result := ''
end;

function TIndyHTTPTransport.GetTransportObject: TObject;
begin
  result := Self;
end;

function TIndyHTTPTransport.GetUserAgent: string;
begin
  result := str_ProductName
end;

procedure TIndyHTTPTransport.SetContentType(const aValue: string);
begin
  fResponseInfo.ContentType := aValue
end;

procedure TIndyHTTPTransport.SetHeaders(const aName,
  aValue: string);
begin
  {$IFDEF RemObjects_INDY8}
  SetHeaderValue(fResponseInfo.Headers, aName, aValue);
  {$ELSE}
  SetHeaderValue(fResponseInfo.RawHeaders, aName, aValue);
  {$ENDIF}
end;

procedure TIndyHTTPTransport.SetTargetURL(const aValue: string);
begin

end;

procedure TIndyHTTPTransport.SetUserAgent(const aValue: string);
begin
  fResponseInfo.ServerSoftware := str_ProductName
end;

function TIndyHTTPTransport.GetQueryString: string;
begin
  {$IFDEF RemObjects_INDY8}
  result := '';
  {$ELSE}
  result := fRequestInfo.QueryParams;
  {$ENDIF}
end;

procedure TIndyHTTPTransport.SetPathInfo(const aValue: String);
begin
  fOverriddenPathInfo := aValue;
end;

{ TROIdHTTPServer }

function TROIdHTTPServer.GetActive: boolean;
begin
  result := inherited Active
end;

procedure TROIdHTTPServer.IndySetActive(Value: boolean);
begin
  inherited Active := Value
end;

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