Watch, Follow, &
Connect with Us

For forums, blogs and more please visit our
Developer Tools Community.


Welcome, Guest
Guest Settings
Help

Thread: Indy SSL with in memory certificates (PEM & PKCS12)



Permlink Replies: 2 - Last Post: Jan 6, 2018 10:19 AM Last Post By: Hafedh TRIMECHE
Hafedh TRIMECHE

Posts: 107
Registered: 12/29/06
Indy SSL with in memory certificates (PEM & PKCS12)
Click to report abuse...   Click to reply to this thread Reply
  Posted: Dec 28, 2017 7:35 AM
This is an implementation of Server & Client using in memory SSL certificates (separated PEM or PKCS12).

Improvements in progress regarding peer certificate's verification with depth.

Implementation tested with https://testssl.sh giving the expected results.

unit uSocketBase;
{$I Defines}
interface
uses
  Types,Classes,SysUtils,Windows,Messages,
  IdGlobal,IdSSLOpenSSLHeaders,IdSSLOpenSSL,IdContext,IdYarn,IdTCPConnection,
  IdIOHandler,IdCustomTCPServer,IdTCPServer,IdTCPClient;
(* 
  https://testssl.sh/ 
  used for testing SSL/TLS
*)
const
  WSANO_RECOVERY = 11003;
 
  SSL_OP_STRONG =
    SSL_OP_ALL                                    or
    SSL_OP_NO_SSLv2 or SSL_OP_NO_SSLv3            or
    SSL_OP_NO_TLSv1 or SSL_OP_NO_TLSv1_1          or
    SSL_OP_CIPHER_SERVER_PREFERENCE               or
    SSL_OP_SINGLE_DH_USE                          or
    SSL_OP_SINGLE_ECDH_USE                        or
    SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION ;
 
  SSLStrongCiphers =
    'ECDHE-RSA-AES256-GCM-SHA384:' +
    'ECDHE-RSA-AES256-SHA384:'     +
    'ECDHE-RSA-AES256-SHA:'        +
    'AES256-GCM-SHA384:'           +
    /////////////////////////////////
    'AES256-SHA256:'   +
    'AES256-SHA:'      +
    'CAMELLIA256-SHA:' +
    /////////////////////////////////
    '!aNULL:'       +
    '!eNULL:'       +
    '!EXPORT:'      +
    '!RC4:'         +
    '!DES:'         +
    '!MD5@STRENGTH' ;
    /////////////////////////////////
type
  TSocketCopress            = class;
  TSocketCopressClass       = class of TSocketCopress;
  TSocketContext            = class;
  TSocketContextClass       = class of TSocketContext;
  TSocketClient             = class;
  TSocketClientEvent        = procedure(SocketClient:TSocketClient) of object;
  TSocketServerEvent        = procedure(AContext:TSocketContext) of object;
  TSocketServerExecuteEvent = function(AContext:TSocketContext):Boolean of object;
 
  TSocketCopress=class
  protected
    function Compress(const Decoded:TBytes;StartPos:Integer=0;Offset:Integer=-1):TBytes;virtual;
    function Decompress(const Encoded:TBytes):TBytes;virtual;
  end;
 
  TSocketSSLOptions=class
  private
    FKeyPassword : RawByteString;
    FCACert      : PX509;
    FCert        : PX509;
    FPrivateKey  : PEVP_PKEY;
    FP12         : Pointer;
    FCiphers     : RawByteString;
    FPassThrough : Boolean;
    procedure SetCert(Index:Integer;Value:string);
    procedure SetP12(Value:TBytes);
  public
    constructor Create;
    destructor  Destroy;override;
    property    CACert      : string index 1 write SetCert;
    property    Cert        : string index 2 write SetCert;
    property    PrivateKey  : string index 3 write SetCert;
    property    KeyPassword : string index 4 write SetCert;
    property    Ciphers     : string index 5 write SetCert;
    property    P12         : TBytes write SetP12;
    property    PassThrough : Boolean read FPassThrough write FPassThrough;
  end;
 
  TSocketSSLIOClient = class(TIdSSLIOHandlerSocketOpenSSL)
  private
    FSSLOptions : TSocketSSLOptions;
  protected
    procedure InitComponent;override;
  public
    destructor Destroy;override;
    property   SSLOptions:TSocketSSLOptions read FSSLOptions write FSSLOptions;
    procedure  StartSSL;override;
  end;
 
  TSocketSSLIOServer = class(TIdServerIOHandlerSSLOpenSSL)
  private
    FSSLOptions : TSocketSSLOptions;
  protected
    procedure InitComponent;override;
  public
    procedure  Init;override;
    destructor Destroy;override;
    property   SSLOptions:TSocketSSLOptions read FSSLOptions write FSSLOptions;
  end;
 
  TSocketContext = class(TIdServerContext)
  private
    FConnection    : TIdTCPConnection;
    FIOHandler     : TIdIOHandler;
    FSocketCopress : TSocketCopress;
    FRemoteIP      : string;
    FRemotePort    : Integer;
    FTimeout       : Integer;
    FLastError     : Integer;
    FLastErrorDesc : string;
 
    FLastAccess    : TDateTime;
    procedure ClearErrors;
    procedure SetTimeout(Seconds:Integer);
  protected
    procedure HandleException(AException:Exception);override;
  public
    constructor Create(AConnection:TIdTCPConnection;AYarn:TIdYarn;AList:TIdContextThreadList=nil);override;
    property    RemoteIP:string read FRemoteIP;
    property    RemotePort:Integer read FRemotePort;
    property    Timeout:Integer read FTimeout write SetTimeout;
    function    Connected:Boolean;
    procedure   Disconnect;
    property    LastError:Integer read FLastError;
    property    LastErrorDesc:string read FLastErrorDesc;
 
    function    ReadBytes(ToRead:Integer=-1):TBytes;
    function    WriteBytes(Value:TBytes;StartPos:Integer=0;ToWrite:Integer=-1):Boolean;
 
    function    ReadByte:Byte;
    function    ReadSmallInt:SmallInt;
    function    ReadWord:Word;
    function    ReadInteger:Integer;
    function    ReadCardinal:Cardinal;
    function    ReadLargeInt:Int64;
    function    WriteByte(const Value:Byte):Boolean;
    function    WriteSmallInt(Value:SmallInt):Boolean;
    function    WriteWord(Value:Word):Boolean;
    function    WriteInteger(Value:Integer):Boolean;
    function    WriteCardinal(Value:Cardinal):Boolean;
    function    WriteLargeInt(Value:Int64):Boolean;
 
    function    Read:TBytes;
    function    Write(Value:TBytes;StartPos:Integer=0;ToWrite:Integer=0):Boolean;
    function    WriteThenRead(const Data:TBytes;var SocketErrorCode:Integer):TBytes;
  end;
 
  TSocketClient=class(TIdTCPClient)
  private
  var
    FTimeout       : Integer;
    FCompressClass : TSocketCopressClass;
    FSocketCopress : TSocketCopress;
    FCert          ,
    FPrivateKey    ,
    FCACert        ,
    FKeyPassword   ,
    FCiphers       : string;
    FP12           : TBytes;
    FEnableSSL     : Boolean;
    FSSLHandler    : TSocketSSLIOClient;
    FLastError     : Integer;
    FLastErrorDesc : string;
    FOnConnect     : TSocketClientEvent;
    FOnDisconnect  : TSocketClientEvent;
    procedure ClearErrors;
    procedure SetTimeout(Seconds:Integer);
    function  GetCert(Index:Integer):string;
    procedure SetCert(Index:Integer;Value:string);
    procedure SetCopressClass(Value:TSocketCopressClass);
  protected
    procedure InitComponent;override;
    procedure DoOnConnected;override;
    procedure DoOnDisconnected;override;
    procedure HandleException(AException:Exception);
  public
    Destructor  Destroy;override;
    property    Timeout:Integer read FTimeout write SetTimeout;
    procedure   Connect;override;
    property    CompressClass:TSocketCopressClass read FCompressClass write SetCopressClass;
 
    property    CACert      : string index 1 read GetCert write SetCert;
    property    Cert        : string index 2 read GetCert write SetCert;
    property    PrivateKey  : string index 3 read GetCert write SetCert;
    property    KeyPassword : string index 4 read GetCert write SetCert;
    property    Ciphers     : string index 5 read GetCert write SetCert;
    property    P12         : TBytes read FP12 write FP12;
 
    property    EnableSSL:Boolean read FEnableSSL write FEnableSSL;
 
    function    LastError:Integer;
    function    LastErrorDesc:string;
 
    function    ReadBytes(ToRead:Integer=-1):TBytes;
    function    WriteBytes(Value:TBytes;StartPos:Integer=0;ToWrite:Integer=-1):Boolean;
 
    function    ReadByte:Byte;
    function    ReadSmallInt:SmallInt;
    function    ReadWord:Word;
    function    ReadInteger:Integer;
    function    ReadCardinal:Cardinal;
    function    ReadLargeInt:Int64;
    function    WriteByte(const Value:Byte):Boolean;
    function    WriteSmallInt(Value:SmallInt):Boolean;
    function    WriteWord(Value:Word):Boolean;
    function    WriteInteger(Value:Integer):Boolean;
    function    WriteCardinal(Value:Cardinal):Boolean;
    function    WriteLargeInt(Value:Int64):Boolean;
 
    function    Read:TBytes;
    function    Write(Value:TBytes;StartPos:Integer=0;ToWrite:Integer=0):Boolean;
    function    WriteThenRead(const Data:TBytes;var SocketErrorCode:Integer):TBytes;
 
    property    OnConnect:TSocketClientEvent read FOnConnect write FOnConnect;
    property    OnDisconnect:TSocketClientEvent read FOnDisconnect write FOnDisconnect;
  end;
 
  TSocketServer=class(TIdTCPServer)
  private
    FCompressClass : TSocketCopressClass;
    FSocketCopress : TSocketCopress;
    FVerifyCert    : Boolean;
    FCACert        ,
    FCert          ,
    FPrivateKey    ,
    FKeyPassword   ,
    FCiphers       : string;
    FP12           : TBytes;
    FPassThrough   : Boolean;
    FEnableSSL     : Boolean;
    FSSLHandler    : TSocketSSLIOServer;
    FOnConnect     : TSocketServerEvent;
    FOnDisconnect  : TSocketServerEvent;
    FOnExecute     : TSocketServerExecuteEvent;
    procedure SetCopressClass(Value:TSocketCopressClass);
    function  GetCert(Index:Integer):string;
    procedure SetCert(Index:Integer;Value:string);
  protected
    procedure InitComponent;override;
    procedure CheckOkToBeActive;override;
    procedure SetActive(Value:Boolean);override;
    procedure DoConnect(AContext:TIdContext);override;
    procedure DoDisconnect(AContext:TIdContext);override;
    function  DoExecute(AContext:TIdContext):Boolean;override;
  public
    destructor Destroy;override;
    property   CompressClass:TSocketCopressClass read FCompressClass write SetCopressClass;
 
    property   CACert      : string index 1 read GetCert write SetCert;
    property   Cert        : string index 2 read GetCert write SetCert;
    property   PrivateKey  : string index 3 read GetCert write SetCert;
    property   KeyPassword : string index 4 read GetCert write SetCert;
    property   Ciphers     : string index 5 read GetCert write SetCert;
    property   P12         : TBytes read FP12 write FP12;
    property   PassThrough : Boolean read FPassThrough write FPassThrough;
 
    property   SSLEnabled:Boolean  read FEnableSSL write FEnableSSL;
    property   VerifyCert:Boolean  read FVerifyCert write FVerifyCert;
 
    property   OnConnect:TSocketServerEvent read FOnConnect write FOnConnect;
    property   OnDisconnect:TSocketServerEvent read FOnDisconnect write FOnDisconnect;
    property   OnExecute:TSocketServerExecuteEvent read FOnExecute write FOnExecute;
  end;
 
