unit osAPITCPEngineServer;

interface

uses
  IdCTypes,
  IdContext,
  IdComponent,

  IdTCPServer,

  IdSSLOpenSSL,
  IdSSLOpenSSLHeaders,

  osAPITCPServerContext,
  osServiceServersTypes;

type
  TAPITCPEngineServer = class
  private
    FCertificatesPath: string;
    FCmdCommandsBlockEnabled: Boolean;
    FIOHandlerSSLOpenSLL: TIdServerIOHandlerSSLOpenSSL;
    FListenPort: Word;
    FOpenSSLDLLPath: string;
    FSecurityPolicy: TConnectionSecurityPolicy;
    FServer: TIdTCPServer;
    FSetCommandsBlockEnabled: Boolean;
    FStopNewConnections: Boolean;
  private
    function GetActive: Boolean;
  private
    procedure SetCertificatesPath(const Value: string);
    procedure SetListenPort(Value: Word);
    procedure SetOpenSSLDLLPath(const Value: string);
  private
    procedure ServerConnect(AContext: TIdContext);
    procedure ServerExecute(AContext: TIdContext);
  private
    procedure SSLGetPassword(var Password: string);
    procedure SSLGetPasswordEx(ASender: TObject; var VPassword: string; const AIsWrite: Boolean);
    procedure SSLStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string);
    procedure SSLStatusInfo(const AMsg: string);
    procedure SSLStatusInfoEx(ASender: TObject; const AsslSocket: PSSL; const AWhere, Aret: TIdC_INT; const AType, AMsg: string);
  public
    constructor Create;
    destructor Destroy; override;
  public
    function Start: Boolean;
    function Stop: Boolean;
  public
    property Active: Boolean read GetActive;
    property CertificatesPath: string read FCertificatesPath write SetCertificatesPath;
    property CmdCommandsBlockEnabled: Boolean read FCmdCommandsBlockEnabled write FCmdCommandsBlockEnabled;
    property ListenPort: Word read FListenPort write SetListenPort;
    property OpenSSLDLLPath: string read FOpenSSLDLLPath write SetOpenSSLDLLPath;
    property SecurityPolicy: TConnectionSecurityPolicy read FSecurityPolicy write FSecurityPolicy;
    property SetCommandsBlockEnabled: Boolean read FSetCommandsBlockEnabled write FSetCommandsBlockEnabled;
  end;

implementation

uses
  System.Classes,

  IdGlobal,

  osSysUtils;

const
  { default constants }
  DEF_LISTEN_PORT     = 8000;
  DEF_SECURITY_POLICY = cnsp_None;

{ TAPITCPEngineServer }

constructor TAPITCPEngineServer.Create;
begin
  // sets default members values
  FCertificatesPath := '';
  FCmdCommandsBlockEnabled := False;
  FIOHandlerSSLOpenSLL := nil;
  FListenPort := DEF_LISTEN_PORT;
  FOpenSSLDLLPath := '';
  FSecurityPolicy := DEF_SECURITY_POLICY;
  FServer := nil;
  FSetCommandsBlockEnabled := False;
  FStopNewConnections := False;
end;

destructor TAPITCPEngineServer.Destroy;
begin
  // frees objects
  SafeFreeAndNil(FServer);
  SafeFreeAndNil(FIOHandlerSSLOpenSLL);

  inherited;
end;

function TAPITCPEngineServer.GetActive: Boolean;
begin
  if FServer = nil then Exit(False);
  Result := FServer.Active;
end;

procedure TAPITCPEngineServer.ServerConnect(AContext: TIdContext);
begin
  // checks if new connections are permitted
  if FStopNewConnections then
    AContext.Connection.Disconnect;

  // ###
  if not (AContext.Connection.IOHandler is TIdSSLIOHandlerSocketOpenSSL) then
  begin
    AContext.Connection.Disconnect;
    Exit;
  end;
end;

procedure TAPITCPEngineServer.ServerExecute(AContext: TIdContext);
begin
  // enables server request to be UTF8 compliant
  AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
  TAPITCPServerContext(AContext).CmdCommandsBlockEnabled := FCmdCommandsBlockEnabled;
  TAPITCPServerContext(AContext).SetCommandsBlockEnabled := FSetCommandsBlockEnabled;
  TAPITCPServerContext(AContext).Execute;
end;

procedure TAPITCPEngineServer.SetCertificatesPath(const Value: string);
begin
  if (FServer <> nil) and FServer.Active then Exit;
  FCertificatesPath := Value;
end;

procedure TAPITCPEngineServer.SetListenPort(Value: Word);
begin
  if (FServer <> nil) and FServer.Active then Exit;
  FListenPort := Value;
end;

procedure TAPITCPEngineServer.SetOpenSSLDLLPath(const Value: string);
begin
  if (FServer <> nil) and FServer.Active then Exit;
  FOpenSSLDLLPath := Value;
end;

procedure TAPITCPEngineServer.SSLGetPassword(var Password: string);
begin
  //### TODO: Used for debug. At moment it is never called at client connection!!!
  Password := '';
end;

procedure TAPITCPEngineServer.SSLGetPasswordEx(ASender: TObject; var VPassword: string; const AIsWrite: Boolean);
begin
  //### TODO: Used for debug. At moment it is never called at client connection!!!
end;

procedure TAPITCPEngineServer.SSLStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string);
begin
  //### TODO: Used for debug. At moment it is never called at client connection!!!
end;

procedure TAPITCPEngineServer.SSLStatusInfo(const AMsg: string);
begin
  //### TODO: Used for debug. At moment it is never called at client connection!!!
