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,
     {$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;
    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;
    function GetBPDXServer: TDXHTTPServerCore;
    function GetSupportKeepAlive: Boolean;
    procedure SetSupportKeepAlive(const Value: Boolean);

  protected
    function CreateBPDXServer : TDXServerCore; override;

    function BuildResponseHeader(StatusCode:Integer;var EnableKeepAlive : Boolean) : string;
    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 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;
  end;

implementation

uses SysUtils, uRORes, uROHTTPDispatch, uROHTTPTools, uROClient, uROServerIntf,
  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;
begin
  lPos := Pos(#13#10+aName+'=', fHeaderInfo.Unknown);
  if lPos = 0 then begin
    result := '';
    exit;
  end;
  s := Copy(fHeaderInfo.Unknown, 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 := fHeaderInfo.ContentType
end;

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

function TROBPDXHTTPTransport.GetUserAgent : string;
begin
  result := 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  :=  fClientThread.Socket.PeerIPAddress;
end;

function TROBPDXHTTPTransport.GetPathInfo : string;
begin
  if fOverriddenPathInfo <> '' then
    result := fOverriddenPathInfo
  else begin
    result := StringReplace(fHeaderInfo^.URI, 'http://', '', []);
    result := Copy(result, Pos('/', result), MaxInt);
  end;
end;

function TROBPDXHTTPTransport.GetLocation : string;
begin
  result := 'http://'+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
    {$IFNDEF LINUX}
    ListenerThreadPriority := tpIdle;
    SpawnedThreadPriority := tpIdle;
    {$ENDIF LINUX}
    SocketOutputBufferSize := bsfNormal;
    UseThreadPool := FALSE;
    SupportKeepAlive  :=  FALSE;

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

function TROBPDXHTTPServer.BuildResponseHeader(StatusCode:Integer;var EnableKeepAlive : Boolean) : string;
begin
   Result := 'HTTP/1.1 '+BPDXServer.HeaderText(StatusCode)+#13#10+
      'Server: RemObjects DXSock Web Server v1.0'+#13#10+
      'Date: '+{DXString.}DateTimeToGMTRFC822(Now)+#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+
         'Pragma: no-cache'+#13#10+
         'Cache-Control: no-cache'+#13#10;
      EnableKeepAlive := False;
   end;
   if EnableKeepAlive then begin
      Result := Result+'Connection: Keep-Alive'+#13#10+
         'Keep-Alive: timeout='+IntToStr((BPDXServer.Timeout div 1000))+#13#10;
   End
   else begin
      Result := Result+'Connection: close'+#13#10;
   end;
end;

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

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

procedure TROBPDXHTTPServer.InternalHandleSession(ClientThread: TDXClientThread; HeaderInfo: PHeaderInfo; var EnableKeepAlive: boolean);
Var
   StatusCode:Integer; // you set this!
   req : TStringStream;
   resp:TMemoryStream; // you set this!
   transport : IROHTTPTransport;
   HeaderStr:String;
   disp : TROHTTPDispatcher;
   s, root, sub : string;
   lIgnore: TROResponseOptions;
   format: TDataFormat;
   info: IRONamedModuleInfo;
   lRodl: TRodlLibrary;
   ok: Boolean;
begin
  req  := NIL;
  resp := NIL;

  // 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 := '/'; // fix old Netscape!

  try
    req  :=  TStringStream.Create(HeaderInfo^.PostData);
    resp := TMemoryStream.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 := '<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
          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 := '<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
        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
    begin
      s := '<font size="7">500 Invalid Path</font><br />'+err_CannotFindMessageDispatcher;
      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+': '+IntToStr(resp.Size)+#13#10+
       id_ContentType+': '+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 := fHeaderInfo^.QueryString
end;

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

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

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