procedure HandleSocketException(E:Exception;var SocketError:Integer);
 
implementation
uses
  IdStackConsts,IdStack,IdExceptionCore,IdResourceStringsCore,IdResourceStringsProtocols;
const
  SSL_CTRL_SET_ECDH_AUTO = 94;
var
  SSLLoaded : Boolean = False;
 
procedure LoadSSL;
begin
  if SSLLoaded then Exit;
  SSLLoaded := True;
  LoadOpenSSLLibrary;
end;
 
///////////////////////////////////////////////////////////////////////////
procedure HandleSocketException(E:Exception;var SocketError:Integer);
begin
  if E=nil then SocketError := 0 else
  begin
    SocketError := WSANO_RECOVERY;
    if (E is EIdSocketError)      then SocketError := (E as EIdSocketError).LastError else
    if (E is EIdOpenSSLError)     then SocketError := Id_WSAENOPROTOOPT else
    if (E is EIdReadTimeout)      then SocketError := Id_WSAETIMEDOUT   else
    if (E is EIdAlreadyConnected) then SocketError := Id_WSAEISCONN     ;
  end;
end;
 
function SSLErrorMessage(const Method:string;out Error:Integer):string;
var
  Buffer : TBytes;
begin
  Error := Integer(ERR_get_error);
  if Error>1 then
  begin
    SetLength(Buffer,1024*2);
    ERR_error_string(Error,@Buffer[0]);
    Result := string(PAnsiChar(@Buffer[0]));
  end
  else Result := '';
end;
///////////////////////////////////////////////////////////////////////////
function TSocketCopress.Compress(const Decoded:TBytes;StartPos:Integer;Offset:Integer): TBytes;
begin
  Result := Decoded;
end;
 
function TSocketCopress.Decompress(const Encoded: TBytes): TBytes;
begin
  Result := Encoded;
end;
///////////////////////////////////////////////////////////////////////////
function X509ToPEM(X509:Pointer):string;
var
  MemIO     : pBIO;
  iResult   : Integer;
  RawResult : RawByteString;
  P         : Pointer;
begin
  Result := '';
  if X509=nil then Exit;
  MemIO   := BIO_new(BIO_s_mem);
  iResult := PEM_write_bio_X509(MemIO,X509);
  if iResult=1 then 
  begin
    P := nil;
    SetLength(RawResult,BIO_get_mem_data(MemIO,P));
    if RawResult<>'' then BIO_read(MemIO,PAnsiChar(RawResult),Length(RawResult));
    Result := string(RawResult);
  end;
  BIO_free(MemIO);
end;
 
procedure LoadCert(PEM:RawByteString;var x509:PX509);
var
  Buffer : PBIO;
begin
  if x509<>nil then X509_free(x509);
  x509 := nil;
  if Length(PEM)=0 then Exit;
  Buffer := BIO_new_mem_buf(PAnsiChar(PEM),Length(PEM));
  try
    x509 := PEM_read_bio_X509(Buffer,nil,nil,nil);
  finally
    BIO_free(Buffer);
  end;
end;
 
procedure LoadKey(PEM:RawByteString;const KeyPassword:RawByteString;var xKey:PEVP_PKEY);
var
  Buffer : PBIO;
begin
  if xKey<>nil then EVP_PKEY_free(xKey);
  if Length(PEM)=0 then Exit;
  Buffer := BIO_new_mem_buf(PAnsiChar(PEM),Length(PEM));
  try
    xKey := PEM_read_bio_PrivateKey(Buffer,nil,nil,PAnsiChar(KeyPassword));
  finally
    BIO_free(Buffer);
  end;
