(*
 * Licensed to the Apache Software Foundation (ASF) under one
 * or more contributor license agreements. See the NOTICE file
 * distributed with this work for additional information
 * regarding copyright ownership. The ASF licenses this file
 * to you under the Apache License, Version 2.0 (the
 * "License"); you may not use this file except in compliance
 * with the License. You may obtain a copy of the License at
 *
 *   http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing,
 * software distributed under the License is distributed on an
 * "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
 * KIND, either express or implied. See the License for the
 * specific language governing permissions and limitations
 * under the License.
 *)

 unit Thrift.Server;

{$I Thrift.Defines.inc}
{$I-}  // prevent annoying errors with default log delegate and no console

interface

uses
  {$IFDEF OLD_UNIT_NAMES}
  Windows, SysUtils,
  {$ELSE}
  Winapi.Windows, System.SysUtils,
  {$ENDIF}
  Thrift,
  Thrift.Protocol,
  Thrift.Transport;

type
  IServerEvents = interface
    ['{9E2A99C5-EE85-40B2-9A52-2D1722B18176}']
    // Called before the server begins.
    procedure PreServe;
    // Called when the server transport is ready to accept requests
    procedure PreAccept;
    // Called when a new client has connected and the server is about to being processing.
    function  CreateProcessingContext( const input, output : IProtocol) : IProcessorEvents;
  end;


  IServer = interface
    ['{ADC46F2D-8199-4D1C-96D2-87FD54351723}']
    procedure Serve;
    procedure Stop;

    function GetServerEvents : IServerEvents;
    procedure SetServerEvents( const value : IServerEvents);

    property ServerEvents : IServerEvents read GetServerEvents write SetServerEvents;
  end;

  TServerImpl = class abstract( TInterfacedObject, IServer )
  public
    type
      TLogDelegate = reference to procedure( const str: string);
  strict protected
    FProcessor : IProcessor;
    FServerTransport : IServerTransport;
    FInputTransportFactory : ITransportFactory;
    FOutputTransportFactory : ITransportFactory;
    FInputProtocolFactory : IProtocolFactory;
    FOutputProtocolFactory : IProtocolFactory;
    FLogDelegate : TLogDelegate;
    FServerEvents : IServerEvents;

    class procedure DefaultLogDelegate( const str: string);

    function GetServerEvents : IServerEvents;
    procedure SetServerEvents( const value : IServerEvents);

    procedure Serve; virtual; abstract;
    procedure Stop; virtual; abstract;
  public
    constructor Create(
      const aProcessor :IProcessor;
      const aServerTransport: IServerTransport;
      const aInputTransportFactory : ITransportFactory;
      const aOutputTransportFactory : ITransportFactory;
      const aInputProtocolFactory : IProtocolFactory;
      const aOutputProtocolFactory : IProtocolFactory;
      const aLogDelegate : TLogDelegate
      ); overload;

    constructor Create(
      const aProcessor :IProcessor;
      const aServerTransport: IServerTransport
      ); overload;

    constructor Create(
      const aProcessor :IProcessor;
      const aServerTransport: IServerTransport;
      const aLogDelegate: TLogDelegate
      ); overload;

    constructor Create(
      const aProcessor :IProcessor;
      const aServerTransport: IServerTransport;
      const aTransportFactory : ITransportFactory
      ); overload;

    constructor Create(
      const aProcessor :IProcessor;
      const aServerTransport: IServerTransport;
      const aTransportFactory : ITransportFactory;
      const aProtocolFactory : IProtocolFactory
      ); overload;
  end;


  TSimpleServer = class( TServerImpl)
  private
    FStop : Boolean;
  public
    constructor Create(
      const aProcessor: IProcessor;
      const aServerTransport: IServerTransport
      ); overload;

    constructor Create(
      const aProcessor: IProcessor;
      const aServerTransport: IServerTransport;
      const ALogDel: TServerImpl.TLogDelegate
      ); overload;

    constructor Create(
      const aProcessor: IProcessor;
      const aServerTransport: IServerTransport;
      const aTransportFactory: ITransportFactory
      ); overload;

    constructor Create(
      const aProcessor: IProcessor;
      const aServerTransport: IServerTransport;
      const aTransportFactory: ITransportFactory;
      const aProtocolFactory: IProtocolFactory
      ); overload;

    procedure Serve; override;
    procedure Stop; override;
  end;