end;

procedure TAPITCPEngineServer.SSLStatusInfoEx(ASender: TObject; const AsslSocket: PSSL; const AWhere, Aret: TIdC_INT; const AType, AMsg: string);
begin
  //### TODO: Used for debug. At moment it is never called at client connection!!!
end;

function TAPITCPEngineServer.Start: Boolean;
begin
  try
    if (FServer <> nil) and (FServer.Active) then Exit(True);
    if FServer = nil then
    begin
      FStopNewConnections := False;

      // creates and sets tcp server
      FServer := TIdTCPServer.Create(nil);
      FServer.Active := False;
      FServer.ContextClass := TAPITCPServerContext;
      FServer.DefaultPort := FListenPort;
      FServer.OnConnect := ServerConnect;
      FServer.OnExecute := ServerExecute;

      // sets OpenSLL library path
      IdOpenSSLSetLibPath(FOpenSSLDLLPath);

      // evaluates security policy
      case FSecurityPolicy of
        cnsp_None: ;

        cnsp_sslvTLSv1_2:
        begin
          FIOHandlerSSLOpenSLL := TIdServerIOHandlerSSLOpenSSL.Create(nil);
          FIOHandlerSSLOpenSLL.OnStatus := SSLStatus;
          FIOHandlerSSLOpenSLL.OnStatusInfo := SSLStatusInfo;
          FIOHandlerSSLOpenSLL.OnStatusInfoEx := SSLStatusInfoEx;
          FIOHandlerSSLOpenSLL.OnGetPassword := SSLGetPassword;
          FIOHandlerSSLOpenSLL.OnGetPasswordEx := SSLGetPasswordEx;

          FIOHandlerSSLOpenSLL.SSLOptions.Mode := sslmServer;
          FIOHandlerSSLOpenSLL.SSLOptions.Method := sslvTLSv1_2;
          FIOHandlerSSLOpenSLL.SSLOptions.SSLVersions := [sslvTLSv1_2];
          FIOHandlerSSLOpenSLL.SSLOptions.DHParamsFile := '';
          FIOHandlerSSLOpenSLL.SSLOptions.CertFile := FCertificatesPath + 'server-cert.pem';
          FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := FCertificatesPath + 'server-key.pem';
//        FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := FCertificatesPath + 'root-cert.pem';
          FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := '';
          FIOHandlerSSLOpenSLL.SSLOptions.CipherList := '!EXPORT:!LOW:!aNULL:!eNULL:!RC4:!ADK:!3DES:!DES:!MD5:!PSK:!SRP:!CAMELLIA'+
                      ':ECDHE-RSA-AES128-GCM-SHA256'+
                      ':ECDHE-RSA-AES256-GCM-SHA384'+
                      ':ECDHE-RSA-CHACHA20-POLY1305'+
                      //to use this two you must create a dhparam.pem file with openssl in this way
                      //openssl dhparam -out dhparam.pem 4096
                      //':DHE-RSA-AES128-GCM-SHA256'+
                      //':DHE-RSA-AES256-GCM-SHA384'+
                      '';
          FServer.IOHandler := FIOHandlerSSLOpenSLL;
        end;
      end;
    end;
    FServer.Active := True;
    Result := FServer.Active;
  except
    Result := False;
  end;
end;

function TAPITCPEngineServer.Stop: Boolean;

  function ActivitiesStop: Boolean;
  var
    I: Integer;
    LList: TList;
    Context: TAPITCPServerContext;
  begin
    Result := False;
    LList := FServer.Contexts.LockList;
    try
      for I := 0 to LList.Count - 1 do
      begin
        Context := TAPITCPServerContext(LList[I]);
        Context.ActivitiesStop := True;
        Result := True;
      end;
    finally
      FServer.Contexts.UnlockList;
    end;
  end;

  function ActivitiesStoppedCheck: Boolean;
  var
    I: Integer;
    LList: TList;
    Context: TAPITCPServerContext;
  begin
    Result := False;
    LList := FServer.Contexts.LockList;
    try
      for I := 0 to LList.Count - 1 do
      begin
        Context := TAPITCPServerContext(LList[I]);
        Result := not Context.ActivitiesStopped;
        if Result then Exit;
      end;
    finally
      FServer.Contexts.UnlockList;
    end;
  end;

begin
  Result := True;
  try
    if FServer = nil then Exit;
    if FServer.Active then
    begin
      {**
       *  TAKE CARE
       *  =========
       *  At this point we are in primary thread and we want to close all API Server connections but someone could be
       *  in waiting for Thread.Syncronize and stay in infinite loop because TApplication.Idle is not managed, and the
       *  related CheckSynchronize will never be called, we are in primary thread here.
       *  A valid solution, before to set server Active to False is:
       *  - Refuse any new connection on OnConnect with FStopNewConnections to True.
       *  - Ask clients context to stop any activity (get request and put a response which could call TThread.Synchronize.
       *  - Check when all client context accepted the stop to any activity.
       *    In the meanwhile call CheckSynchronize to manage possible pending TThread.Synchronize calls.
       *
       **}
      FStopNewConnections := True;
      if ActivitiesStop then
      begin
        while ActivitiesStoppedCheck do
        begin
          CheckSynchronize;
          TThread.Sleep(1);
        end;
      end;
      FServer.Active := False;
    end;

    // frees objects
    SafeFreeAndNil(FServer);
    SafeFreeAndNil(FIOHandlerSSLOpenSLL);
  except
    Result := False;
  end;
end;

end.