end;
///////////////////////////////////////////////////////////////////////////
constructor TSocketSSLOptions.Create;
begin
  FKeyPassword := '';
  FCACert      := nil;
  FCert        := nil;
  FPrivateKey  := nil;
  FCiphers     := '';
  FP12         := nil;
  FPassThrough := False;
end;
 
destructor TSocketSSLOptions.Destroy;
begin
  if FCACert<>nil then X509_free(FCACert);
  if FCert<>nil then X509_free(FCert);
  if FPrivateKey<>nil then EVP_PKEY_free(FPrivateKey);
  inherited;
end;
 
procedure TSocketSSLOptions.SetCert(Index:Integer;Value:string);
var
  RawValue : RawByteString;
begin
  RawValue := RawByteString(Trim(Value));
  case index of
    1: LoadCert(RawValue,FCACert);
    2: LoadCert(RawValue,FCert);
    3: LoadKey(RawValue,FKeyPassword,FPrivateKey);
    4: FKeyPassword := RawByteString(Value);
    5: FCiphers     := RawByteString(Value);
  end;
end;
 
procedure TSocketSSLOptions.SetP12(Value: TBytes);
var
  MemIO     : PBIO;
  p12       : PPKCS12;
  xCA       : PSTACK_OF_X509;
  Err       ,
  i         : Integer;
  CertChain : string;
procedure Clear;
begin
  if xCA        <>nil then sk_pop_free(xCA,@X509_free);
  if FCACert    <>nil then X509_free(FCACert);
  if FCert      <>nil then X509_free(FCert);
  if FPrivateKey<>nil then EVP_PKEY_free(FPrivateKey);
  xCA         := nil;
  FCACert     := nil;
  FCert       := nil;
  FPrivateKey := nil;
end;
begin
  if Value=nil then Exit;
  xCA := nil;
  Clear;
  MemIO := BIO_new_mem_buf(@Value[0],Length(Value));
  p12   := d2i_PKCS12_bio(MemIO,nil);
  Err   := 1;
  if Assigned(p12) then
  begin
    Err := PKCS12_parse(p12,PAnsiChar(FKeyPassword),FPrivateKey,FCert,@xCA);
    PKCS12_free(p12);
  end;
  BIO_free(MemIO);
  if Err<=0 then Clear else
  begin
    if xCA<>nil  then
    begin
      CertChain := '';
      for i:=0 to sk_num(xCA)-1 do CertChain := X509ToPEM(sk_value(xCA,i))+CertChain;
      sk_pop_free(xCA,@X509_free);
      CACert := CertChain;
    end;
  end;
end;
///////////////////////////////////////////////////////////////////////////
type
  TSocketSSLContext=class(TIdSSLContext)
  end;
///////////////////////////////////////////////////////////////////////////
procedure TSocketSSLIOClient.InitComponent;
begin
  LoadSSL;
  inherited;
  FSSLOptions := TSocketSSLOptions.Create;
end;
 
destructor TSocketSSLIOClient.Destroy;
begin
  FreeAndNil(FSSLOptions);
  inherited;
end;
 
procedure TSocketSSLIOClient.StartSSL;
var
  SSLCtx : Pointer;
begin
  LoadSSL;
  if fSSLContext<>nil then FreeAndNil(fSSLContext);
  fSSLContext := TIdSSLContext.Create;
  SSLCtx      := SSL_CTX_new(SSLv23_client_method);
  if SSLCtx<>nil then
  begin
    TSocketSSLContext(fSSLContext).fContext := SSLCtx;
    SSL_CTX_ctrl(SSLCtx,SSL_CTRL_OPTIONS,SSL_OP_STRONG,nil);
    SSL_CTX_ctrl(SSLCtx,SSL_CTRL_EXTRA_CHAIN_CERT,0,FSSLOptions.FCACert);
    SSL_CTX_use_certificate(SSLCtx,FSSLOptions.FCert);
    SSL_CTX_use_PrivateKey(SSLCtx,FSSLOptions.FPrivateKey);
    if FSSLOptions.FCiphers<>'' then SSL_CTX_set_cipher_list(SSLCtx,PAnsiChar(FSSLOptions.FCiphers));
    fSSLContext.Mode := sslmClient;
  end
  else
  begin
    if (not PassThrough) then
    begin
      FreeAndNil(fSSLContext);
      EIdOSSLCreatingContextError.RaiseException(RSSSLCreatingContextError);
    end;
  end;
  if (not PassThrough) then OpenEncodedConnection;
end;
///////////////////////////////////////////////////////////////////////////
procedure TSocketSSLIOServer.InitComponent;
begin
  LoadSSL;
  inherited;
  FSSLOptions := TSocketSSLOptions.Create;
end;
 
destructor TSocketSSLIOServer.Destroy;
begin
  FSSLOptions.Free;
  inherited;
end;
 
procedure TSocketSSLIOServer.Init;
var
  SSLCtx : Pointer;
begin
  LoadSSL;
  if fSSLContext<>nil then FreeAndNil(fSSLContext);
  fSSLContext := TIdSSLContext.Create;
  SSLCtx      := SSL_CTX_new(SSLv23_server_method);
  if SSLCtx<>nil then
  begin
    TSocketSSLContext(fSSLContext).fContext := SSLCtx;
    SSL_CTX_ctrl(SSLCtx,SSL_CTRL_OPTIONS,SSL_OP_STRONG,nil);
    SSL_CTX_ctrl(SSLCtx,SSL_CTRL_SET_ECDH_AUTO,1,nil);
    SSL_CTX_ctrl(SSLCtx,SSL_CTRL_EXTRA_CHAIN_CERT,0,FSSLOptions.FCACert);
    SSL_CTX_use_certificate(SSLCtx,FSSLOptions.FCert);
    SSL_CTX_use_PrivateKey(SSLCtx,FSSLOptions.FPrivateKey);
    if FSSLOptions.FCiphers<>'' then SSL_CTX_set_cipher_list(SSLCtx,PAnsiChar(FSSLOptions.FCiphers));
  end
  else
  begin
    FreeAndNil(fSSLContext);
    EIdOSSLCreatingContextError.RaiseException(RSSSLCreatingContextError);
  end;
end;
///////////////////////////////////////////////////////////////////////////
constructor TSocketContext.Create(AConnection:TIdTCPConnection;AYarn:TIdYarn;AList:TIdContextThreadList);
begin
  inherited;
  FSocketCopress := nil;
  FConnection    := AConnection;
  FIOHandler     := FConnection.IOHandler;
  Timeout        := -1;
  FRemoteIP      := FConnection.Socket.BoundIP;
  FRemotePort    := FConnection.Socket.BoundPort;
  FLastError     := 0;
  FLastErrorDesc := '';
  FLastAccess    := Now;
end;
 
procedure TSocketContext.HandleException(AException: Exception);
begin
  inherited;
  HandleSocketException(AException,FLastError);
  FLastErrorDesc := AException.Message;
end;
 
procedure TSocketContext.ClearErrors;
begin
  FLastError     := 0;
  FLastErrorDesc := '';
end;
 
procedure TSocketContext.SetTimeout(Seconds: Integer);
var
  ms : Int64;
begin
  if Seconds<=0 then ms := -1
                else ms := Seconds*1000;
  if ms>MaxInt then ms := -1;
  FConnection.IOHandler.ReadTimeout := ms;
end;
 
function TSocketContext.Connected: Boolean;
begin
  Result := FConnection.Connected;
end;
 
procedure TSocketContext.Disconnect;
begin
  try
    FConnection.Disconnect;
  except
  end;
end;
 
function TSocketContext.ReadBytes(ToRead:Integer):TBytes;
var
  Expand : Boolean;
