{*******************************************************}
{                                                       }
{  Responsive Software     http://www.responsive.co.nz  }
{                                                       }
{  Copyright (c) 2003-2006 Responsive Software Limited  }
{                                                       }
{*******************************************************}

unit HTTPServerCommunicatorUnit;

interface

uses
  Classes, ScktComp, SyncObjs;

type
  THTTPServerCommunicator = class;

  // this class is used to service HTTP requests when running
  // in server mode
  // it assumes that there is a server communicator and uses this to
  // coordinate access to common resources with connected clients
  THTTPServerCommunicator = class
  private
    FServerSocket : TServerSocket;

    // page count
    FPageCount : integer;
    FPageCountLock : TCriticalSection;

    procedure GetThread
      (Sender : TObject;
       ClientSocket : TServerClientWinSocket;
       var SocketThread : TServerClientThread);
    procedure Log
      (Str : string);
  public
    constructor Create;
    destructor Destroy; override;

    function PageCount : integer;
    procedure IncrementPageCount;
  end;

  // this class is the thread spawned by the server socket
  // within the THTTPServerCommunicator class
  // there is one created for each new connection received
  THTTPConnectionThread = class(TServerClientThread)
  private
    FHTTPServerCommunicator : THTTPServerCommunicator;  // ref to THTTPServerCommunicator object which spawned this thread
    procedure Log
      (Str : string);
  public
    constructor Create
      (CreateSuspended: Boolean;
       ASocket: TServerClientWinSocket;
       HTTPServerCommunicator : THTTPServerCommunicator);
    procedure ClientExecute; override;
    procedure DoSynchronize
      (Method : TThreadMethod);
  end;

implementation

uses
  SysUtils, IBDatabase, DateUtils, 
  Globals, GeneralUtilities, Utilities,
  ServerCommunicatorUnit, HTTPResponder,
  Windows;

{***** THTTPServerCommunicator methods ********************************************}

constructor THTTPServerCommunicator.Create;
begin
  // create a single server socket
  FServerSocket := TServerSocket.Create(nil);
  FServerSocket.Port := GlobalConfiguration.HTTPPortNumber;
  // create separate thread for each connection
  FServerSocket.ServerType := stThreadBlocking;
  // increase the thread cache size
  FServerSocket.ThreadCacheSize := 20;
  // set event handler
  FServerSocket.OnGetThread := GetThread;
  // create thread control objects
  FPageCountLock := TCriticalSection.Create;
  // open the socket to listen for incoming connections
  FServerSocket.Active := true;
end;

destructor THTTPServerCommunicator.Destroy;
begin
  // close connections
  FServerSocket.Close;
  // destroy server socket
  FServerSocket.Free;
  // destroy thread control objects
  FPageCountLock.Free;
end;

procedure THTTPServerCommunicator.Log
  (Str : string);
begin
  if ServerLogging then
    MessageLog.Log(Str);
end;

procedure THTTPServerCommunicator.GetThread
  (Sender : TObject;
   ClientSocket : TServerClientWinSocket;
   var SocketThread : TServerClientThread);
begin
  // create new thread for connection on request
  SocketThread := THTTPConnectionThread.Create(false,ClientSocket,Self);
end;

function THTTPServerCommunicator.PageCount : integer;
begin
  FPageCountLock.Acquire;
  try
    Result := FPageCount;
  finally
    FPageCountLock.Release;
  end;
end;

procedure THTTPServerCommunicator.IncrementPageCount;
begin
  FPageCountLock.Acquire;
  try
    Inc(FPageCount);
  finally
    FPageCountLock.Release;
  end;
end;

{***** TConnectionThread methods **********************************************}

constructor THTTPConnectionThread.Create
  (CreateSuspended: Boolean;
   ASocket: TServerClientWinSocket;
   HTTPServerCommunicator : THTTPServerCommunicator);
begin
  FHTTPServerCommunicator := HTTPServerCommunicator;
  inherited Create(CreateSuspended,ASocket);
end;

procedure THTTPConnectionThread.Log
  (Str : string);
begin
  FHTTPServerCommunicator.Log('TID = ' + IntToStr(ThreadId) + ' ' + Str);
end;

procedure THTTPConnectionThread.DoSynchronize
  (Method : TThreadMethod);
begin
  Self.Synchronize(Method);
end;

procedure THTTPConnectionThread.ClientExecute;
const
  MaxBytesRead = 8096;
  CR = Chr(13);
  LF = Chr(10);
var
  WinSocketStream : TWinSocketStream;
  Buffer : string;
  ReceivedData : string;
  BytesRead : integer;
  StartTime : TDateTime;
  AllDataReceived : boolean;

  procedure SendDataToClient
    (Data : string);
  var
    Str : string;
    BytesSent : integer;
  begin
    Str := Data;
    try
      BytesSent := WinSocketStream.Write(Str[1],Length(Str));
    except
      BytesSent := 0;
    end;
    // record byte count
    ServerCommunicator.IncrementBytesSentCount(BytesSent);
  end;

  procedure ProcessReceivedData;
  var
    RequestLine : string;
    MessageHeaders : TStringList;
    MessageBody : string;

    Method : string;
    URI : string;
    Version : string;

    StringList : TStringList;
    Str : string;
    i : integer;

    function GetLine : string;
    var
      LFPos : integer;
    begin
      // check for CR,LF combination
      LFPos := Pos(CR+LF,ReceivedData);
      if LFPos <> 0 then
      begin
        Result := Copy(ReceivedData,1,LFPos-1);
        Delete(ReceivedData,1,LFPos+1);
      end else begin
        // check for LF's only
        LFPos := Pos(LF,ReceivedData);
        if LFPos <> 0 then
        begin
          Result := Copy(ReceivedData,1,LFPos-1);
          Delete(ReceivedData,1,LFPos);
        end else begin
          Result := ReceivedData;
          ReceivedData := '';
        end;
      end;
    end;

  begin
    // initialise variables
    RequestLine := '';
    Method := '';
    URI := '';
    Version := '';
    MessageHeaders := TStringList.Create;
    // extract request line
    while (RequestLine = '') and (ReceivedData <> '') do
      RequestLine := GetLine;
    try
      // extract message headers
      repeat
        Str := GetLine;
        if Str <> '' then
          MessageHeaders.Add(Str);
      until (Str = '');
      // message body must be what is left over
      MessageBody := ReceivedData;
      // split the request line
      StringList := TStringList.Create;
      try
        SplitStrings(StringList,RequestLine,' ');
        for i := 0 to StringList.Count - 1 do
        begin
          if StringList[i] <> '' then
          begin
            if Method = '' then
              Method := StringList[i]
            else if URI = '' then
              URI := StringList[i]
            else if Version = '' then
              Version := StringList[i];
          end;
        end;
      finally
        StringList.Free;
      end;
      // build and send response
      SendDataToClient(GetHTTPResponse(Method,URI,Version,MessageHeaders,MessageBody));
      // increment the page counter
      FHTTPServerCommunicator.IncrementPageCount;
    finally
      MessageHeaders.Free;
    end;
  end;

begin
  Log('HTTP Server thread started');
  // record reference to current thread in thread local space
  TVThread := Self;
  // create instance of TWinSocketStream for this connection
  WinSocketStream := TWinSocketStream.Create(ClientSocket,ServerTimeout);
  // create a new session for database access
  ServerCommunicator.AcquireDatabaseLock;
  try
    if not Firebird then
    begin
      TVSessionName := GetFreeSessionName;
      TVFirebirdDatabase := nil;
    end else begin
      TVSessionName := '';
      TVFirebirdDatabase := TIBDatabase.Create(nil);
      TVFirebirdDatabase.DatabaseName := FirebirdServerIPAddress + ':' + FirebirdDatabaseName;
      TVFirebirdDatabase.Params.Add('user_name=' + FirebirdUsername);
      TVFirebirdDatabase.Params.Add('password=' + FirebirdPassword);
      TVFirebirdDatabase.LoginPrompt := false;
      TVFirebirdDatabase.Open;
    end;
  finally
    ServerCommunicator.ReleaseDatabaseLock;
  end;
  // initialise other local variables
  ReceivedData := '';
  BytesRead := 0;
  StartTime := Now;
  AllDataReceived := false;
  try
    while true do
    begin
      // check connection and if disconnected then terminate the thread
      if not ClientSocket.Connected then
      begin
        Log('Server thread terminated - connection lost');
        Exit;
      end;
      // check for dead client and terminate
      if Now > IncMilliSecond(StartTime,ServerTimeout) then
      begin
        Log('Server thread terminated - no communication from client');
        Exit;
      end;
      // initialise receive buffer
      SetLength(Buffer,MaxBytesRead);
      FillChar(Buffer[1],MaxBytesRead,0);
      // read data from socket
      try
        if WinSocketStream.WaitForData(ServerTimeout) then
        begin
          try
            BytesRead := WinSocketStream.Read(Buffer[1], MaxBytesRead);
          except
            BytesRead := 0;
          end;
          if BytesRead < MaxBytesRead then
            AllDataReceived := true;
        end else begin
          BytesRead := 0;
          AllDataReceived := true;
        end;
      except
        // if an exception occurs while reading then give up
        // and log error message
        on E:Exception do
        begin
          Log('Server thread terminated - ' + E.Message);
          Exit;
        end;
      end;
      // process data received
      SetLength(Buffer,BytesRead);
      // record byte count
      ServerCommunicator.IncrementBytesReceivedCount(BytesRead);
      // add data received to received data string
      ReceivedData := ReceivedData + Buffer;
      if AllDataReceived then
      begin
        // process data
        if BytesRead > 0 then
          ProcessReceivedData;
        Exit;
      end;
      // just keep trying until we have it all
      StartTime := Now;
      // give other threads a chance
      if BytesRead = 0 then
        Sleep(1)
      else
        Sleep(0);
      // check termination flag
      if Terminated then
        Exit;
    end;
  finally
    Log('Thread cleanup');
    // destroy the TWinSocketStream
    WinSocketStream.Free;
    // close the database session
    ServerCommunicator.AcquireDatabaseLock;
    try
      if not Firebird then
        CloseSessionDatabase(TVSessionName)
      else begin
        TVFirebirdDatabase.Close;
        TVFirebirdDatabase.Free;
      end;
    finally
      ServerCommunicator.ReleaseDatabaseLock;
    end; 
  end;
end;

end.