implementation

{ TServerImpl }

constructor TServerImpl.Create( const aProcessor: IProcessor;
                                const aServerTransport: IServerTransport;
                                const aLogDelegate: TLogDelegate);
var
  InputFactory, OutputFactory : IProtocolFactory;
  InputTransFactory, OutputTransFactory : ITransportFactory;

begin
  InputFactory := TBinaryProtocolImpl.TFactory.Create;
  OutputFactory := TBinaryProtocolImpl.TFactory.Create;
  InputTransFactory := TTransportFactoryImpl.Create;
  OutputTransFactory := TTransportFactoryImpl.Create;

  //no inherited;
  Create(
    aProcessor,
    aServerTransport,
    InputTransFactory,
    OutputTransFactory,
    InputFactory,
    OutputFactory,
    ALogDelegate
  );
end;

constructor TServerImpl.Create(const aProcessor: IProcessor;
  const aServerTransport: IServerTransport);
var
  InputFactory, OutputFactory : IProtocolFactory;
  InputTransFactory, OutputTransFactory : ITransportFactory;

begin
  InputFactory := TBinaryProtocolImpl.TFactory.Create;
  OutputFactory := TBinaryProtocolImpl.TFactory.Create;
  InputTransFactory := TTransportFactoryImpl.Create;
  OutputTransFactory := TTransportFactoryImpl.Create;

  //no inherited;
  Create(
    aProcessor,
    aServerTransport,
    InputTransFactory,
    OutputTransFactory,
    InputFactory,
    OutputFactory,
    DefaultLogDelegate
  );
end;

constructor TServerImpl.Create(const aProcessor: IProcessor;
  const aServerTransport: IServerTransport; const aTransportFactory: ITransportFactory);
var
  InputProtocolFactory : IProtocolFactory;
  OutputProtocolFactory : IProtocolFactory;
begin
  InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
  OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;

  //no inherited;
  Create( aProcessor, aServerTransport, aTransportFactory, aTransportFactory,
    InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);
end;

constructor TServerImpl.Create(const aProcessor: IProcessor;
  const aServerTransport: IServerTransport;
  const aInputTransportFactory, aOutputTransportFactory: ITransportFactory;
  const aInputProtocolFactory, aOutputProtocolFactory: IProtocolFactory;
  const aLogDelegate : TLogDelegate);
begin
  inherited Create;
  FProcessor := aProcessor;
  FServerTransport := aServerTransport;
  FInputTransportFactory := aInputTransportFactory;
  FOutputTransportFactory := aOutputTransportFactory;
  FInputProtocolFactory := aInputProtocolFactory;
  FOutputProtocolFactory := aOutputProtocolFactory;
  FLogDelegate := aLogDelegate;
end;

class procedure TServerImpl.DefaultLogDelegate( const str: string);
begin
  try
    Writeln( str);
    if IoResult <> 0 then OutputDebugString(PChar(str));
  except
    OutputDebugString(PChar(str));
  end;
end;

constructor TServerImpl.Create( const aProcessor: IProcessor;
  const aServerTransport: IServerTransport; const aTransportFactory: ITransportFactory;
  const aProtocolFactory: IProtocolFactory);
begin
  //no inherited;
  Create( aProcessor, aServerTransport,
          aTransportFactory, aTransportFactory,
          aProtocolFactory, aProtocolFactory,
          DefaultLogDelegate);
end;


function TServerImpl.GetServerEvents : IServerEvents;
begin
  result := FServerEvents;
end;


procedure TServerImpl.SetServerEvents( const value : IServerEvents);
begin
  // if you need more than one, provide a specialized IServerEvents implementation
  FServerEvents := value;
end;


{ TSimpleServer }

constructor TSimpleServer.Create( const aProcessor: IProcessor;
  const aServerTransport: IServerTransport);
var
  InputProtocolFactory : IProtocolFactory;
  OutputProtocolFactory : IProtocolFactory;
  InputTransportFactory : ITransportFactory;
  OutputTransportFactory : ITransportFactory;
begin
  InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
  OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
  InputTransportFactory := TTransportFactoryImpl.Create;
  OutputTransportFactory := TTransportFactoryImpl.Create;

  inherited Create( aProcessor, aServerTransport, InputTransportFactory,
    OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, DefaultLogDelegate);
end;