begin
  ClearErrors;
  SetLength(Result,0);
  if ToRead=0 then Exit;
  if ToRead<0 then Expand := True else
  begin
    SetLength(Result,ToRead);
    Expand := False;
  end;
  try
    FIOHandler.ReadBytes(TIdBytes(Result),ToRead,Expand);
  except
    on E: Exception do
    begin
      ToRead := 0;
      HandleException(E);
    end;
  end;
  if (ToRead>0) and (Length(Result)<>ToRead) then Result := nil;
end;
 
function TSocketContext.WriteBytes(Value:TBytes;StartPos:Integer;ToWrite:Integer): Boolean;
begin
  ClearErrors;
  Result := True;
  if ToWrite<=0 then ToWrite := Length(Value)-Startpos;
  if ToWrite>0 then
  begin
    try
      FIOHandler.Write(TIdBytes(Value),ToWrite,StartPos);
    except
      on E: Exception do
      begin
        Result := False;
        HandleException(E);
      end;
    end;
  end;
end;
 
function TSocketContext.ReadByte:Byte;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadByte;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketContext.ReadSmallInt:SmallInt;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadInt16;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketContext.ReadWord:Word;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadUInt16;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketContext.ReadInteger:Integer;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadInt32;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketContext.ReadCardinal:Cardinal;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadUInt32;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketContext.ReadLargeInt:Int64;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadInt64;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketContext.WriteByte(const Value:Byte):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketContext.WriteSmallInt(Value:SmallInt):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketContext.WriteWord(Value:Word):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketContext.WriteInteger(Value:Integer):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketContext.WriteCardinal(Value:Cardinal):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketContext.WriteLargeInt(Value:Int64):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketContext.Read:TBytes;
var
  ToRead : Integer;
begin
  if Connected then ToRead := ReadInteger
               else ToRead := 0;
  Result := ReadBytes(ToRead);
  if Assigned(FSocketCopress) then Result := FSocketCopress.Decompress(Result);
end;
 
function TSocketContext.Write(Value:TBytes;StartPos:Integer;ToWrite:Integer):Boolean;
begin
  if ToWrite=-1 then ToWrite := Length(Value)-StartPos;
  if Assigned(FSocketCopress) then
  begin
    Value  := FSocketCopress.Compress(Value,StartPos,ToWrite);
    Result := WriteInteger(Length(Value)) and WriteBytes(Value);
  end
  else Result := WriteInteger(ToWrite) and WriteBytes(Value,StartPos,ToWrite);
end;
 
function TSocketContext.WriteThenRead(const Data:TBytes;var SocketErrorCode:Integer):TBytes;
begin
  if Write(Data) then Result := Read
                 else Result := nil;
end;
///////////////////////////////////////////////////////////////////////////
procedure TSocketClient.InitComponent;
begin
  LoadSSL;
  inherited;
  Host           := '';
  Port           := 0;
  Timeout        := -1;
  FCompressClass := nil;
  FSocketCopress := nil;
  FEnableSSL     := False;
  FCert          := '';
  FCACert        := '';
  FPrivateKey    := '';
  FKeyPassword   := '';
  FP12           := nil;
  FSSLHandler    := TSocketSSLIOClient.Create(Self);
end;
 
destructor TSocketClient.Destroy;
begin
  inherited;
  if FSocketCopress<>nil then FreeAndNil(FSocketCopress);
end;
 
procedure TSocketClient.SetTimeout(Seconds: Integer);
var
  ms : Int64;
begin
  if Seconds<=0 then ms := -1
                else ms := Seconds*1000;
  if ms>MaxInt then ms := -1;
  ReadTimeout := ms;
end;
 
procedure TSocketClient.SetCopressClass(Value: TSocketCopressClass);
begin
  if FCompressClass=Value then Exit;
  if FSocketCopress<>nil then FreeAndNil(FSocketCopress);
  if FCompressClass<>nil then FSocketCopress := FCompressClass.Create;
end;
 
function TSocketClient.GetCert(Index: Integer): string;
begin
  case index of
    1: Result := FCACert;
    2: Result := FCert;
    3: Result := FPrivateKey;
    4: Result := FKeyPassword;
    5: Result := FCiphers;
  end;
end;
 
procedure TSocketClient.SetCert(Index:Integer;Value:string);
begin
  Value := Trim(Value);
  case index of
    1:
    begin
      FCACert                       := Value;
      FSSLHandler.SSLOptions.CACert := Value
    end;
    2:
    begin
      FCert                       := Value;
      FSSLHandler.SSLOptions.Cert := Value;
    end;
    3:
    begin
      FPrivateKey                       := Value;
      FSSLHandler.SSLOptions.PrivateKey := Value
    end;
    4:
    begin
      FKeyPassword                       := Value;
      FSSLHandler.SSLOptions.KeyPassword := Value
    end;
    5:
    begin
      FCiphers                       := Value;
      FSSLHandler.SSLOptions.Ciphers := Value
    end;
  end;
end;
 
procedure TSocketClient.DoOnConnected;
begin
  if Assigned(FOnConnect) then FOnConnect(Self);
end;
 
procedure TSocketClient.DoOnDisconnected;
begin
  try
    IOHandler.InputBuffer.Clear;
  except
  end;
  if Assigned(FOnDisconnect) then FOnDisconnect(Self);
end;
 
procedure TSocketClient.HandleException(AException: Exception);
begin
  HandleSocketException(AException,FLastError);
  FLastErrorDesc := AException.Message;
end;
 
procedure TSocketClient.ClearErrors;
begin
  FLastError     := 0;
  FLastErrorDesc := '';
end;
 
function TSocketClient.LastError:Integer;
begin
  Result := FLastError;
end;
 
function TSocketClient.LastErrorDesc: string;
begin
  Result := FLastErrorDesc;
end;
 
procedure TSocketClient.Connect;
begin
  Host := Trim(Host);
  Disconnect;
  if (Host<>'') or (Port=0) then
  begin
    Exit;
  end;
  if FEnableSSL then IOHandler := FSSLHandler
                else IOHandler :=nil;
end;
 
function TSocketClient.ReadBytes(ToRead:Integer):TBytes;
var
  Expand : Boolean;
begin
  ClearErrors;
  SetLength(Result,0);
  if ToRead=0 then Exit;
  if ToRead<0 then Expand := True else
  begin
    SetLength(Result,ToRead);
    Expand := False;
  end;
  try
    FIOHandler.ReadBytes(TIdBytes(Result),ToRead,Expand);
  except
    on E: Exception do
    begin
      ToRead := 0;
      HandleException(E);
    end;
  end;
  if (ToRead>0) and (Length(Result)<>ToRead) then Result := nil;
end;
 
function TSocketClient.WriteBytes(Value:TBytes;StartPos:Integer;ToWrite:Integer): Boolean;
begin
  ClearErrors;
  Result := True;
  if ToWrite<=0 then ToWrite := Length(Value)-Startpos;
  if ToWrite>0 then
  begin
    try
      FIOHandler.Write(TIdBytes(Value),ToWrite,StartPos);
    except
      on E: Exception do
      begin
        Result := False;
        HandleException(E);
      end;
    end;
  end;
end;
 
function TSocketClient.ReadByte:Byte;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadByte;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketClient.ReadSmallInt:SmallInt;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadInt16;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketClient.ReadWord:Word;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadUInt16;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketClient.ReadInteger:Integer;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadInt32;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketClient.ReadCardinal:Cardinal;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadUInt32;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketClient.ReadLargeInt:Int64;
begin
  ClearErrors;
  Result := 0;
  try
    Result := FIOHandler.ReadInt64;
  except
    on E: Exception do HandleException(E);
  end;
end;
 
