unit uROWebBrokerServer;

{----------------------------------------------------------------------------}
{ RemObjects SDK Library - Core Library                                      }
{                                                                            }
{ 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, HTTPApp, uROClientIntf, uROServer, uROHTTPTools;

type
  { TROWebBrokerServer }
  TROWebBrokerServer = class(TROServer, IROTransport, IROTCPTransport, IROHTTPTransport)
  private
    fUserBeforeDispatch : THTTPMethodEvent;
    fActions : TWebActionItems;

    fActive : boolean;
    fTransportIntf : IROHTTPTransport;

    fRequest : TWebRequest;
    fResponse : TWebResponse;
    fSendExceptionsAs500: boolean;
    fOverridePathInfo : string;
    fServeInfoPage: Boolean;
    fServeRodl: Boolean;

    
    fOnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod;
    fSendClientAccessPolicyXml: TROClientAccessPolicyType;

    function ReadRequestStream(aRequest : TWebRequest): TStream;
    function GetRequest: TWebRequest;
    function GetResponse: TWebResponse;
    function IsWebModuleAction(const aPathInfo: ansistring) : boolean;

  protected
    procedure ReplaceBeforeDispatch(aOwner : TComponent; aNewHandler : THTTPMethodEvent); virtual;

    function GetDispatchersClass : TROMessageDispatchersClass; override;

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

    { IROTransport }
    function GetTransportObject : TObject;

    { IROTCPTransport }
    function GetClientAddress : string;

    { 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 GetLocation : string;
    function GetQueryString : string;
    function GetQueryParameter(const aName: String): String;
  public
    constructor Create(aOwner : TComponent); override;
    destructor Destroy; override;

    property Request : TWebRequest read GetRequest;
    property Response : TWebResponse read GetResponse;

  published
    procedure IntOnBeforeDispatch(Sender: TObject;
                                  Request: TWebRequest;
                                  Response: TWebResponse; var Handled: Boolean); virtual;
    property SendExceptionsAs500: boolean read fSendExceptionsAs500 write fSendExceptionsAs500 default true;
    property ServeInfoPage : Boolean read fServeInfoPage write fServeInfoPage default true;
    property ServeRodl : Boolean read fServeRodl write fServeRodl default true;
    property OnGetRODLReader;
    property OnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod read fOnGetCustomClientAccessPolicy write fOnGetCustomClientAccessPolicy;
    property SendClientAccessPolicyXml: TROClientAccessPolicyType read fSendClientAccessPolicyXml write fSendClientAccessPolicyXml default captAllowNone;
  end;

implementation

uses TypInfo, uRORes,  SysUtils, {$IFDEF DELPHI2009UP}AnsiStrings,{$ENDIF}uROHTTPDispatch, uROServerIntf,
  uROClient, uROHtmlServerInfo, uRODL, uROClasses;

type
  // See TROWebBrokerServer.Loaded This is for EWF support.
  IInterfaceComponentReference = interface
    ['{E28B1858-EC86-4559-8FCD-6B4F824151ED}']
    function GetComponent: TComponent;
  end;

{ TROWebBrokerServer }

constructor TROWebBrokerServer.Create(aOwner: TComponent);
begin
  inherited;

  fActive := TRUE;
  fActions := NIL;
  fServeInfoPage := true;
  fServeRodl := true;
  fSendExceptionsAs500 := true;
  Supports(Self, IROTransport, fTransportIntf);
end;

destructor TROWebBrokerServer.Destroy;
begin
  fTransportIntf := NIL;

  inherited;
end;

procedure TROWebBrokerServer.Loaded;
var dispatchactions : IUnknown;
    icref : IInterfaceComponentReference;
begin
  inherited;

  if not (csDesigning in ComponentState) then begin
    ReplaceBeforeDispatch(Owner, IntOnBeforeDispatch);

    if Owner is TWebModule
      then fActions := TWebActionItems(GetObjectProp(Owner, 'Actions'))
      else try
        { This is for EWF. I don't want to set a dependency to the EWF units.
          This component has to stay WebBroker and EWF neutral since, in the end, we are
          dealing with web broker actions. This solves the problem. }

        {$IFDEF DELPHI6UP}
        if IsPublishedProp(Owner, 'DispatchActions')
          then dispatchactions := GetInterfaceProp(Owner, 'DispatchActions')
          else Exit;
        {$ENDIF DELPHI6UP}

        if (dispatchactions<>NIL) then begin
          if Supports(dispatchactions, IInterfaceComponentReference, icref) then begin
            fActions := TWebActionItems(GetObjectProp(icref.GetComponent, 'Actions'));
          end;
        end;
      except
        //ToDo: do we really want to catch this exception and display a DIAOG??
        on E:Exception do begin
          //showmessage(e.message);
          fActions := NIL;
        end;
      end;
  end;
end;

function TROWebBrokerServer.IntGetActive: boolean;
begin
  result := fActive;
end;

procedure TROWebBrokerServer.IntSetActive(const Value: boolean);
begin
  fActive := Value;
end;

function TROWebBrokerServer.ReadRequestStream(aRequest : TWebRequest): TStream;
var s : ansistring;
    t : ansistring;
    i : integer;
begin
  s := {$IFDEF DELPHI2009UP}aRequest.RawContent{$ELSE}aRequest.Content{$ENDIF};
  i := aRequest.ContentLength-Length(s);

  while (i>0) do begin
    t := aRequest.ReadString(I);
    s := S+T;
    i := i-Length(t);
  end;

  result := TROBinaryMemoryStream.Create(s);
end;

function TROWebBrokerServer.IsWebModuleAction(const aPathInfo: ansistring) : boolean;
var
  i : integer;
  lpathinfo : string;
begin
  result := FALSE;
  if (fActions=NIL) then Exit;
  lpathinfo := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(aPathInfo);
  for i := 0 to (fActions.Count-1) do
    if (CompareText(fActions[i].PathInfo, lPathInfo)=0) then begin
      result := TRUE;
      Exit;
    end;
end;

procedure TROWebBrokerServer.IntOnBeforeDispatch(Sender: TObject;
  Request: TWebRequest; Response: TWebResponse; var Handled: Boolean);

  procedure WriteError(responsestream : TROBinaryMemoryStream);
  begin
    responsestream.WriteAnsiString('<font size="7">500 Invalid Path</font><br />'+{$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(err_CannotFindMessageDispatcher));
  end;

var requeststream : TStream;
    responsestream : TROBinaryMemoryStream;
    root: ansistring;
    sub : string;
    disp: TROHTTPDispatcher;
    lIgnore: TROResponseOptions;
    format: TDataFormat;
    info: IRONamedModuleInfo;
    ok : boolean;
    lRodl: TRODLLibrary;
    lPolicyContent: AnsiString;
begin
  requeststream := NIL;
  responsestream := NIL;

  fRequest := Request;
  fResponse := Response;
  ok := false;
  // Executes the user's event handler
  if Assigned(fUserBeforeDispatch)
    then fUserBeforeDispatch(Sender, Request, Response, Handled);

  // Processes the message if not handled already
  root := request.PathInfo;
  if not Handled and not IsWebModuleAction(root) then begin
    try
      responsestream := TROBinaryMemoryStream.Create;
      requeststream := ReadRequestStream(Request);

      if (root <> '') and (root[1] = '/') then delete(root, 1,1);
      if pos(AnsiChar('/'), root) > 0 then
      begin
        sub :={$IFDEF UNICODE}AnsiStringToWideString{$ENDIF} (copy(root, pos(AnsiChar('/'), root)+1, maxint));
        root := '/' + copy(root, 1, pos(AnsiChar('/'), root) - 1);
      end else
      begin
        root := '/' + root;
        sub := '';
      end;

      disp := TROHTTPMessageDispatchers(Dispatchers).GetDispatcherByPath({$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(root)) as TROHTTPDispatcher;

      if disp <> nil then
      begin
        if (requeststream.Size = 0) then begin
          ok := fServeRodl;
          if ok then
            ok := IntDispatchMessage(disp, fTransportIntf, requeststream, responsestream, lIgnore)
          else
            WriteError(responsestream);
        end else if (sub = '')  then
          ok := IntDispatchMessage(disp, fTransportIntf, requeststream, responsestream, lIgnore)
        else if (CompareText(sub, 'rodl') = 0) and fServeRodl then
        begin
          if copy(disp.PathInfo, 1, 1) = '/' then fTransportIntf.PathInfo := disp.PathInfo else fTransportIntf.PathInfo := '/'+disp.PathInfo;
          GetRodl(responsestream, fTransportIntf, format, GetRODLReader);
          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 fTransportIntf.PathInfo := disp.PathInfo else fTransportIntf.PathInfo := '/'+disp.PathInfo;
          info.GetModuleInfo(responsestream, fTransportIntf, format);
          ok := true;
        end else
        begin
          ok := IntDispatchMessage(disp, fTransportIntf, requeststream, responsestream, lIgnore)
        end;
      end else if (CompareText(root, AnsiString('/rodl')) = 0) and (sub = '') and fServeRodl then
      begin
        GetRodl(responsestream, fTransportIntf, format, GetRODLReader);
        ok := true;
      end else if fServeInfoPage and (CompareText(root, AnsiString('/doc')) = 0) then
      begin
        if sub = 'css' then
        begin
          responsestream.WriteAnsistring(GetRodlCss);
          Response.ContentType := 'text/css';
          ok := true;
        end else
        if sub = 'xslt' then
        begin
          responsestream.WriteAnsiString(GetRodlStyleSheet);
          Response.ContentType := 'text/xml';
          ok := true;
        end else if sub = '' then
        begin
          lRodl := GetRodlLibrary(GetRODLReader);
          try
            Response.ContentType := 'text/xml';
            responsestream.WriteAnsiString(GetRodlWithStyleSheet(lRodl, {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.ScriptName) + '/doc/xslt'));
          finally
            lRodl.Free;
          end;
          ok := true;
        end else
        begin
          WriteError(responsestream);
          ok := false;
        end;
      end else if fServeInfoPage and (CompareStr(root, AnsiString('/favicon.ico')) = 0) then
      begin
        GetRodlFavIcon(responsestream);
        Response.ContentType := 'image/x-icon';
        ok := true;
      end else if fServeInfoPage and (root = '/') then
      begin
        lrodl := GetRodlLibrary(GetRODLReader);
        try
          responsestream.WriteAnsiString(GetRodlServerInfo({$IFDEF UNICODE}UTF8ToString{$ENDIF}(fRequest.ScriptName), lRodl, Dispatchers));
        finally
          lRodl.Free;
        end;
        ok := true;
      end else
      if CompareText(root, AnsiString('/clientaccesspolicy.xml')) = 0 then begin
        case fSendClientAccessPolicyXml of
          captAllowAll: begin
            lPolicyContent := GetClientAccessPolicy;
          end;
          captCustom: begin
            if Assigned(fOnGetCustomClientAccessPolicy) then
              fOnGetCustomClientAccessPolicy(Self, lPolicyContent);
          end;
        end;
        if lPolicyContent <> '' then begin
          Response.ContentType := 'text/xml';
          responsestream.WriteAnsiString(lPolicyContent);
        end;
      end  else
      begin
        WriteError(responsestream);
        ok := false;
      end;

      if ok or not fSendExceptionsAs500 then
        Response.StatusCode := HTTP_OK
      else
        Response.StatusCode := HTTP_FAILED;

    finally
      requeststream.Free;
      Handled := TRUE;

      responsestream.Position := 0;
      Response.ContentStream := responsestream;
    end;
  end;
end;

function TROWebBrokerServer.GetRequest: TWebRequest;
begin
  result := fRequest;
end;

function TROWebBrokerServer.GetResponse: TWebResponse;
begin
  result := fResponse;
end;

function TROWebBrokerServer.GetClientAddress: string;
begin
  result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.RemoteAddr);
end;

function TROWebBrokerServer.GetContentType: string;
begin
  result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Response.ContentType)
end;

function TROWebBrokerServer.GetHeaders(const aName: string): string;
begin
  Result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Request.GetFieldByName({$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(aName)));
end;

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

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

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

procedure TROWebBrokerServer.SetContentType(const aValue: string);
begin
  Response.ContentType :={$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(aValue);
end;

procedure TROWebBrokerServer.SetHeaders(const aName, aValue: string);
begin
  SetHeaderValue(Response.CustomHeaders, aName, aValue);
end;

procedure TROWebBrokerServer.SetPathInfo(const aValue: string);
begin
  fOverridePathInfo := aValue;
  // ignore?
end;

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

end;

procedure TROWebBrokerServer.SetUserAgent(const aValue: string);
begin
  
end;

procedure TROWebBrokerServer.ReplaceBeforeDispatch(aOwner: TComponent;
  aNewHandler: THTTPMethodEvent);
// Do not change the sequance of these names. It's important for EWF.
const EventHandlerNames : array[0..1] of string = ('OnBeforeDispatch', 'BeforeDispatch');
var pinfo : PPropInfo;
    i     : integer;
    myevent : THTTPMethodEvent;
    mtd,
    mtd2  : TMethod;
    s     : string;
begin
  for i := 0 to High(EventHandlerNames) do begin
    s := EventHandlerNames[i];
    pinfo := GetPropInfo(Owner, s);

    if (pinfo<>NIL) then begin
      myevent := IntOnBeforeDispatch;
      mtd := TMethod(myevent);  // <--- I have to pass through a local variable. Cannot type caet directly... Go figure!

      mtd2 := GetMethodProp(Owner, pinfo);
      SetMethodProp(Owner, pinfo, mtd);

      TMethod(fUserBeforeDispatch) := mtd2;
      Exit;
    end;
  end;
  //TWebModule(aOwner).BeforeDispatch := aNewHandler;
end;

function TROWebBrokerServer.GetPathInfo: string;
begin
  if fOverridePathInfo <> '' then
    result := fOverridePathInfo
  else
    result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Request.PathInfo)
end;

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

function TROWebBrokerServer.GetLocation: string;
begin
  result := 'http://'+{$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.Host+fRequest.URL);
end;

function TROWebBrokerServer.GetQueryString: string;
begin
  result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fRequest.Query);
end;

function TROWebBrokerServer.GetQueryParameter(const aName: String): String;
begin
  result := fRequest.QueryFields.Values[aName];
end;

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