1127 lines
37 KiB
ObjectPascal
1127 lines
37 KiB
ObjectPascal
{******************************************************************************}
|
|
{ }
|
|
{ Library: Fundamentals TLS }
|
|
{ File name: flcTLSTransportServer.pas }
|
|
{ File version: 5.04 }
|
|
{ Description: TLS Transport Server }
|
|
{ }
|
|
{ Copyright: Copyright (c) 2008-2020, David J Butler }
|
|
{ All rights reserved. }
|
|
{ Redistribution and use in source and binary forms, with }
|
|
{ or without modification, are permitted provided that }
|
|
{ the following conditions are met: }
|
|
{ Redistributions of source code must retain the above }
|
|
{ copyright notice, this list of conditions and the }
|
|
{ following disclaimer. }
|
|
{ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND }
|
|
{ CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED }
|
|
{ WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED }
|
|
{ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A }
|
|
{ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL }
|
|
{ THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, }
|
|
{ INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR }
|
|
{ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, }
|
|
{ PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF }
|
|
{ USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) }
|
|
{ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER }
|
|
{ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING }
|
|
{ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE }
|
|
{ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE }
|
|
{ POSSIBILITY OF SUCH DAMAGE. }
|
|
{ }
|
|
{ Github: https://github.com/fundamentalslib }
|
|
{ E-mail: fundamentals.library at gmail.com }
|
|
{ }
|
|
{ Revision history: }
|
|
{ }
|
|
{ 2010/12/02 0.01 Initial development. }
|
|
{ 2010/12/15 0.02 Development. Simple client server test case. }
|
|
{ 2016/01/08 0.03 String changes. }
|
|
{ 2018/07/17 5.04 Revised for Fundamentals 5. }
|
|
{ 2020/05/19 5.08 Sign RSA authentication signature for DHE_RSA. }
|
|
{ }
|
|
{******************************************************************************}
|
|
|
|
{$INCLUDE flcTLS.inc}
|
|
|
|
unit flcTLSTransportServer;
|
|
|
|
interface
|
|
|
|
uses
|
|
{ System }
|
|
|
|
SyncObjs,
|
|
|
|
{ Utils }
|
|
|
|
flcStdTypes,
|
|
|
|
{ Cipher }
|
|
|
|
flcCipherRSA,
|
|
flcCipherDH,
|
|
|
|
{ X509 }
|
|
|
|
flcX509Certificate,
|
|
|
|
{ PEM }
|
|
|
|
flcPEM,
|
|
|
|
{ TLS }
|
|
|
|
flcTLSProtocolVersion,
|
|
flcTLSAlgorithmTypes,
|
|
flcTLSRandom,
|
|
flcTLSCipherSuite,
|
|
flcTLSAlert,
|
|
flcTLSKeyExchangeParams,
|
|
flcTLSCertificate,
|
|
flcTLSKeys,
|
|
flcTLSHandshake,
|
|
flcTLSTransportTypes,
|
|
flcTLSTransportConnection;
|
|
|
|
|
|
|
|
{ }
|
|
{ TLS Server }
|
|
{ }
|
|
const
|
|
DefaultTLSServerOptions = [];
|
|
DefaultTLSServerVersionOptions = AllTLSVersionOptions - [tlsvoSSL3];
|
|
DefaultTLSServerKeyExchangeOptions = AllTLSKeyExchangeOptions;
|
|
DefaultTLSServerCipherOptions = AllTLSCipherOptions;
|
|
DefaultTLSServerHashOptions = AllTLSHashOptions;
|
|
|
|
|
|
|
|
type
|
|
TTLSServer = class;
|
|
|
|
TTLSServerClientState = (
|
|
tlsscInit,
|
|
tlsscHandshakeAwaitingClientHello,
|
|
tlsscHandshakeAwaitingClientKeyExchange,
|
|
tlsscHandshakeAwaitingFinish,
|
|
tlsscConnection
|
|
);
|
|
|
|
TTLSServerClient = class(TTLSConnection)
|
|
protected
|
|
FServer : TTLSServer;
|
|
FUserObj : TObject;
|
|
FClientId : Integer;
|
|
|
|
FClientState : TTLSServerClientState;
|
|
FSessionID : RawByteString;
|
|
FCipherSuite : TTLSCipherSuite;
|
|
FCompression : TTLSCompressionMethod;
|
|
FClientHello : TTLSClientHello;
|
|
FClientHelloRandomStr : RawByteString;
|
|
FServerHello : TTLSServerHello;
|
|
FServerHelloRandomStr : RawByteString;
|
|
FServerKeyExchange : TTLSServerKeyExchange;
|
|
FClientKeyExchange : TTLSClientKeyExchange;
|
|
FPreMasterSecret : RawByteString;
|
|
FMasterSecret : RawByteString;
|
|
FDHState : PDHState;
|
|
|
|
procedure TriggerLog(const LogType: TTLSLogType; const LogMsg: String; const LogLevel: Integer); override;
|
|
procedure TriggerConnectionStateChange; override;
|
|
procedure TriggerAlert(const Level: TTLSAlertLevel; const Description: TTLSAlertDescription); override;
|
|
procedure TriggerHandshakeFinished; override;
|
|
|
|
procedure SetClientState(const State: TTLSServerClientState);
|
|
|
|
procedure TransportLayerSendProc(const Sender: TTLSConnection; const Buffer; const Size: Integer);
|
|
|
|
procedure SelectCompression(var Compression: TTLSCompressionMethod);
|
|
procedure SelectCipherSuite(var CipherSuite: TTLSCipherSuite);
|
|
|
|
procedure InitDHState;
|
|
|
|
procedure InitProtocolVersion;
|
|
procedure InitHandshakeServerHello;
|
|
procedure InitHandshakeServerKeyExchange;
|
|
|
|
procedure SendHandshakeHelloRequest;
|
|
procedure SendHandshakeServerHello;
|
|
procedure SendHandshakeCertificate;
|
|
procedure SendHandshakeServerKeyExchange;
|
|
procedure SendHandshakeCertificateRequest;
|
|
procedure SendHandshakeServerHelloDone;
|
|
procedure SendHandshakeFinished;
|
|
|
|
procedure HandleHandshakeClientHello(const Buffer; const Size: Integer);
|
|
procedure HandleHandshakeCertificateVerify(const Buffer; const Size: Integer);
|
|
procedure HandleHandshakeClientKeyExchange(const Buffer; const Size: Integer);
|
|
procedure HandleHandshakeFinished(const Buffer; const Size: Integer);
|
|
procedure HandleHandshakeMessage(const MsgType: TTLSHandshakeType; const Buffer; const Size: Integer); override;
|
|
|
|
procedure InitCipherSpecNone;
|
|
procedure DoStart;
|
|
|
|
public
|
|
constructor Create(const AServer: TTLSServer; const AUserObj: TObject);
|
|
destructor Destroy; override;
|
|
|
|
property UserObj: TObject read FUserObj;
|
|
procedure Start;
|
|
end;
|
|
|
|
TTLSServerOptions = set of (
|
|
tlssoNone
|
|
);
|
|
|
|
TTLSServerState = (
|
|
tlssInit,
|
|
tlssActive,
|
|
tlssStopped
|
|
);
|
|
|
|
TTLSServerTransportLayerSendProc = procedure (Server: TTLSServer; Client: TTLSServerClient; const Buffer; const Size: Integer) of object;
|
|
TTLSServerNotifyEvent = procedure (Sender: TTLSServer) of object;
|
|
TTLSServerLogEvent = procedure (Sender: TTLSServer; LogType: TTLSLogType; LogMsg: String; LogLevel: Integer) of object;
|
|
TTLSServerClientEvent = procedure (Sender: TTLSServer; Client: TTLSServerClient) of object;
|
|
TTLSServerClientAlertEvent = procedure (Sender: TTLSServer; Client: TTLSServerClient; Level: TTLSAlertLevel; Description: TTLSAlertDescription) of object;
|
|
|
|
TTLSServer = class
|
|
protected
|
|
FOnLog : TTLSServerLogEvent;
|
|
FOnClientStateChange : TTLSServerClientEvent;
|
|
FOnClientAlert : TTLSServerClientAlertEvent;
|
|
FOnClientHandshakeFinished : TTLSServerClientEvent;
|
|
FTransportLayerSendProc : TTLSServerTransportLayerSendProc;
|
|
FServerOptions : TTLSServerOptions;
|
|
FVersionOptions : TTLSVersionOptions;
|
|
FKeyExchangeOptions : TTLSKeyExchangeOptions;
|
|
FCipherOptions : TTLSCipherOptions;
|
|
FHashOptions : TTLSHashOptions;
|
|
FCertificateList : TTLSCertificateList;
|
|
FPrivateKeyRSA : RawByteString;
|
|
FPEMFileName : String;
|
|
FPEMText : RawByteString;
|
|
FDHKeySize : Integer;
|
|
|
|
FLock : TCriticalSection;
|
|
FState : TTLSServerState;
|
|
FClients : array of TTLSServerClient;
|
|
FClientNr : Integer;
|
|
FX509RSAPrivateKey : TX509RSAPrivateKey;
|
|
FRSAPrivateKey : TRSAPrivateKey;
|
|
|
|
procedure Init; virtual;
|
|
|
|
procedure Lock;
|
|
procedure Unlock;
|
|
|
|
procedure Log(const LogType: TTLSLogType; const LogMsg: String; const LogLevel: Integer = 0); overload; virtual;
|
|
procedure Log(const LogType: TTLSLogType; const LogMsg: String; const Args: array of const; const LogLevel: Integer = 0); overload;
|
|
|
|
procedure CheckNotActive;
|
|
procedure CheckActive;
|
|
|
|
procedure SetServerOptions(const AServerOptions: TTLSServerOptions);
|
|
procedure SetVersionOptions(const AVersionOptions: TTLSVersionOptions);
|
|
procedure SetCipherOptions(const ACipherOptions: TTLSCipherOptions);
|
|
procedure SetKeyExchangeOptions(const AKeyExchangeOptions: TTLSKeyExchangeOptions);
|
|
procedure SetHashOptions(const AHashOptions: TTLSHashOptions);
|
|
|
|
procedure SetCertificateList(const List: TTLSCertificateList);
|
|
procedure SetPrivateKeyRSA(const APrivateKeyRSA: RawByteString);
|
|
function GetPrivateKeyRSAPEM: RawByteString;
|
|
procedure SetPrivateKeyRSAPEM(const APrivateKeyRSAPEM: RawByteString);
|
|
procedure SetPEMFileName(const APEMFileName: String);
|
|
procedure SetPEMText(const APEMText: RawByteString);
|
|
procedure SetDHKeySize(const ADHKeySize: Integer);
|
|
|
|
procedure ClientLog(const Client: TTLSServerClient; const LogType: TTLSLogType; const LogMsg: String; const LogLevel: Integer);
|
|
procedure ClientStateChange(const Client: TTLSServerClient);
|
|
procedure ClientAlert(const Client: TTLSServerClient; const Level: TTLSAlertLevel; const Description: TTLSAlertDescription);
|
|
procedure ClientHandshakeFinished(const Client: TTLSServerClient);
|
|
|
|
function CreateClient(const UserObj: TObject): TTLSServerClient; virtual;
|
|
function GetClientCount: Integer;
|
|
function GetClient(const Idx: Integer): TTLSServerClient;
|
|
function GetClientIndex(const Client: TTLSServerClient): Integer;
|
|
|
|
procedure ClientTransportLayerSend(const Sender: TTLSServerClient; const Buffer; const Size: Integer);
|
|
|
|
procedure InitFromPEM;
|
|
procedure InitPrivateKey;
|
|
procedure AllocateSessionID(var SessionID: RawByteString);
|
|
|
|
procedure DoStart;
|
|
procedure DoStop;
|
|
|
|
public
|
|
constructor Create(const ATransportLayerSendProc: TTLSServerTransportLayerSendProc);
|
|
destructor Destroy; override;
|
|
|
|
property OnLog: TTLSServerLogEvent read FOnLog write FOnLog;
|
|
property OnClientAlert: TTLSServerClientAlertEvent read FOnClientAlert write FOnClientAlert;
|
|
property OnClientStateChange: TTLSServerClientEvent read FOnClientStateChange write FOnClientStateChange;
|
|
property OnClientHandshakeFinished: TTLSServerClientEvent read FOnClientHandshakeFinished write FOnClientHandshakeFinished;
|
|
|
|
property ServerOptions: TTLSServerOptions read FServerOptions write SetServerOptions default DefaultTLSServerOptions;
|
|
property VersionOptions: TTLSVersionOptions read FVersionOptions write SetVersionOptions default DefaultTLSServerVersionOptions;
|
|
property KeyExchangeOptions: TTLSKeyExchangeOptions read FKeyExchangeOptions write SetKeyExchangeOptions default DefaultTLSServerKeyExchangeOptions;
|
|
property CipherOptions: TTLSCipherOptions read FCipherOptions write SetCipherOptions default DefaultTLSServerCipherOptions;
|
|
property HashOptions: TTLSHashOptions read FHashOptions write SetHashOptions default DefaultTLSServerHashOptions;
|
|
|
|
property CertificateList: TTLSCertificateList read FCertificateList write SetCertificateList;
|
|
property PrivateKeyRSA: RawByteString read FPrivateKeyRSA write SetPrivateKeyRSA;
|
|
property PrivateKeyRSAPEM: RawByteString read GetPrivateKeyRSAPEM write SetPrivateKeyRSAPEM;
|
|
property PEMFileName: String read FPEMFileName write SetPEMFileName;
|
|
property PEMText: RawByteString read FPEMText write SetPEMText;
|
|
property DHKeySize: Integer read FDHKeySize write SetDHKeySize;
|
|
|
|
property State: TTLSServerState read FState;
|
|
procedure Start;
|
|
procedure Stop;
|
|
|
|
property ClientCount: Integer read GetClientCount;
|
|
property Client[const Idx: Integer]: TTLSServerClient read GetClient;
|
|
function AddClient(const UserObj: TObject): TTLSServerClient;
|
|
procedure RemoveClient(const Client: TTLSServerClient);
|
|
|
|
procedure ProcessTransportLayerReceivedData(
|
|
const AClient: TTLSServerClient;
|
|
const Buffer; const Size: Integer);
|
|
end;
|
|
|
|
|
|
|
|
implementation
|
|
|
|
uses
|
|
{ System }
|
|
SysUtils,
|
|
|
|
{ Utils }
|
|
flcBase64,
|
|
flcHugeInt,
|
|
|
|
{ Cipher }
|
|
flcCipherUtils,
|
|
flcCipherRandom,
|
|
|
|
{ TLS }
|
|
flcTLSErrors,
|
|
flcTLSSessionID,
|
|
flcTLSCipher;
|
|
|
|
|
|
|
|
{ }
|
|
{ TLS Server Client }
|
|
{ }
|
|
constructor TTLSServerClient.Create(const AServer: TTLSServer; const AUserObj: TObject);
|
|
begin
|
|
Assert(Assigned(AServer));
|
|
inherited Create(TransportLayerSendProc);
|
|
FServer := AServer;
|
|
FUserObj := AUserObj;
|
|
end;
|
|
|
|
destructor TTLSServerClient.Destroy;
|
|
begin
|
|
if Assigned(FDHState) then
|
|
begin
|
|
DHStateFinalise(FDHState^);
|
|
Dispose(FDHState);
|
|
FDHState := nil;
|
|
end;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TTLSServerClient.TriggerLog(const LogType: TTLSLogType; const LogMsg: String; const LogLevel: Integer);
|
|
begin
|
|
inherited;
|
|
FServer.ClientLog(self, LogType, LogMsg, LogLevel);
|
|
end;
|
|
|
|
procedure TTLSServerClient.TriggerConnectionStateChange;
|
|
begin
|
|
inherited;
|
|
FServer.ClientStateChange(self);
|
|
end;
|
|
|
|
procedure TTLSServerClient.TriggerAlert(const Level: TTLSAlertLevel; const Description: TTLSAlertDescription);
|
|
begin
|
|
inherited;
|
|
FServer.ClientAlert(self, Level, Description);
|
|
end;
|
|
|
|
procedure TTLSServerClient.TriggerHandshakeFinished;
|
|
begin
|
|
inherited;
|
|
FServer.ClientHandshakeFinished(self);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SetClientState(const State: TTLSServerClientState);
|
|
begin
|
|
FClientState := State;
|
|
end;
|
|
|
|
procedure TTLSServerClient.TransportLayerSendProc(const Sender: TTLSConnection; const Buffer; const Size: Integer);
|
|
begin
|
|
FServer.ClientTransportLayerSend(self, Buffer, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SelectCompression(var Compression: TTLSCompressionMethod);
|
|
begin
|
|
Compression := tlscmNull;
|
|
end;
|
|
|
|
procedure TTLSServerClient.SelectCipherSuite(var CipherSuite: TTLSCipherSuite);
|
|
var
|
|
I : TTLSCipherSuite;
|
|
C : PTLSCipherSuiteInfo;
|
|
begin
|
|
for I := High(TTLSCipherSuite) downto Low(TTLSCipherSuite) do
|
|
if (I <> tlscsNone) and (I in FClientHello.CipherSuites) then
|
|
begin
|
|
C := @TLSCipherSuiteInfo[I];
|
|
if C^.ServerSupport then
|
|
begin
|
|
CipherSuite := I;
|
|
exit;
|
|
end;
|
|
end;
|
|
CipherSuite := tlscsNone;
|
|
end;
|
|
|
|
procedure TTLSServerClient.InitDHState;
|
|
begin
|
|
New(FDHState);
|
|
DHStateInit(FDHState^);
|
|
|
|
(*
|
|
P = 'FFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A63A3620FFFFFFFFFFFFFFFF'
|
|
G = '00000002'
|
|
*)
|
|
|
|
{ HugeWordToHexB(FDHState^.Q);
|
|
HugeWordToHexB(FDHState^.X);
|
|
HugeWordToHexB(FDHState^.Y);
|
|
}
|
|
|
|
(*
|
|
DHInitHashAlgorithm(FDHState^, dhhSHA1);
|
|
|
|
HexToHugeWordB('FFFFFFFFFFFFFFFFC90FDAA22168C234C4C6628B80DC1CD129024E088A67CC74020BBEA63B139B22514A08798E3404DDEF9519B3CD3A431B302B0A6DF25F14374FE1356D6D51C245E485B576625E7EC6F44C42E9A63A3620FFFFFFFFFFFFFFFF',
|
|
FDHState^.P);
|
|
HexToHugeWordB('00000002', FDHState^.G);
|
|
|
|
HexToHugeWordB('AF2FCC0B5ADD8F623266378ADBF72664D5913FFF', FDHState^.Q);
|
|
HexToHugeWordB('8E62C571E6ECCC720CF65E432FA779BE56EFAB46', FDHState^.X);
|
|
HexToHugeWordB('A37CCB97CAB7AC5C3C2B59FC7C33007B2CDD9FA6C616D8BA4A202EC901FE5F37F790295D5DAA990E22121C154B78E2201B36AB4A8944E61D34ADA541221653B49E432B782A5A59806E87ADBCC57033385FB9197CEC137170DD80466D82F431BA',
|
|
FDHState^.Y);
|
|
|
|
FDHState^.PrimePBitCount := DHWellKnownGroup[0].PBitCount;
|
|
FDHState^.PrimeQBitCount := DHWellKnownGroup[0].QBitCount;
|
|
*)
|
|
|
|
//DHGenerateKeys(FDHState^, dhhSHA1, DHQBitCount(FServer.FDHKeySize), FServer.FDHKeySize);
|
|
//// Use well known pairs
|
|
//// x/prikey is a random nr
|
|
|
|
HexToHugeWordB(DHWellKnownGroup[0].P_Hex, FDHState^.P);
|
|
HexToHugeWordB(DHWellKnownGroup[0].G_Hex, FDHState^.G);
|
|
DHDeriveKeysFromGroupParametersPG(
|
|
FDHState^, dhhSHA1, DHWellKnownGroup[0].QBitCount, DHWellKnownGroup[0].PBitCount,
|
|
FDHState^.P, FDHState^.G);
|
|
end;
|
|
|
|
procedure TTLSServerClient.InitProtocolVersion;
|
|
begin
|
|
FProtocolVersion := FClientHello.ProtocolVersion;
|
|
if IsSSL2(FProtocolVersion) then
|
|
raise ETLSError.CreateAlertBadProtocolVersion; // SSL2 not supported
|
|
if IsPostTLS12(FProtocolVersion) then
|
|
FProtocolVersion := TLSProtocolVersion12;
|
|
if not IsKnownTLSVersion(FProtocolVersion) then
|
|
raise ETLSError.CreateAlertBadProtocolVersion; // unknown SSL version
|
|
end;
|
|
|
|
procedure TTLSServerClient.InitHandshakeServerHello;
|
|
begin
|
|
InitTLSServerHello(FServerHello,
|
|
FProtocolVersion,
|
|
FSessionID,
|
|
FCipherSpecNew.CipherSuiteDetails.CipherSuiteInfo^.Rec,
|
|
FCompression);
|
|
|
|
{$IFDEF TLS_TEST_NO_RANDOM_HELLO}
|
|
FClientHello.Random.gmt_unix_time := 123;
|
|
FillChar(FServerHello.Random.random_bytes, 28, 117);
|
|
{$ENDIF}
|
|
|
|
FServerHelloRandomStr := TLSRandomToStr(FServerHello.Random);
|
|
end;
|
|
|
|
procedure TTLSServerClient.InitHandshakeServerKeyExchange;
|
|
begin
|
|
InitTLSServerKeyExchange(FServerKeyExchange);
|
|
|
|
case FCipherSpecNew.KeyExchangeAlgorithm of
|
|
tlskeaDHE_DSS,
|
|
tlskeaDHE_RSA,
|
|
tlskeaDH_Anon :
|
|
begin
|
|
InitDHState;
|
|
|
|
AssignTLSServerKeyExchangeDHParams(
|
|
FServerKeyExchange,
|
|
DHHugeWordKeyEncodeBytes(FDHState^.P),
|
|
DHHugeWordKeyEncodeBytes(FDHState^.G),
|
|
DHHugeWordKeyEncodeBytes(FDHState^.Y)); /////////
|
|
|
|
SignTLSServerKeyExchangeDH_RSA(
|
|
FServerKeyExchange,
|
|
PTLSClientServerRandom(@FClientHello.Random)^,
|
|
PTLSClientServerRandom(@FServerHello.Random)^,
|
|
FServer.FRSAPrivateKey);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
const
|
|
MaxHandshakeHelloRequestSize = 2048;
|
|
MaxHandshakeServerHelloSize = 2048;
|
|
MaxHandshakeCertificateSize = 65536;
|
|
MaxHandshakeServerKeyExchangeSize = 16384;
|
|
MaxHandshakeCertificateRequestSize = 16384;
|
|
MaxHandshakeServerHelloDoneSize = 16384;
|
|
MaxHandshakeFinishedSize = 2048;
|
|
|
|
procedure TTLSServerClient.SendHandshakeHelloRequest;
|
|
var
|
|
Buf : array[0..MaxHandshakeHelloRequestSize - 1] of Byte;
|
|
Size : Integer;
|
|
begin
|
|
Size := EncodeTLSHandshakeHelloRequest(Buf, SizeOf(Buf));
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SendHandshakeServerHello;
|
|
var
|
|
Buf : array[0..MaxHandshakeServerHelloSize - 1] of Byte;
|
|
Size : Integer;
|
|
begin
|
|
InitHandshakeServerHello;
|
|
Size := EncodeTLSHandshakeServerHello(Buf, SizeOf(Buf), FServerHello);
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SendHandshakeCertificate;
|
|
var
|
|
Buf : array[0..MaxHandshakeCertificateSize - 1] of Byte;
|
|
Size : Integer;
|
|
begin
|
|
Size := EncodeTLSHandshakeCertificate(Buf, SizeOf(Buf), FServer.FCertificateList);
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SendHandshakeServerKeyExchange;
|
|
var
|
|
Buf : array[0..MaxHandshakeServerKeyExchangeSize - 1] of Byte;
|
|
Size : Integer;
|
|
begin
|
|
InitHandshakeServerKeyExchange;
|
|
Size := EncodeTLSHandshakeServerKeyExchange(Buf, SizeOf(Buf),
|
|
FCipherSpecNew.KeyExchangeAlgorithm, FServerKeyExchange);
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SendHandshakeCertificateRequest;
|
|
var
|
|
Buf : array[0..MaxHandshakeCertificateRequestSize - 1] of Byte;
|
|
Size : Integer;
|
|
CReq : TTLSCertificateRequest;
|
|
begin
|
|
Size := EncodeTLSHandshakeCertificateRequest(Buf, SizeOf(Buf), CReq);
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SendHandshakeServerHelloDone;
|
|
var
|
|
Buf : array[0..MaxHandshakeServerHelloDoneSize - 1] of Byte;
|
|
Size : Integer;
|
|
begin
|
|
Size := EncodeTLSHandshakeServerHelloDone(Buf, SizeOf(Buf));
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.SendHandshakeFinished;
|
|
var
|
|
Buf : array[0..MaxHandshakeFinishedSize - 1] of Byte;
|
|
Size : Integer;
|
|
begin
|
|
Size := EncodeTLSHandshakeFinished(Buf, SizeOf(Buf), FMasterSecret, FProtocolVersion, FVerifyHandshakeData, False);
|
|
SendHandshake(Buf, Size);
|
|
end;
|
|
|
|
procedure TTLSServerClient.HandleHandshakeClientHello(const Buffer; const Size: Integer);
|
|
begin
|
|
if FClientState <> tlsscHandshakeAwaitingClientHello then
|
|
raise ETLSError.CreateAlertUnexpectedMessage;
|
|
|
|
DecodeTLSClientHello(Buffer, Size, FClientHello);
|
|
FClientHelloRandomStr := TLSRandomToStr(FClientHello.Random);
|
|
{$IFDEF TLS_DEBUG}
|
|
Log(tlsltDebug, 'ClientHello:%s', [TLSProtocolVersionName(FClientHello.ProtocolVersion)]);
|
|
{$ENDIF}
|
|
|
|
InitProtocolVersion;
|
|
{$IFDEF TLS_DEBUG}
|
|
Log(tlsltDebug, 'ProtocolVersion:%s', [TLSProtocolVersionName(FProtocolVersion)]);
|
|
{$ENDIF}
|
|
|
|
SelectCompression(FCompression);
|
|
SelectCipherSuite(FCipherSuite);
|
|
{$IFDEF TLS_DEBUG}
|
|
Log(tlsltDebug, 'CipherSuite:%s', [TLSCipherSuiteInfo[FCipherSuite].Name]);
|
|
{$ENDIF}
|
|
if FCipherSuite = tlscsNone then
|
|
raise ETLSError.CreateAlert(TLSError_BadProtocol, tlsadHandshake_failure);
|
|
InitTLSSecurityParameters(FCipherSpecNew, FCompression, FCipherSuite);
|
|
|
|
SetClientState(tlsscHandshakeAwaitingClientKeyExchange);
|
|
|
|
SendHandshakeServerHello;
|
|
SendHandshakeCertificate;
|
|
|
|
{ The ServerKeyExchange message is sent by the server only when the ServerCertificate message (if sent) }
|
|
{ does not contain enough data to allow the user-agent to exchange a premaster secret. }
|
|
{ This is true for the following key exchange methods: }
|
|
{ RSA_EXPORT (if the public key in the server certificate is longer than 512 bits) }
|
|
{ DHE_DSS, DHE_DSS_EXPORT, DHE_RSA, DHE_RSA_EXPORT, DH_anon }
|
|
{ It is not legal to send the server key exchange message for the following key exchange methods: }
|
|
{ RSA, DH_DSS, DH_RSA, }
|
|
{ RSA_EXPORT (when the public key in the server certificate is less than or equal to 512 bits in length) }
|
|
{ Additionally, a ServerKeyExchange message may be sent, if it is required (e.g., if the server has no }
|
|
{ certificate, or if its certificate is for signing only). If the server is authenticated, it may }
|
|
{ request a certificate from the client. }
|
|
|
|
if FCipherSpecNew.KeyExchangeAlgorithm in [tlskeaDHE_DSS, tlskeaDHE_RSA, tlskeaDH_Anon] then
|
|
SendHandshakeServerKeyExchange;
|
|
|
|
SendHandshakeServerHelloDone;
|
|
end;
|
|
|
|
procedure TTLSServerClient.HandleHandshakeCertificateVerify(const Buffer; const Size: Integer);
|
|
begin
|
|
if FClientState <> tlsscHandshakeAwaitingClientKeyExchange then
|
|
raise ETLSError.CreateAlertUnexpectedMessage;
|
|
end;
|
|
|
|
procedure TTLSServerClient.HandleHandshakeClientKeyExchange(const Buffer; const Size: Integer);
|
|
var
|
|
Yc : HugeWord;
|
|
ZZ : HugeWord;
|
|
begin
|
|
if FClientState <> tlsscHandshakeAwaitingClientKeyExchange then
|
|
raise ETLSError.CreateAlertUnexpectedMessage;
|
|
|
|
DecodeTLSClientKeyExchange(Buffer, Size,
|
|
FCipherSpecNew.KeyExchangeAlgorithm,
|
|
True, FClientKeyExchange);
|
|
|
|
// pre-master-secret
|
|
case FCipherSpecNew.KeyExchangeAlgorithm of
|
|
tlskeaNone : ;
|
|
tlskeaNULL : ;
|
|
tlskeaRSA :
|
|
begin
|
|
{ RFC 5246: When RSA is used for server authentication and key exchange, a 48- }
|
|
{ byte pre_master_secret is generated by the client, encrypted under }
|
|
{ the server's public key, and sent to the server. The server uses its }
|
|
{ private key to decrypt the pre_master_secret. Both parties then }
|
|
{ convert the pre_master_secret into the master_secret, as specified above. }
|
|
|
|
FPreMasterSecret := RSADecryptStr(rsaetRSAES_PKCS1, FServer.FRSAPrivateKey,
|
|
FClientKeyExchange.EncryptedPreMasterSecret);
|
|
end;
|
|
tlskeaDHE_DSS,
|
|
tlskeaDHE_RSA,
|
|
tlskeaDH_Anon :
|
|
begin
|
|
Assert(Assigned(FDHState));
|
|
|
|
{ RFC 5246: A conventional Diffie-Hellman computation is performed. The }
|
|
{ negotiated key (Z) is used as the pre_master_secret, and is converted }
|
|
{ into the master_secret, as specified above. Leading bytes of Z that }
|
|
{ contain all zero bits are stripped before it is used as the }
|
|
{ pre_master_secret }
|
|
|
|
HugeWordInit(Yc);
|
|
HugeWordInit(ZZ);
|
|
DHHugeWordKeyDecodeBytes(Yc, FClientKeyExchange.ClientDiffieHellmanPublic.dh_Yc);
|
|
HugeWordPowerAndMod(ZZ, Yc, FDHState^.X, FDHState^.P);
|
|
|
|
FPreMasterSecret := DHHugeWordKeyEncodeBytes(ZZ);
|
|
|
|
HugeWordFinalise(ZZ);
|
|
HugeWordFinalise(Yc);
|
|
end;
|
|
else
|
|
raise ETLSError.CreateAlert(TLSError_BadProtocol, tlsadHandshake_failure);
|
|
end;
|
|
|
|
case FCipherSpecNew.KeyExchangeAlgorithm of
|
|
tlskeaRSA,
|
|
tlskeaDHE_DSS,
|
|
tlskeaDHE_RSA,
|
|
tlskeaDH_Anon :
|
|
begin
|
|
Assert(FPreMasterSecret <> '');
|
|
FMasterSecret := TLSMasterSecret(FProtocolVersion, FPreMasterSecret,
|
|
FClientHelloRandomStr, FServerHelloRandomStr);
|
|
SecureClearStr(FPreMasterSecret);
|
|
|
|
GenerateTLSKeys(FProtocolVersion,
|
|
FCipherSpecNew.CipherSuiteDetails.HashInfo^.KeyLength,
|
|
FCipherSpecNew.CipherSuiteDetails.CipherInfo^.KeyBits,
|
|
FCipherSpecNew.CipherSuiteDetails.CipherInfo^.IVSize * 8,
|
|
FMasterSecret,
|
|
FServerHelloRandomStr,
|
|
FClientHelloRandomStr,
|
|
FKeys);
|
|
GenerateFinalTLSKeys(FProtocolVersion,
|
|
FCipherSpecNew.CipherSuiteDetails.CipherInfo^.Exportable,
|
|
FCipherSpecNew.CipherSuiteDetails.CipherInfo^.ExpKeyMat * 8,
|
|
FServerHelloRandomStr,
|
|
FClientHelloRandomStr,
|
|
FKeys);
|
|
|
|
SetEncodeKeys(FKeys.ServerMACKey, FKeys.ServerEncKey, FKeys.ServerIV);
|
|
SetDecodeKeys(FKeys.ClientMACKey, FKeys.ClientEncKey, FKeys.ClientIV);
|
|
end;
|
|
end;
|
|
|
|
SetClientState(tlsscHandshakeAwaitingFinish);
|
|
end;
|
|
|
|
procedure TTLSServerClient.HandleHandshakeFinished(const Buffer; const Size: Integer);
|
|
begin
|
|
if FClientState <> tlsscHandshakeAwaitingFinish then
|
|
raise ETLSError.CreateAlertUnexpectedMessage;
|
|
|
|
SendChangeCipherSpec;
|
|
ChangeEncryptCipherSpec;
|
|
SetClientState(tlsscConnection);
|
|
SetConnectionState(tlscoApplicationData);
|
|
SendHandshakeFinished;
|
|
TriggerHandshakeFinished;
|
|
end;
|
|
|
|
procedure TTLSServerClient.HandleHandshakeMessage(const MsgType: TTLSHandshakeType; const Buffer; const Size: Integer);
|
|
begin
|
|
{$IFDEF TLS_DEBUG}
|
|
Log(tlsltDebug, 'R:Handshake:%s:%db', [TLSHandshakeTypeToStr(MsgType), Size]);
|
|
{$ENDIF}
|
|
|
|
case MsgType of
|
|
tlshtHello_request : ShutdownBadProtocol(tlsadUnexpected_message);
|
|
tlshtClient_hello : HandleHandshakeClientHello(Buffer, Size);
|
|
tlshtServer_hello : ShutdownBadProtocol(tlsadUnexpected_message);
|
|
tlshtCertificate : ShutdownBadProtocol(tlsadUnexpected_message);
|
|
tlshtServer_key_exchange : ShutdownBadProtocol(tlsadUnexpected_message);
|
|
tlshtCertificate_request : ShutdownBadProtocol(tlsadUnexpected_message);
|
|
tlshtServer_hello_done : ShutdownBadProtocol(tlsadUnexpected_message);
|
|
tlshtCertificate_verify : HandleHandshakeCertificateVerify(Buffer, Size);
|
|
tlshtClient_key_exchange : HandleHandshakeClientKeyExchange(Buffer, Size);
|
|
tlshtFinished : HandleHandshakeFinished(Buffer, Size);
|
|
else
|
|
ShutdownBadProtocol(tlsadUnexpected_message);
|
|
end;
|
|
end;
|
|
|
|
procedure TTLSServerClient.InitCipherSpecNone;
|
|
begin
|
|
InitTLSSecurityParametersNone(FCipherEncryptSpec);
|
|
InitTLSSecurityParametersNone(FCipherDecryptSpec);
|
|
TLSCipherInitNone(FCipherEncryptState, tlscoEncrypt);
|
|
TLSCipherInitNone(FCipherDecryptState, tlscoDecrypt);
|
|
end;
|
|
|
|
procedure TTLSServerClient.DoStart;
|
|
begin
|
|
SetConnectionState(tlscoStart);
|
|
InitCipherSpecNone;
|
|
SetConnectionState(tlscoHandshaking);
|
|
SetClientState(tlsscHandshakeAwaitingClientHello);
|
|
FServer.AllocateSessionID(FSessionID);
|
|
end;
|
|
|
|
procedure TTLSServerClient.Start;
|
|
begin
|
|
Assert(FConnectionState = tlscoInit);
|
|
Assert(FClientState = tlsscInit);
|
|
DoStart;
|
|
end;
|
|
|
|
|
|
|
|
{ }
|
|
{ TLS Server }
|
|
{ }
|
|
constructor TTLSServer.Create(const ATransportLayerSendProc: TTLSServerTransportLayerSendProc);
|
|
begin
|
|
inherited Create;
|
|
Init;
|
|
if not Assigned(ATransportLayerSendProc) then
|
|
raise ETLSError.Create(TLSError_InvalidParameter);
|
|
FTransportLayerSendProc := ATransportLayerSendProc;
|
|
end;
|
|
|
|
procedure TTLSServer.Init;
|
|
begin
|
|
FServerOptions := DefaultTLSServerOptions;
|
|
FVersionOptions := DefaultTLSServerVersionOptions;
|
|
FKeyExchangeOptions := DefaultTLSServerKeyExchangeOptions;
|
|
FCipherOptions := DefaultTLSServerCipherOptions;
|
|
FHashOptions := DefaultTLSServerHashOptions;
|
|
|
|
FState := tlssInit;
|
|
FLock := TCriticalSection.Create;
|
|
RSAPrivateKeyInit(FRSAPrivateKey);
|
|
FDHKeySize := 1024;
|
|
end;
|
|
|
|
destructor TTLSServer.Destroy;
|
|
var I : Integer;
|
|
begin
|
|
for I := Length(FClients) - 1 downto 0 do
|
|
FreeAndNil(FClients[I]);
|
|
RSAPrivateKeyFinalise(FRSAPrivateKey);
|
|
FreeAndNil(FLock);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TTLSServer.Lock;
|
|
begin
|
|
Assert(Assigned(FLock));
|
|
FLock.Acquire;
|
|
end;
|
|
|
|
procedure TTLSServer.Unlock;
|
|
begin
|
|
FLock.Release;
|
|
end;
|
|
|
|
procedure TTLSServer.Log(const LogType: TTLSLogType; const LogMsg: String; const LogLevel: Integer);
|
|
begin
|
|
if Assigned(FOnLog) then
|
|
FOnLog(self, LogType, LogMsg, LogLevel);
|
|
end;
|
|
|
|
procedure TTLSServer.Log(const LogType: TTLSLogType; const LogMsg: String; const Args: array of const; const LogLevel: Integer);
|
|
begin
|
|
Log(LogType, Format(LogMsg, Args), LogLevel);
|
|
end;
|
|
|
|
procedure TTLSServer.CheckNotActive;
|
|
begin
|
|
if FState = tlssActive then
|
|
raise ETLSError.Create(TLSError_InvalidState, 'Operation not allowed while active');
|
|
end;
|
|
|
|
procedure TTLSServer.CheckActive;
|
|
begin
|
|
if FState <> tlssActive then
|
|
raise ETLSError.Create(TLSError_InvalidState, 'Operation not allowed while not active');
|
|
end;
|
|
|
|
procedure TTLSServer.SetServerOptions(const AServerOptions: TTLSServerOptions);
|
|
begin
|
|
if AServerOptions = FServerOptions then
|
|
exit;
|
|
CheckNotActive;
|
|
FServerOptions := AServerOptions;
|
|
end;
|
|
|
|
procedure TTLSServer.SetVersionOptions(const AVersionOptions: TTLSVersionOptions);
|
|
begin
|
|
if AVersionOptions = FVersionOptions then
|
|
exit;
|
|
CheckNotActive;
|
|
if AVersionOptions = [] then
|
|
raise ETLSError.Create(TLSError_InvalidParameter, 'Invalid version options');
|
|
FVersionOptions := AVersionOptions;
|
|
end;
|
|
|
|
procedure TTLSServer.SetCipherOptions(const ACipherOptions: TTLSCipherOptions);
|
|
begin
|
|
if ACipherOptions = FCipherOptions then
|
|
exit;
|
|
CheckNotActive;
|
|
if ACipherOptions = [] then
|
|
raise ETLSError.Create(TLSError_InvalidParameter, 'Invalid cipher options');
|
|
FCipherOptions := ACipherOptions;
|
|
end;
|
|
|
|
procedure TTLSServer.SetKeyExchangeOptions(const AKeyExchangeOptions: TTLSKeyExchangeOptions);
|
|
begin
|
|
if AKeyExchangeOptions = FKeyExchangeOptions then
|
|
exit;
|
|
CheckNotActive;
|
|
if AKeyExchangeOptions = [] then
|
|
raise ETLSError.Create(TLSError_InvalidParameter, 'Invalid key exchange options');
|
|
FKeyExchangeOptions := AKeyExchangeOptions;
|
|
end;
|
|
|
|
procedure TTLSServer.SetHashOptions(const AHashOptions: TTLSHashOptions);
|
|
begin
|
|
if AHashOptions = FHashOptions then
|
|
exit;
|
|
CheckNotActive;
|
|
if AHashOptions = [] then
|
|
raise ETLSError.Create(TLSError_InvalidParameter, 'Invalid hash options');
|
|
FHashOptions := AHashOptions;
|
|
end;
|
|
|
|
procedure TTLSServer.SetCertificateList(const List: TTLSCertificateList);
|
|
begin
|
|
CheckNotActive;
|
|
FCertificateList := Copy(List);
|
|
end;
|
|
|
|
procedure TTLSServer.SetPrivateKeyRSA(const APrivateKeyRSA: RawByteString);
|
|
begin
|
|
if APrivateKeyRSA = FPrivateKeyRSA then
|
|
exit;
|
|
CheckNotActive;
|
|
FPrivateKeyRSA := APrivateKeyRSA;
|
|
end;
|
|
|
|
function TTLSServer.GetPrivateKeyRSAPEM: RawByteString;
|
|
begin
|
|
Result := MIMEBase64Encode(PrivateKeyRSA);
|
|
end;
|
|
|
|
procedure TTLSServer.SetPrivateKeyRSAPEM(const APrivateKeyRSAPEM: RawByteString);
|
|
begin
|
|
SetPrivateKeyRSA(MIMEBase64Decode(APrivateKeyRSAPEM));
|
|
end;
|
|
|
|
procedure TTLSServer.SetPEMFileName(const APEMFileName: String);
|
|
begin
|
|
if APEMFileName = FPEMFileName then
|
|
exit;
|
|
CheckNotActive;
|
|
FPEMFileName := APEMFileName;
|
|
end;
|
|
|
|
procedure TTLSServer.SetPEMText(const APEMText: RawByteString);
|
|
begin
|
|
if APEMText = FPEMText then
|
|
exit;
|
|
CheckNotActive;
|
|
FPEMText := APEMText;
|
|
end;
|
|
|
|
procedure TTLSServer.SetDHKeySize(const ADHKeySize: Integer);
|
|
begin
|
|
if ADHKeySize = FDHKeySize then
|
|
exit;
|
|
CheckNotActive;
|
|
FDHKeySize := ADHKeySize;
|
|
end;
|
|
|
|
procedure TTLSServer.ClientLog(const Client: TTLSServerClient; const LogType: TTLSLogType; const LogMsg: String; const LogLevel: Integer);
|
|
begin
|
|
Log(LogType, 'C[%d]:%s', [Client.FClientId, LogMsg], LogLevel + 1);
|
|
end;
|
|
|
|
procedure TTLSServer.ClientStateChange(const Client: TTLSServerClient);
|
|
begin
|
|
if Assigned(FOnClientStateChange) then
|
|
FOnClientStateChange(self, Client);
|
|
end;
|
|
|
|
procedure TTLSServer.ClientAlert(const Client: TTLSServerClient; const Level: TTLSAlertLevel; const Description: TTLSAlertDescription);
|
|
begin
|
|
if Assigned(FOnClientAlert) then
|
|
FOnClientAlert(self, Client, Level, Description);
|
|
end;
|
|
|
|
procedure TTLSServer.ClientHandshakeFinished(const Client: TTLSServerClient);
|
|
begin
|
|
if Assigned(FOnClientHandshakeFinished) then
|
|
FOnClientHandshakeFinished(self, Client);
|
|
end;
|
|
|
|
function TTLSServer.CreateClient(const UserObj: TObject): TTLSServerClient;
|
|
begin
|
|
Result := TTLSServerClient.Create(self, UserObj);
|
|
end;
|
|
|
|
function TTLSServer.GetClientCount: Integer;
|
|
begin
|
|
Result := Length(FClients);
|
|
end;
|
|
|
|
function TTLSServer.GetClient(const Idx: Integer): TTLSServerClient;
|
|
begin
|
|
Assert(Idx >= 0);
|
|
Assert(Idx < Length(FClients));
|
|
|
|
Result := FClients[Idx];
|
|
end;
|
|
|
|
function TTLSServer.GetClientIndex(const Client: TTLSServerClient): Integer;
|
|
var I : Integer;
|
|
begin
|
|
for I := 0 to Length(FClients) - 1 do
|
|
if FClients[I] = Client then
|
|
begin
|
|
Result := I;
|
|
exit;
|
|
end;
|
|
Result := -1;
|
|
end;
|
|
|
|
function TTLSServer.AddClient(const UserObj: TObject): TTLSServerClient;
|
|
var L : Integer;
|
|
C : TTLSServerClient;
|
|
begin
|
|
CheckActive;
|
|
C := CreateClient(UserObj);
|
|
Lock;
|
|
try
|
|
Inc(FClientNr);
|
|
C.FClientId := FClientNr;
|
|
|
|
L := Length(FClients);
|
|
SetLength(FClients, L + 1);
|
|
FClients[L] := C;
|
|
finally
|
|
Unlock;
|
|
end;
|
|
Result := C;
|
|
end;
|
|
|
|
procedure TTLSServer.RemoveClient(const Client: TTLSServerClient);
|
|
var I, J, L : Integer;
|
|
begin
|
|
Lock;
|
|
try
|
|
I := GetClientIndex(Client);
|
|
if I < 0 then
|
|
raise ETLSError.Create(TLSError_InvalidParameter);
|
|
L := Length(FClients);
|
|
for J := I to L - 2 do
|
|
FClients[J] := FClients[J + 1];
|
|
SetLength(FClients, L - 1);
|
|
finally
|
|
Unlock;
|
|
end;
|
|
Client.Free;
|
|
end;
|
|
|
|
procedure TTLSServer.ClientTransportLayerSend(const Sender: TTLSServerClient; const Buffer; const Size: Integer);
|
|
begin
|
|
Assert(Assigned(FTransportLayerSendProc));
|
|
Assert(Size > 0);
|
|
FTransportLayerSendProc(self, Sender, Buffer, Size);
|
|
end;
|
|
|
|
procedure TTLSServer.ProcessTransportLayerReceivedData(const AClient: TTLSServerClient; const Buffer; const Size: Integer);
|
|
begin
|
|
if not Assigned(AClient) then
|
|
raise ETLSError.Create(TLSError_InvalidParameter);
|
|
AClient.ProcessTransportLayerReceivedData(Buffer, Size);
|
|
end;
|
|
|
|
procedure TTLSServer.InitFromPEM;
|
|
var P : TPEMFile;
|
|
L, I : Integer;
|
|
begin
|
|
if (FPEMFileName = '') and (FPEMText = '') then
|
|
exit;
|
|
P := TPEMFile.Create;
|
|
try
|
|
if FPEMFileName <> '' then
|
|
P.LoadFromFile(FPEMFileName)
|
|
else
|
|
P.LoadFromText(FPEMText);
|
|
FPrivateKeyRSA := P.RSAPrivateKey;
|
|
L := P.CertificateCount;
|
|
SetLength(FCertificateList, L);
|
|
for I := 0 to L - 1 do
|
|
FCertificateList[I] := P.Certificate[I];
|
|
finally
|
|
P.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TTLSServer.InitPrivateKey;
|
|
var L1, L2 : Integer;
|
|
begin
|
|
if FPrivateKeyRSA = '' then
|
|
raise ETLSError.Create(TLSError_InvalidCertificate, 'No private key');
|
|
ParseX509RSAPrivateKeyStr(FPrivateKeyRSA, FX509RSAPrivateKey);
|
|
L1 := NormaliseX509IntKeyBuf(FX509RSAPrivateKey.Modulus);
|
|
L2 := NormaliseX509IntKeyBuf(FX509RSAPrivateKey.PrivateExponent);
|
|
if L2 > L1 then
|
|
L1 := L2;
|
|
RSAPrivateKeyAssignBufStr(FRSAPrivateKey, L1 * 8,
|
|
FX509RSAPrivateKey.Modulus,
|
|
FX509RSAPrivateKey.PrivateExponent);
|
|
end;
|
|
|
|
procedure TTLSServer.AllocateSessionID(var SessionID: RawByteString);
|
|
begin
|
|
SessionID := SecureRandomStrA(TLSSessionIDMaxLen);
|
|
end;
|
|
|
|
procedure TTLSServer.DoStart;
|
|
begin
|
|
Assert(FState <> tlssActive);
|
|
|
|
{$IFDEF TLS_DEBUG}
|
|
Log(tlsltDebug, 'Start');
|
|
{$ENDIF}
|
|
|
|
FClientNr := 0;
|
|
InitFromPEM;
|
|
InitPrivateKey;
|
|
FState := tlssActive;
|
|
end;
|
|
|
|
procedure TTLSServer.DoStop;
|
|
begin
|
|
Assert(FState = tlssActive);
|
|
|
|
{$IFDEF TLS_DEBUG}
|
|
Log(tlsltDebug, 'Stop');
|
|
{$ENDIF}
|
|
|
|
FState := tlssStopped;
|
|
end;
|
|
|
|
procedure TTLSServer.Start;
|
|
begin
|
|
if FState = tlssActive then
|
|
exit;
|
|
DoStart;
|
|
end;
|
|
|
|
procedure TTLSServer.Stop;
|
|
begin
|
|
if FState <> tlssActive then
|
|
exit;
|
|
DoStop;
|
|
end;
|
|
|
|
|
|
|
|
end.
|
|
|