constructor TSimpleServer.Create( const aProcessor: IProcessor;
  const aServerTransport: IServerTransport; const ALogDel: TServerImpl.TLogDelegate);
var
  InputProtocolFactory : IProtocolFactory;
  OutputProtocolFactory : IProtocolFactory;
  InputTransportFactory : ITransportFactory;
  OutputTransportFactory : ITransportFactory;
begin
  InputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
  OutputProtocolFactory := TBinaryProtocolImpl.TFactory.Create;
  InputTransportFactory := TTransportFactoryImpl.Create;
  OutputTransportFactory := TTransportFactoryImpl.Create;

  inherited Create( aProcessor, aServerTransport, InputTransportFactory,
    OutputTransportFactory, InputProtocolFactory, OutputProtocolFactory, ALogDel);
end;

constructor TSimpleServer.Create( const aProcessor: IProcessor;
  const aServerTransport: IServerTransport; const aTransportFactory: ITransportFactory);
begin
  inherited Create( aProcessor, aServerTransport, aTransportFactory,
    aTransportFactory, TBinaryProtocolImpl.TFactory.Create, TBinaryProtocolImpl.TFactory.Create, DefaultLogDelegate);
end;

constructor TSimpleServer.Create( const aProcessor: IProcessor;
  const aServerTransport: IServerTransport; const aTransportFactory: ITransportFactory;
  const aProtocolFactory: IProtocolFactory);
begin
  inherited Create( aProcessor, aServerTransport, aTransportFactory,
    aTransportFactory, aProtocolFactory, aProtocolFactory, DefaultLogDelegate);
end;

procedure TSimpleServer.Serve;
var
  client : ITransport;
  InputTransport : ITransport;
  OutputTransport : ITransport;
  InputProtocol : IProtocol;
  OutputProtocol : IProtocol;
  context : IProcessorEvents;
begin
  try
    FServerTransport.Listen;
  except
    on E: Exception do
    begin
      FLogDelegate( E.ToString);
    end;
  end;

  if FServerEvents <> nil
  then FServerEvents.PreServe;

  client := nil;
  while (not FStop) do
  begin
    try
      // clean up any old instances before waiting for clients
      InputTransport := nil;
      OutputTransport := nil;
      InputProtocol := nil;
      OutputProtocol := nil;

      // close any old connections before before waiting for new clients
      if client <> nil then try
        try
          client.Close;
        finally
          client := nil;
        end;
      except
        // catch all, we can't do much about it at this point
      end;

      client := FServerTransport.Accept( procedure
                                         begin
                                           if FServerEvents <> nil
                                           then FServerEvents.PreAccept;
                                         end);

      if client = nil then begin
        if FStop
        then Abort  // silent exception
        else raise TTransportExceptionUnknown.Create('ServerTransport.Accept() may not return NULL');
      end;

      FLogDelegate( 'Client Connected!');

      InputTransport := FInputTransportFactory.GetTransport( client );
      OutputTransport := FOutputTransportFactory.GetTransport( client );
      InputProtocol := FInputProtocolFactory.GetProtocol( InputTransport );
      OutputProtocol := FOutputProtocolFactory.GetProtocol( OutputTransport );

      if FServerEvents <> nil
      then context := FServerEvents.CreateProcessingContext( InputProtocol, OutputProtocol)
      else context := nil;

      while not FStop do begin
        if context <> nil
        then context.Processing( client);
        if not FProcessor.Process( InputProtocol, OutputProtocol, context)
        then Break;
      end;

    except
      on E: TTransportException do
      begin
        if FStop
        then FLogDelegate('TSimpleServer was shutting down, caught ' + E.ToString)
        else FLogDelegate( E.ToString);
      end;
      on E: Exception do
      begin
        FLogDelegate( E.ToString);
      end;
    end;

    if context <> nil
    then begin
      context.CleanupContext;
      context := nil;
    end;

    if InputTransport <> nil then
    begin
      InputTransport.Close;
    end;
    if OutputTransport <> nil then
    begin
      OutputTransport.Close;
    end;
  end;

  if FStop then
  begin
    try
      FServerTransport.Close;
    except
      on E: TTransportException do
      begin
        FLogDelegate('TServerTranport failed on close: ' + E.Message);
      end;
    end;
    FStop := False;
  end;
end;

procedure TSimpleServer.Stop;
begin
  FStop := True;
  FServerTransport.Close;
end;

end.