function TSocketClient.WriteByte(const Value:Byte):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketClient.WriteSmallInt(Value:SmallInt):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketClient.WriteWord(Value:Word):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketClient.WriteInteger(Value:Integer):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketClient.WriteCardinal(Value:Cardinal):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketClient.WriteLargeInt(Value:Int64):Boolean;
begin
  ClearErrors;
  Result := True;
  try
    FIOHandler.Write(Value);
  except
    on E: Exception do
    begin
      Result := False;
      HandleException(E);
    end;
  end;
end;
 
function TSocketClient.Read:TBytes;
var
  ToRead : Integer;
begin
  if Connected then ToRead := ReadInteger
               else ToRead := 0;
  Result := ReadBytes(ToRead);
  if Assigned(FSocketCopress) then Result := FSocketCopress.Decompress(Result);
end;
 
function TSocketClient.Write(Value:TBytes;StartPos:Integer;ToWrite:Integer):Boolean;
begin
  if ToWrite=-1 then ToWrite := Length(Value)-StartPos;
  if Assigned(FSocketCopress) then
  begin
    Value  := FSocketCopress.Compress(Value,StartPos,ToWrite);
    Result := WriteInteger(Length(Value)) and WriteBytes(Value);
  end
  else Result := WriteInteger(ToWrite) and WriteBytes(Value,StartPos,ToWrite);
end;
 
function TSocketClient.WriteThenRead(const Data:TBytes;var SocketErrorCode:Integer):TBytes;
begin
  if Write(Data) then Result := Read
                 else Result := nil;
end;
///////////////////////////////////////////////////////////////////////////
procedure TSocketServer.InitComponent;
begin
  LoadSSL;
  inherited;
  VerifyCert     := False;
  FCiphers       := SSLStrongCiphers;
  FCompressClass := nil;
  FSocketCopress := nil;
  ContextClass   := TSocketContext;
  FCert          := '';
  FPrivateKey    := '';
  FCACert        := '';
  FKeyPassword   := '';
  FP12           := nil;
  FEnableSSL     := False;
  FPassThrough   := False;
  FSSLHandler    := TSocketSSLIOServer.Create(Self);
end;
 
destructor TSocketServer.Destroy;
begin
  if Contexts.Count=0 then ;
  inherited;
  if FSocketCopress<>nil then FreeAndNil(FSocketCopress);
end;
 
function TSocketServer.GetCert(Index: Integer): string;
begin
  case index of
    1: Result := FCACert;
    2: Result := FCert;
    3: Result := FPrivateKey;
    4: Result := FKeyPassword;
    5: Result := FCiphers;
  end;
end;
 
procedure TSocketServer.SetCert(Index:Integer;Value:string);
begin
  Value := Trim(Value);
  case index of
    1: FCACert      := Value;
    2: FCert        := Value;
    3: FPrivateKey  := Value;
    4: FKeyPassword := Value;
    5: FCiphers     := Value;
  end;
end;
 
procedure TSocketServer.SetCopressClass(Value: TSocketCopressClass);
begin
  if FCompressClass=Value then Exit;
  if FSocketCopress<>nil then FreeAndNil(FSocketCopress);
  if FCompressClass<>nil then FSocketCopress := FCompressClass.Create;
end;
 
procedure TSocketServer.SetActive(Value: Boolean);
begin
  if Value and FEnableSSL then
  begin
    FSSLHandler.FSSLOptions.KeyPassword := FKeyPassword; {do not localize}
    if FP12<>nil then
    begin
      FSSLHandler.FSSLOptions.CACert     := '';
      FSSLHandler.FSSLOptions.Cert       := '';
      FSSLHandler.FSSLOptions.PrivateKey := '';
      FSSLHandler.FSSLOptions.P12        := FP12;
    end
    else
    begin
      FSSLHandler.FSSLOptions.CACert     := FCACert;
      FSSLHandler.FSSLOptions.Cert       := FCert;
      FSSLHandler.FSSLOptions.PrivateKey := FPrivateKey;
    end;
    FSSLHandler.FSSLOptions.Ciphers      := FCiphers;
    FSSLHandler.FSSLOptions.FPassThrough := FPassThrough;
    IOHandler                            := FSSLHandler;
  end
  else IOHandler := nil;
  try
    inherited SetActive(Value);
  except
  end;
end;
 
procedure TSocketServer.CheckOkToBeActive;
begin
  if not Assigned(FOnExecute) then raise EIdTCPNoOnExecute.Create(RSNoOnExecute);
end;
 
procedure TSocketServer.DoConnect(AContext:TIdContext);
begin
  TSocketContext(AContext).FRemoteIP   := AContext.Binding.PeerIP;
  TSocketContext(AContext).FRemotePort := AContext.Binding.PeerPort;
  if Assigned(FOnConnect) then FOnConnect(TSocketContext(AContext));
  if FEnableSSL then TIdSSLIOHandlerSocketOpenSSL(AContext.Connection.IOHandler).PassThrough := PassThrough;
end;
 
procedure TSocketServer.DoDisconnect(AContext:TIdContext);
begin
  if Assigned(FOnDisconnect) then FOnDisconnect(TSocketContext(AContext));
end;
 
function TSocketServer.DoExecute(AContext:TIdContext):Boolean;
begin
  Result := FOnExecute(TSocketContext(AContext));
