unit uROBPDXHTTPServer;

{----------------------------------------------------------------------------}
{ 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, uROServer, uROClientIntf, uROBPDXTCPServer, uROHTTPTools,
     {$IFDEF RemObjects_USE_RODX}
     uRODXString, uRODXServerCore, uRODXSock, uRODXHTTPServerCore, uRODXHTTPHeaderTools;
     {$ELSE}
     DXString, DXServerCore, DXSock, DXHTTPServerCore, DXHTTPHeaderTools;
     {$ENDIF}

type
  { TROBPDXHTTPTransport }
  TROBPDXHTTPTransport = class(TInterfacedObject, IROTransport, IROTCPTransport, IROHTTPTransport)
  private
    fResponseHeaders : TStringList;

    fClientThread: TDXClientThread;
    fHeaderInfo: PHeaderInfo;
    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;
    function GetLocation : string;
    function GetQueryString : string;
    function GetQueryParameter(const aName: string): string;
    procedure SetPathInfo(const aValue: String);

    { IROTransport }
    function GetTransportObject : TObject;
    function GetClientAddress : string;
  public
    constructor Create(aClientThread: TDXClientThread; aHeaderInfo: PHeaderInfo);
    destructor Destroy; override;

    property ClientThread: TDXClientThread read fClientThread;
    property HeaderInfo: PHeaderInfo read fHeaderInfo;
  end;

  { TROBPDXHTTPServer }
  TROBPDXHTTPServer = class(TROBPDXTCPServer)
  private
    fServeInfoPage, fServeRodl: Boolean;
    fSendExceptionsAs500: boolean;
    fDisableNagle:  Boolean;
    fOnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod;
    fSendClientAccessPolicyXml: TROClientAccessPolicyType;
    function GetBPDXServer: TDXHTTPServerCore;
    function GetSupportKeepAlive: Boolean;
    procedure SetSupportKeepAlive(const Value: Boolean);

  protected
    function CreateBPDXServer : TDXServerCore; override;

    function BuildResponseHeader(StatusCode:Integer;var EnableKeepAlive : Boolean) : Ansistring;
    procedure CleanupNetscapeAndProxyRequests(HeaderInfo:PHeaderInfo);

    procedure InternalOnNewConnect(ClientThread:TDXClientThread);
    procedure InternalHandleSession(ClientThread: TDXClientThread; HeaderInfo: PHeaderInfo; var EnableKeepAlive: boolean);

    function GetDispatchersClass : TROMessageDispatchersClass; override;
  public
    constructor Create(aOwner: TComponent); override;

  published
    property BPDXServer: TDXHTTPServerCore read GetBPDXServer;
    property DisableNagle: Boolean read fDisableNagle write fDisableNagle default True;
    property SupportKeepAlive: Boolean read GetSupportKeepAlive write SetSupportKeepAlive;
    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 OnGetCustomClientAccessPolicy: TROCustomClientAccessPolicyMethod read fOnGetCustomClientAccessPolicy write fOnGetCustomClientAccessPolicy;
    property SendClientAccessPolicyXml: TROClientAccessPolicyType read fSendClientAccessPolicyXml write fSendClientAccessPolicyXml default captAllowNone;
  end;

implementation

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

constructor TROBPDXHTTPTransport.Create(aClientThread: TDXClientThread; aHeaderInfo: PHeaderInfo);
begin
  inherited Create;
  fResponseHeaders := TStringList.Create;
  fClientThread := aClientThread;
  fHeaderInfo := aHeaderInfo;
end;

destructor TROBPDXHTTPTransport.Destroy;
begin
  fResponseHeaders.Free;

  inherited;
end;

procedure TROBPDXHTTPTransport.SetHeaders(const aName, aValue : string);
begin
  SetHeaderValue(fResponseHeaders, aName, aValue);
end;

function TROBPDXHTTPTransport.GetHeaders(const aName : string) : string;
var
  s: string;
  lPos: Integer;
  s1: string;
begin
  s1:={$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fHeaderInfo.Unknown);
  lPos := Pos(#13#10+aName+'=',s1 );
  if lPos = 0 then begin
    result := '';
    exit;
  end;
  s := Copy(s1, lPos + 2, MaxInt);
  s := copy(s,1,pos(#13#10, s)-1);
  s := copy(s,pos('=', s)+1, MaxInt);
  result := s;
end;

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

procedure TROBPDXHTTPTransport.SetContentType(const aValue : string);
begin
  SetHeaders(id_ContentType, aValue);
end;

function TROBPDXHTTPTransport.GetUserAgent : string;
begin
  result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fHeaderInfo.UserAgent)
end;

procedure TROBPDXHTTPTransport.SetUserAgent(const aValue : string);
begin
  SetHeaders(id_UserAgent, aValue);
end;

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

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

end;

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

function TROBPDXHTTPTransport.GetClientAddress : string;
begin
  result  :=  {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fClientThread.Socket.PeerIPAddress);
end;

function TROBPDXHTTPTransport.GetPathInfo : string;
var
  r: AnsiString;
begin
  if fOverriddenPathInfo <> '' then
    result := fOverriddenPathInfo
  else begin
    r := StringReplace(fHeaderInfo^.URI, AnsiString('http://'), AnsiString(''), []);
    result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(Copy(r, Pos(AnsiChar('/'), r), MaxInt));
  end;
end;

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

{ TROBPDXHTTPServer }
function TROBPDXHTTPServer.GetBPDXServer: TDXHTTPServerCore;
begin
  result := TDXHTTPServerCore(inherited BPDXServer);
end;

function TROBPDXHTTPServer.CreateBPDXServer: TDXServerCore;
begin
  //DXSock.TDXXferTimeout := 100;
  result  :=  TDXHTTPServerCore.Create(Self);

  with TDXHTTPServerCore(result) do begin
    ServerPort  :=  8099;
    BindTo  :=  ''; // blank = ALL IP's!
    Timeout  :=  50000; // 50 seconds for initial header
    ThreadCacheSize  :=  10;
    SocketOutputBufferSize  :=  bsfHuge;

    // Optimized settings
    {$IFDEF MSWINDOWS}
    ListenerThreadPriority := tpIdle;
    SpawnedThreadPriority := tpIdle;
    {$ENDIF}
    SocketOutputBufferSize := bsfNormal;
    UseThreadPool := FALSE;
    SupportKeepAlive  :=  FALSE;

    OnNewConnect  :=  InternalOnNewConnect;
    OnCommandGET  :=  InternalHandleSession;
    OnCommandPOST  :=  InternalHandleSession;
    OnCommandHEAD  :=  InternalHandleSession;
  end;
end;

function TROBPDXHTTPServer.BuildResponseHeader(StatusCode:Integer;var EnableKeepAlive : Boolean) : Ansistring;
begin
   Result := AnsiString('HTTP/1.1 ')+BPDXServer.HeaderText(StatusCode)+AnsiString(#13#10+
      'Server: RemObjects DXSock Web Server v1.0'+#13#10+
      'Date: ')+{DXString.}DateTimeToGMTRFC822(Now)+AnsiString(#13#10+
      'MIME-Version: 1.0'+#13#10+
      'Public: GET,POST,HEAD,TRACE'+#13#10+
      'Accept-Ranges: none'+#13#10);
   if StatusCode<>200 then begin
      Result := Result+
         AnsiString('Pragma: no-cache'+#13#10+
                    'Cache-Control: no-cache'+#13#10);
      EnableKeepAlive := False;
   end;
   if EnableKeepAlive then begin
      Result := Result+AnsiString('Connection: Keep-Alive'+#13#10+
         'Keep-Alive: timeout=')+Ansi_IntToStr((BPDXServer.Timeout div 1000))+AnsiString(#13#10);
   End
   else begin
      Result := Result+AnsiString('Connection: close'+#13#10);
   end;
end;

Procedure TROBPDXHTTPServer.CleanupNetscapeAndProxyRequests(HeaderInfo:PHeaderInfo);
Var
   Ws:AnsiString;
   p: integer;
begin
   p:= Pos(AnsiString('://'),HeaderInfo^.Raw);
   if (p>0) and (p<10) then begin
      Ws := Copy(HeaderInfo^.RAW,1,Pos(AnsiChar(#32),HeaderInfo^.RAW));
      Delete(HeaderInfo^.RAW,1,p+2);
      p := Pos(AnsiChar('/'),HeaderInfo^.RAW);
      if p = 0 then
        HeaderInfo^.RAW := AnsiString('/ HTTP/1.1')
      else
        Delete(HeaderInfo^.RAW,1,p-1);
      HeaderInfo^.RAW := Ws+HeaderInfo^.RAW;
   end;
end;

procedure TROBPDXHTTPServer.InternalOnNewConnect(ClientThread:TDXClientThread);
begin
//  ClientThread.Socket.SetNagle(False);
  if fDisableNagle then
    ClientThread.Socket.SetNagle(True);
  BPDXServer.ProcessSession(ClientThread); // tell server to handle connection
end;

procedure TROBPDXHTTPServer.InternalHandleSession(ClientThread: TDXClientThread; HeaderInfo: PHeaderInfo; var EnableKeepAlive: boolean);

  function GetError: ansistring;
  begin
    Result := AnsiString('<font size="7">500 Invalid Path</font><br />')+
              {$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(err_CannotFindMessageDispatcher);
  end;

Var
   StatusCode:Integer; // you set this!
   req : TMemoryStream;
   resp:TMemoryStream; // you set this!
   transport : IROHTTPTransport;
   HeaderStr:ansiString;
   disp : TROHTTPDispatcher;
   s: Ansistring;
    root, sub : string;
   lIgnore: TROResponseOptions;
   format: TDataFormat;
   info: IRONamedModuleInfo;
   lRodl: TRodlLibrary;
   ok: Boolean;
   lPolicyContent: AnsiString;
begin
  req  := NIL;
  resp := NIL;
  ok := false;
  // if POST then collect the post data!
  if HeaderInfo^.Method='POST' then begin // collect post data!
    if HeaderInfo^.ContentLength=0 then begin // HACKER!!
      ClientThread.Socket.Writeln(BuildResponseHeader(411,EnableKeepAlive));
      Exit;
    end;

    while Length(HeaderInfo^.PostData)<HeaderInfo^.ContentLength do begin
      HeaderInfo^.PostData  :=  HeaderInfo^.PostData+
                                ClientThread.Socket.ReadStr(HeaderInfo^.ContentLength-Length(HeaderInfo^.PostData));
      if ClientThread.Socket.DroppedConnection then begin // connection aborted!
        EnableKeepAlive := False;
        Exit;
      end;
    end;
  end;

  // now we handle the request!
  CleanupNetscapeAndProxyRequests(HeaderInfo);
  if HeaderInfo^.URI='' then HeaderInfo^.URI := AnsiChar('/'); // fix old Netscape!

  try
    req := TROBinaryMemoryStream.Create(HeaderInfo^.PostData);
    resp := TROBinaryMemoryStream.Create;
    transport  :=  TROBPDXHTTPTransport.Create(ClientThread, HeaderInfo);

    { make sure you set the:
        StatusCode to the result you want to send!
        resp - is the page body, xml, html, etc.
        MimeType - is the Content-Type: <value_only> e.g. text/html }

    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 begin
          s := GetError;
          resp.Write(s[1], length(s));
        end;
      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);
        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);
        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
        s := GetRodlCss;
        resp.Write(s[1], length(s));
        transport.ContentType := 'text/css';
        ok := true;
      end else
      if sub = 'xslt' then
      begin
        s := GetRodlStyleSheet;
        resp.Write(s[1], length(s));
        transport.ContentType := 'text/xml';
        ok := true;
      end else if sub = '' then
      begin
        lRodl := GetRodlLibrary(GetRODLReader);
        try
          s := GetRodlWithStyleSheet(lRodl, '/doc/xslt');
          resp.Write(s[1], length(s));
          transport.ContentType := 'text/xml';
        finally
          lRodl.Free;
        end;
        ok := true;
      end else
      begin
        s := GetError;
        resp.Write(s[1], length(s));
        ok := false;
      end;
    end else if fServeInfoPage and (CompareStr(root, '/favicon.ico') = 0) then
    begin
      GetRodlFavIcon(resp);
      transport.ContentType := 'image/x-icon';
      ok := true;
    end else if fServeInfoPage and (root = '/') then
    begin
      lrodl := GetRodlLibrary(GetRODLReader);
      try
        s := GetRodlServerInfo(transport.PathInfo, lRodl, Dispatchers);
        resp.Write(s[1], length(s));
      finally
        lRodl.Free;
      end;
      ok := true;
    end else
    if CompareText(root, '/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
        transport.ContentType := 'text/xml';
        resp.Write(lPolicyContent[1], Length(lPolicyContent));
      end;
    end  else
    begin
      s := GetError;
      resp.Write(s[1], length(s));
      ok := false;
    end;

    if ok or (not fSendExceptionsAs500) then
      StatusCode:= HTTP_OK
    else
      StatusCode := HTTP_FAILED;

    HeaderStr := BuildResponseHeader(StatusCode,EnableKeepAlive)+
       id_UserAgent+': '+str_ProductName+#13#10+
       id_ContentLength+': '+Ansi_IntToStr(resp.Size)+#13#10+
       id_ContentType+': '+{$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(transport.Headers[id_ContentType])+#13#10;

    ClientThread.Socket.Writeln(HeaderStr);

    if (HeaderInfo^.Method<>'HEAD') and (resp.Size>0) then begin
      {$IFDEF VER100}
      ClientThread.Socket.BlockWrite(resp.Memory,resp.Size);
      {$ELSE}
      ClientThread.Socket.Write(resp.Memory,resp.Size);
      {$ENDIF}
    end;
  finally
    req.Free;
    resp.Free;
  end;
end;

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


function TROBPDXHTTPServer.GetSupportKeepAlive: Boolean;
begin
  Result := BPDXServer.SupportKeepAlive;
end;

procedure TROBPDXHTTPServer.SetSupportKeepAlive(const Value: Boolean);
begin
  BPDXServer.SupportKeepAlive := Value;
end;

function TROBPDXHTTPTransport.GetQueryString: string;
begin
  result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(fHeaderInfo^.QueryString)
end;

constructor TROBPDXHTTPServer.Create(aOwner: TComponent);
begin
  inherited;
  fServeInfoPage := true;
  fDisableNagle := true;
  fServeRodl := true;
  fSendExceptionsAs500 := true;
end;

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

function TROBPDXHTTPTransport.GetQueryParameter(
  const aName: string): string;
var
  s: Ansistring;
  i: Integer;
  lName: AnsiString;
begin
  lName := {$IFDEF UNICODE}WideStringToAnsiString{$ENDIF}(AName);
  s := fHeaderInfo^.QueryString;
  if Copy(s,1,length(lName)+1) = lName+'=' then begin
    Delete(s,1,Length(lname)+1);
  end else begin
    i := Pos('&' +lName+'=',s);
    if i = 0 then exit;
    Delete(s,1,i+Length(lName)+1);
  end;
  i := pos(AnsiChar('&'), s);
  if i > 0 then s:= copy(s,1,i-1);
  Result := {$IFDEF UNICODE}AnsiStringToWideString{$ENDIF}(EscapeDecode(s));
end;

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