end;
///////////////////////////////////////////////////////////////////////////
end.
Remy Lebeau (Te...


Posts: 9,447
Registered: 12/23/01
Re: Indy SSL with in memory certificates (PEM & PKCS12)
Click to report abuse...   Click to reply to this thread Reply
  Posted: Jan 4, 2018 2:09 PM   in response to: Hafedh TRIMECHE in response to: Hafedh TRIMECHE
Hafedh TRIMECHE wrote:

This is an implementation of Server & Client using in memory SSL
certificates (separated PEM or PKCS12).

That is a LOT of code just to load certificates from memory instead of
files. Couldn't you simplify it any better? And most of the code you
showed isn't even relevant to certificate usage at all.

What you present looks interesting, but I can't integrate something
like that into Indy the way it has been shown.

--
Remy Lebeau (TeamB)
Hafedh TRIMECHE

Posts: 107
Registered: 12/29/06
Re: Indy SSL with in memory certificates (PEM & PKCS12)
Click to report abuse...   Click to reply to this thread Reply
  Posted: Jan 6, 2018 10:19 AM   in response to: Remy Lebeau (Te... in response to: Remy Lebeau (Te...
Remy Lebeau (TeamB) wrote:
Hafedh TRIMECHE wrote:

This is an implementation of Server & Client using in memory SSL
certificates (separated PEM or PKCS12).

That is a LOT of code just to load certificates from memory instead of
files. Couldn't you simplify it any better? And most of the code you
showed isn't even relevant to certificate usage at all.

What you present looks interesting, but I can't integrate something
like that into Indy the way it has been shown.

--
Remy Lebeau (TeamB)

Please consider this concise version.

unit uTCPSSL;
interface
uses
  Classes,SysUtils,
  IdGlobal,IdSSLOpenSSLHeaders,IdSSLOpenSSL,IdContext,
  IdIOHandler,IdCustomTCPServer,IdTCPServer,IdTCPClient;
(*
  https://testssl.sh/
  used for testing SSL/TLS
*)
const
  WSANO_RECOVERY = 11003;
 
  SSL_OP_STRONG =
    SSL_OP_ALL                                    or
    SSL_OP_NO_SSLv2 or SSL_OP_NO_SSLv3            or
    SSL_OP_NO_TLSv1 or SSL_OP_NO_TLSv1_1          or
    SSL_OP_CIPHER_SERVER_PREFERENCE               or
    SSL_OP_SINGLE_DH_USE                          or
    SSL_OP_SINGLE_ECDH_USE                        or
    SSL_OP_NO_SESSION_RESUMPTION_ON_RENEGOTIATION ;
 
  SSLStrongCiphers =
    'ECDHE-RSA-AES256-GCM-SHA384:' +
    'ECDHE-RSA-AES256-SHA384:'     +
    'ECDHE-RSA-AES256-SHA:'        +
    'AES256-GCM-SHA384:'           +
    /////////////////////////////////
    'AES256-SHA256:'   +
    'AES256-SHA:'      +
    'CAMELLIA256-SHA:' +
    /////////////////////////////////
    '!aNULL:'       +
    '!eNULL:'       +
    '!EXPORT:'      +
    '!RC4:'         +
    '!DES:'         +
    '!MD5@STRENGTH' ;
    /////////////////////////////////
type
  TTCPContext            = class;
  TTCPContextClass       = class of TTCPContext;
  TTCPClient             = class;
  TTCPClientEvent        = procedure(Client:TTCPClient) of object;
  TTCPVerifyEvent        = function(Client:TTCPClient;const Certificate:string):Boolean of object;
  TTCPServerEvent        = procedure(AContext:TTCPContext) of object;
  TTCPServerVerifyEvent  = function(AContext:TTCPContext;const Certificate:string):Boolean of object;
  TTCPServerExecuteEvent = function(AContext:TTCPContext):Boolean of object;
 
  TTCPSSLOptions=class
  private
    FKeyPassword   : RawByteString;
    FCACertPEM     : RawByteString;
    FCertPEM       : RawByteString;
    FPrivateKeyPEM : RawByteString;
    FP12           : TBytes;
    FCiphers       : RawByteString;
    FCACert        : PX509;
    FCert          : PX509;
    FPrivateKey    : PEVP_PKEY;
    procedure SetCert(Index:Integer;Value:string);
    procedure SetP12(Value:TBytes);
    procedure PrepareSSL;
  public
    constructor Create;
    destructor  Destroy;override;
    property    CACert      : string index 1 write SetCert;
    property    Cert        : string index 2 write SetCert;
    property    PrivateKey  : string index 3 write SetCert;
    property    KeyPassword : string index 4 write SetCert;
    property    Ciphers     : string index 5 write SetCert;
    property    P12         : TBytes write FP12;
  end;
 
  TTCPSSLIOClient = class(TIdSSLIOHandlerSocketOpenSSL)
  private
    FSSLOptions : TTCPSSLOptions;
    FSSLCtx     : Pointer;
    property PassThrough;
  protected
    procedure InitComponent;override;
  public
    destructor Destroy;override;
    property   SSLOptions:TTCPSSLOptions read FSSLOptions write FSSLOptions;
    procedure  StartSSL;override;
  end;
 
  TTCPSSLIOServer = class(TIdServerIOHandlerSSLOpenSSL)
  private
    FSSLOptions : TTCPSSLOptions;
    FSSLCtx     : Pointer;
  protected
    procedure InitComponent;override;
  public
    procedure  Init;override;
    destructor Destroy;override;
    property   SSLOptions:TTCPSSLOptions read FSSLOptions write FSSLOptions;
  end;
 
  TTCPContext = class(TIdServerContext)
  private
    FPeerCertificate : string;
  public
    property PeerCertificate:string read FPeerCertificate;
  end;
 
  TTCPClient=class(TIdTCPClient)
  private
  var
    FCert            ,
    FPrivateKey      ,
    FCACert          ,
    FKeyPassword     ,
    FCiphers         : string;
    FP12             : TBytes;
    FSSLEnabled      : Boolean;
    FSSLHandler      : TTCPSSLIOClient;
    FPeerCertificate : string;
    FOnVerify        : TTCPVerifyEvent;
    FOnConnect       : TTCPClientEvent;
    FOnDisconnect    : TTCPClientEvent;
    function  GetCert(Index:Integer):string;
    procedure SetCert(Index:Integer;Value:string);
  protected
    procedure InitComponent;override;
    procedure DoOnConnected;override;
    procedure DoOnDisconnected;override;
  public
    property   CACert      : string index 1 read GetCert write SetCert;
    property   Cert        : string index 2 read GetCert write SetCert;
    property   PrivateKey  : string index 3 read GetCert write SetCert;
    property   KeyPassword : string index 4 read GetCert write SetCert;
    property   Ciphers     : string index 5 read GetCert write SetCert;
    property   P12         : TBytes read FP12 write FP12;
 
    property   SSLEnabled:Boolean  read FSSLEnabled write FSSLEnabled;
 
    procedure  Connect;override;
    function   Connected:Boolean;override;
 
    property   PeerCertificate:string read FPeerCertificate;
 
    property   OnVerify     : TTCPVerifyEvent read FOnVerify     write FOnVerify;
    property   OnConnect    : TTCPClientEvent read FOnConnect    write FOnConnect;
    property   OnDisconnect : TTCPClientEvent read FOnDisconnect write FOnDisconnect;
  end;
 
  TTCPServer=class(TIdTCPServer)
  private
    FCACert        ,
    FCert          ,
    FPrivateKey    ,
    FKeyPassword   ,
    FCiphers       : string;
    FP12           : TBytes;
    FSSLEnabled    : Boolean;
    FSSLHandler    : TTCPSSLIOServer;
    FOnVerify      : TTCPServerVerifyEvent;
    FOnConnect     : TTCPServerEvent;
    FOnDisconnect  : TTCPServerEvent;
    FOnExecute     : TTCPServerExecuteEvent;
    function  GetCert(Index:Integer):string;
    procedure SetCert(Index:Integer;Value:string);
  protected
    procedure InitComponent;override;
    procedure CheckOkToBeActive;override;
    procedure SetActive(Value:Boolean);override;
    procedure DoConnect(AContext:TIdContext);override;
    procedure DoDisconnect(AContext:TIdContext);override;
    function  DoExecute(AContext:TIdContext):Boolean;override;
  public
    property   CACert      : string index 1 read GetCert write SetCert;
    property   Cert        : string index 2 read GetCert write SetCert;
    property   PrivateKey  : string index 3 read GetCert write SetCert;
    property   KeyPassword : string index 4 read GetCert write SetCert;
    property   Ciphers     : string index 5 read GetCert write SetCert;
    property   P12         : TBytes read FP12 write FP12;
 
    property   SSLEnabled:Boolean  read FSSLEnabled write FSSLEnabled;
 
    property   OnVerify     : TTCPServerVerifyEvent  read FOnVerify     write FOnVerify;
    property   OnConnect    : TTCPServerEvent        read FOnConnect    write FOnConnect;
    property   OnDisconnect : TTCPServerEvent        read FOnDisconnect write FOnDisconnect;
    property   OnExecute    : TTCPServerExecuteEvent read FOnExecute    write FOnExecute;
  end;
 
implementation
 
uses
  IdCTypes,IdStackConsts,IdStack,
  IdResourceStringsCore,IdResourceStringsProtocols,
  IdSSL,IdExplicitTLSClientServerBase;
 
const
  SSL_CTRL_SET_ECDH_AUTO = 94;
var
  SSLLoaded : Boolean = False;
 
procedure LoadSSL;
begin
  if SSLLoaded then Exit;
  SSLLoaded := True;
  LoadOpenSSLLibrary;
end;
 
///////////////////////////////////////////////////////////////////////////
function X509ToPEM(X509:Pointer):string;
var
  MemIO     : pBIO;
  iResult   : Integer;
  RawResult : RawByteString;
  P         : Pointer;
begin
  Result := '';
  if X509=nil then Exit;
  MemIO   := BIO_new(BIO_s_mem);
  iResult := PEM_write_bio_X509(MemIO,X509);
  if iResult=1 then
  begin
    P := nil;
    SetLength(RawResult,BIO_get_mem_data(MemIO,P));
    if RawResult<>'' then BIO_read(MemIO,PAnsiChar(RawResult),Length(RawResult));
    Result := string(RawResult);
  end;
  BIO_free(MemIO);
end;
 
procedure LoadCert(PEM:RawByteString;var x509:PX509);
var
  Buffer : PBIO;
begin
  if x509<>nil then X509_free(x509);
  x509 := nil;
  if Length(PEM)=0 then Exit;
  Buffer := BIO_new_mem_buf(PAnsiChar(PEM),Length(PEM));
  try
    x509 := PEM_read_bio_X509(Buffer,nil,nil,nil);
  finally
    BIO_free(Buffer);
  end;
end;
 
procedure LoadKey(PEM:RawByteString;const KeyPassword:RawByteString;var xKey:PEVP_PKEY);
var
  Buffer : PBIO;
begin
  if xKey<>nil then EVP_PKEY_free(xKey);
  if Length(PEM)=0 then Exit;
  Buffer := BIO_new_mem_buf(PAnsiChar(PEM),Length(PEM));
  try
    xKey := PEM_read_bio_PrivateKey(Buffer,nil,nil,PAnsiChar(KeyPassword));
  finally
    BIO_free(Buffer);
  end;
end;
///////////////////////////////////////////////////////////////////////////
constructor TTCPSSLOptions.Create;
begin
  FKeyPassword := '';
  FCACert      := nil;
  FCert        := nil;
  FPrivateKey  := nil;
  FCiphers     := '';
  FP12         := nil;
end;
 
destructor TTCPSSLOptions.Destroy;
begin
  (*
  if FCACert<>nil then X509_free(FCACert);
  if FCert<>nil then X509_free(FCert);
  if FPrivateKey<>nil then EVP_PKEY_free(FPrivateKey);
  *)
  inherited;
end;
 
procedure TTCPSSLOptions.SetCert(Index:Integer;Value:string);
var
  RawValue : RawByteString;
begin
  RawValue := RawByteString(Trim(Value));
  case index of
    1: FCACertPEM     := RawValue;
    2: FCertPEM       := RawValue;
    3: FPrivateKeyPEM := RawValue;
    4: FKeyPassword   := RawByteString(Value);
    5: FCiphers       := RawByteString(Value);
  end;
end;
 
procedure TTCPSSLOptions.SetP12(Value: TBytes);
var
  MemIO     : PBIO;
  p12       : PPKCS12;
  xCA       : PSTACK_OF_X509;
  Err       ,
  i         : Integer;
  CertChain : string;
procedure Clear;
begin
  if xCA        <>nil then sk_pop_free(xCA,@X509_free);
  if FCACert    <>nil then X509_free(FCACert);
  if FCert      <>nil then X509_free(FCert);
  if FPrivateKey<>nil then EVP_PKEY_free(FPrivateKey);
  xCA         := nil;
  FCACert     := nil;
  FCert       := nil;
  FPrivateKey := nil;
end;
begin
  if Value=nil then Exit;
  xCA := nil;
  Clear;
  MemIO := BIO_new_mem_buf(@Value[0],Length(Value));
  p12   := d2i_PKCS12_bio(MemIO,nil);
  Err   := 1;
  if Assigned(p12) then
  begin
    Err := PKCS12_parse(p12,PAnsiChar(FKeyPassword),FPrivateKey,FCert,@xCA);
    PKCS12_free(p12);
  end;
  BIO_free(MemIO);
  if Err<=0 then Clear else
  begin
    if xCA<>nil then
    begin
      CertChain := '';
      for i:=0 to sk_num(xCA)-1 do CertChain := X509ToPEM(sk_value(xCA,i))+CertChain;
      sk_pop_free(xCA,@X509_free);
      CACert := CertChain;
      LoadCert(FCACertPEM,FCACert);
    end;
  end;
end;
 
procedure TTCPSSLOptions.PrepareSSL;
begin
  if FP12=nil then
  begin
    LoadCert(FCACertPEM,FCACert);
    LoadCert(FCertPEM,FCert);
    LoadKey(FPrivateKeyPEM,FKeyPassword,FPrivateKey);
  end
  else SetP12(FP12);
end;
///////////////////////////////////////////////////////////////////////////
type
  TTCPSSLSocket=class(TIdSSLSocket)
  end;
 
  TTCPSSLContext=class(TIdSSLContext)
  end;
///////////////////////////////////////////////////////////////////////////
function VerifyCallback(Ok: TIdC_INT; ctx: PX509_STORE_CTX): TIdC_INT; cdecl;
begin
  Result := 1;
end;
 
procedure TTCPSSLIOClient.InitComponent;
begin
  LoadSSL;
  inherited;
  FSSLOptions := TTCPSSLOptions.Create;
  PassThrough := True;
end;
 
destructor TTCPSSLIOClient.Destroy;
begin
  if fSSLContext<>nil then FreeAndNil(fSSLContext);
  inherited;
end;
 
procedure TTCPSSLIOClient.StartSSL;
begin
  LoadSSL;
  if fSSLContext<>nil then FreeAndNil(fSSLContext);
  fSSLContext      := TIdSSLContext.Create;
  fSSLContext.Mode := sslmClient;
  FSSLCtx          := SSL_CTX_new(SSLv23_client_method);
  if FSSLCtx<>nil then
  begin
    FSSLOptions.PrepareSSL;
    TTCPSSLContext(fSSLContext).fContext := FSSLCtx;
    SSL_CTX_set_options(FSSLCtx,SSL_OP_STRONG);
    SSL_CTX_ctrl(FSSLCtx,SSL_CTRL_SET_ECDH_AUTO,1,nil);
    SSL_CTX_add_extra_chain_cert(FSSLCtx,FSSLOptions.FCACert);
    SSL_CTX_use_certificate(FSSLCtx,FSSLOptions.FCert);
    SSL_CTX_use_PrivateKey(FSSLCtx,FSSLOptions.FPrivateKey);
    SSL_CTX_set_verify(FSSLCtx,SSL_VERIFY_PEER,VerifyCallback);
    SSL_CTX_set_verify_depth(FSSLCtx,0);
    if FSSLOptions.FCiphers<>'' then SSL_CTX_set_cipher_list(FSSLCtx,PAnsiChar(FSSLOptions.FCiphers));
  end
  else
  begin
    FreeAndNil(fSSLContext);
    EIdOSSLCreatingContextError.RaiseException(RSSSLCreatingContextError);
  end;
  try
    if (not PassThrough) then OpenEncodedConnection;
  except
  end;
end;
///////////////////////////////////////////////////////////////////////////
procedure TTCPSSLIOServer.InitComponent;
begin
  LoadSSL;
  inherited;
  FSSLCtx     := nil;
  FSSLOptions := TTCPSSLOptions.Create;
end;
 
destructor TTCPSSLIOServer.Destroy;
begin
  if fSSLContext<>nil then FreeAndNil(fSSLContext);
  FreeAndNil(FSSLOptions);
  inherited;
end;
 
procedure TTCPSSLIOServer.Init;
begin
  LoadSSL;
  if fSSLContext<>nil then FreeAndNil(fSSLContext);
  fSSLContext      := TIdSSLContext.Create;
  fSSLContext.Mode := sslmServer;
  FSSLCtx          := SSL_CTX_new(SSLv23_server_method);
  if FSSLCtx<>nil then
  begin
    FSSLOptions.PrepareSSL;
    TTCPSSLContext(fSSLContext).fContext := FSSLCtx;
    SSL_CTX_set_options(FSSLCtx,SSL_OP_STRONG);
    SSL_CTX_ctrl(FSSLCtx,SSL_CTRL_SET_ECDH_AUTO,1,nil);
    SSL_CTX_add_extra_chain_cert(FSSLCtx,FSSLOptions.FCACert);
    SSL_CTX_use_certificate(FSSLCtx,FSSLOptions.FCert);
    SSL_CTX_use_PrivateKey(FSSLCtx,FSSLOptions.FPrivateKey);
    SSL_CTX_set_verify(FSSLCtx,SSL_VERIFY_PEER or SSL_VERIFY_CLIENT_ONCE,VerifyCallback);
    SSL_CTX_set_verify_depth(FSSLCtx,0);
    if FSSLOptions.FCiphers<>'' then SSL_CTX_set_cipher_list(FSSLCtx,PAnsiChar(FSSLOptions.FCiphers));
  end
  else
  begin
    FreeAndNil(fSSLContext);
    EIdOSSLCreatingContextError.RaiseException(RSSSLCreatingContextError);
  end;
end;
///////////////////////////////////////////////////////////////////////////
///////////////////////////////////////////////////////////////////////////
procedure TTCPClient.InitComponent;
begin
  LoadSSL;
  inherited;
  Host             := '';
  Port             := 0;
  FCert            := '';
  FCACert          := '';
  FPrivateKey      := '';
  FKeyPassword     := '';
  FP12             := nil;
  FPeerCertificate := '';
  FOnVerify        := nil;
  FOnConnect       := nil;
  FOnDisconnect    := nil;
  FSSLEnabled      := False;
  FSSLHandler      := TTCPSSLIOClient.Create(Self);
  IOHandler        := FSSLHandler;
end;
 
procedure TTCPClient.Connect;
begin
  FSSLHandler.PassThrough := (not FSSLEnabled);
  try
    inherited;
  except
  end;
end;
 
function TTCPClient.Connected: Boolean;
begin
  try
    Result := inherited;
  except
    Result := False;
  end;
end;
 
function TTCPClient.GetCert(Index: Integer): string;
begin
  case index of
    1: Result := FCACert;
    2: Result := FCert;
    3: Result := FPrivateKey;
    4: Result := FKeyPassword;
    5: Result := FCiphers;
  end;
end;
 
procedure TTCPClient.SetCert(Index:Integer;Value:string);
begin
  Value := Trim(Value);
  case index of
    1:
    begin
      FCACert                       := Value;
      FSSLHandler.SSLOptions.CACert := Value
    end;
    2:
    begin
      FCert                       := Value;
      FSSLHandler.SSLOptions.Cert := Value;
    end;
    3:
    begin
      FPrivateKey                       := Value;
      FSSLHandler.SSLOptions.PrivateKey := Value
    end;
    4:
    begin
      FKeyPassword                       := Value;
      FSSLHandler.SSLOptions.KeyPassword := Value
    end;
    5:
    begin
      FCiphers                       := Value;
      FSSLHandler.SSLOptions.Ciphers := Value
    end;
  end;
end;
 
procedure TTCPClient.DoOnConnected;
var
  SSLSocket : TTCPSSLSocket;
  x509      : PX509;
  OK        : Boolean;
begin
  FPeerCertificate := '';
  SSLSocket        := TTCPSSLSocket(TTCPSSLIOClient(FIOHandler).SSLSocket);
  if Assigned(SSLSocket) then
  begin
    try
      x509 := SSL_get_peer_certificate(SSLSocket.fSSL);
    except
      x509 := nil;
    end;
    FPeerCertificate := X509ToPEM(x509);
  end;
  if Assigned(FOnVerify) then OK := FOnVerify(Self,FPeerCertificate)
                         else OK := True;
  if (not OK) then
  begin
    try
      Disconnect;
    finally
    end;
    Exit;
  end;
  if Assigned(FOnConnect) then FOnConnect(Self);
end;
 
procedure TTCPClient.DoOnDisconnected;
begin
  try
    IOHandler.InputBuffer.Clear;
  except
  end;
  if Assigned(FOnDisconnect) then FOnDisconnect(Self);
end;
///////////////////////////////////////////////////////////////////////////
procedure TTCPServer.InitComponent;
begin
  LoadSSL;
  inherited;
  FCiphers      := SSLStrongCiphers;
  ContextClass  := TTCPContext;
  FCert         := '';
  FPrivateKey   := '';
  FCACert       := '';
  FKeyPassword  := '';
  FP12          := nil;
  FSSLEnabled   := False;
  FOnVerify     := nil;
  FOnConnect    := nil;
  FOnDisconnect := nil;
  FSSLHandler   := TTCPSSLIOServer.Create(Self);
end;
 
function TTCPServer.GetCert(Index: Integer): string;
begin
  case index of
    1: Result := FCACert;
    2: Result := FCert;
    3: Result := FPrivateKey;
    4: Result := FKeyPassword;
    5: Result := FCiphers;
  end;
end;
 
procedure TTCPServer.SetCert(Index:Integer;Value:string);
begin
  Value := Trim(Value);
  case index of
    1: FCACert      := Value;
    2: FCert        := Value;
    3: FPrivateKey  := Value;
    4: FKeyPassword := Value;
    5: FCiphers     := Value;
  end;
end;
 
procedure TTCPServer.SetActive(Value: Boolean);
begin
  if Value and FSSLEnabled then
  begin
    if FP12<>nil then
    begin
      FSSLHandler.FSSLOptions.CACert     := '';
      FSSLHandler.FSSLOptions.Cert       := '';
      FSSLHandler.FSSLOptions.PrivateKey := '';
      FSSLHandler.FSSLOptions.P12        := FP12;
    end
    else
    begin
      FSSLHandler.FSSLOptions.CACert     := FCACert;
      FSSLHandler.FSSLOptions.Cert       := FCert;
      FSSLHandler.FSSLOptions.PrivateKey := FPrivateKey;
    end;
    FSSLHandler.FSSLOptions.KeyPassword := FKeyPassword;
    FSSLHandler.FSSLOptions.Ciphers     := FCiphers;
    IOHandler                           := FSSLHandler;
  end
  else
  begin
    if Value then IOHandler := nil;
  end;
  try
    inherited SetActive(Value);
  except
  end;
end;
 
procedure TTCPServer.CheckOkToBeActive;
begin
  if not Assigned(FOnExecute) then raise EIdTCPNoOnExecute.Create(RSNoOnExecute);
end;
 
procedure TTCPServer.DoConnect(AContext:TIdContext);
var
  IOHandler : TIdIOHandler;
  SSLSocket : TTCPSSLSocket;
  x509      : PX509;
  OK        : Boolean;
begin
  if FSSLEnabled then
  begin
    IOHandler                              := TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler);
    TTCPSSLIOClient(IOHandler).PassThrough := False;
    SSLSocket                              := TTCPSSLSocket(TTCPSSLIOClient(IOHandler).SSLSocket);
    if Assigned(SSLSocket) then
    begin
      try
        x509 := SSL_get_peer_certificate(SSLSocket.fSSL);
      except
        x509 := nil;
      end;
      TTCPContext(AContext).FPeerCertificate := X509ToPEM(x509);
    end;
    if Assigned(FOnVerify) then OK := FOnVerify(TTCPContext(AContext),TTCPContext(AContext).FPeerCertificate)
                           else OK := True;
  end
  else OK := True;
  if (not OK) then
  begin
    try
      AContext.Connection.Disconnect;
    finally
    end;
    Exit;
  end;
  if Assigned(FOnConnect) then FOnConnect(TTCPContext(AContext));
end;
 
procedure TTCPServer.DoDisconnect(AContext:TIdContext);
begin
  if Assigned(FOnDisconnect) then FOnDisconnect(TTCPContext(AContext));
end;
 
function TTCPServer.DoExecute(AContext:TIdContext):Boolean;
begin
  Result := FOnExecute(TTCPContext(AContext));
end;
 
end.
Legend
Helpful Answer (5 pts)
Correct Answer (10 pts)

Server Response from: ETNAJIVE02