Last active
January 22, 2024 11:13
-
-
Save LarsFosdal/76bf712c46b3b17d185984d5c0c74494 to your computer and use it in GitHub Desktop.
Test
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
unit osAPITCPEngineServer; | |
interface | |
uses | |
IdCTypes, | |
IdContext, | |
IdComponent, | |
IdTCPServer, | |
IdSSLOpenSSL, | |
IdSSLOpenSSLHeaders, | |
osAPITCPServerContext, | |
osServiceServersTypes; | |
type | |
TAPITCPEngineServer = class | |
private | |
FCertificatesPath: string; | |
FCmdCommandsBlockEnabled: Boolean; | |
FIOHandlerSSLOpenSLL: TIdServerIOHandlerSSLOpenSSL; | |
FListenPort: Word; | |
FOpenSSLDLLPath: string; | |
FSecurityPolicy: TConnectionSecurityPolicy; | |
FServer: TIdTCPServer; | |
FSetCommandsBlockEnabled: Boolean; | |
FStopNewConnections: Boolean; | |
private | |
function GetActive: Boolean; | |
private | |
procedure SetCertificatesPath(const Value: string); | |
procedure SetListenPort(Value: Word); | |
procedure SetOpenSSLDLLPath(const Value: string); | |
private | |
procedure ServerConnect(AContext: TIdContext); | |
procedure ServerExecute(AContext: TIdContext); | |
private | |
procedure SSLGetPassword(var Password: string); | |
procedure SSLGetPasswordEx(ASender: TObject; var VPassword: string; const AIsWrite: Boolean); | |
procedure SSLStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string); | |
procedure SSLStatusInfo(const AMsg: string); | |
procedure SSLStatusInfoEx(ASender: TObject; const AsslSocket: PSSL; const AWhere, Aret: TIdC_INT; const AType, AMsg: string); | |
public | |
constructor Create; | |
destructor Destroy; override; | |
public | |
function Start: Boolean; | |
function Stop: Boolean; | |
public | |
property Active: Boolean read GetActive; | |
property CertificatesPath: string read FCertificatesPath write SetCertificatesPath; | |
property CmdCommandsBlockEnabled: Boolean read FCmdCommandsBlockEnabled write FCmdCommandsBlockEnabled; | |
property ListenPort: Word read FListenPort write SetListenPort; | |
property OpenSSLDLLPath: string read FOpenSSLDLLPath write SetOpenSSLDLLPath; | |
property SecurityPolicy: TConnectionSecurityPolicy read FSecurityPolicy write FSecurityPolicy; | |
property SetCommandsBlockEnabled: Boolean read FSetCommandsBlockEnabled write FSetCommandsBlockEnabled; | |
end; | |
implementation | |
uses | |
System.Classes, | |
IdSSL, | |
IdGlobal, | |
osSysUtils; | |
const | |
{ default constants } | |
DEF_LISTEN_PORT = 8000; | |
DEF_SECURITY_POLICY = cnsp_None; | |
{ TAPITCPEngineServer } | |
constructor TAPITCPEngineServer.Create; | |
begin | |
// sets default members values | |
FCertificatesPath := ''; | |
FCmdCommandsBlockEnabled := False; | |
FIOHandlerSSLOpenSLL := nil; | |
FListenPort := DEF_LISTEN_PORT; | |
FOpenSSLDLLPath := ''; | |
FSecurityPolicy := DEF_SECURITY_POLICY; | |
FServer := nil; | |
FSetCommandsBlockEnabled := False; | |
FStopNewConnections := False; | |
end; | |
destructor TAPITCPEngineServer.Destroy; | |
begin | |
// frees objects | |
SafeFreeAndNil(FServer); | |
SafeFreeAndNil(FIOHandlerSSLOpenSLL); | |
inherited; | |
end; | |
function TAPITCPEngineServer.GetActive: Boolean; | |
begin | |
if FServer = nil then Exit(False); | |
Result := FServer.Active; | |
end; | |
procedure TAPITCPEngineServer.ServerConnect(AContext: TIdContext); | |
begin | |
// checks if new connections are permitted | |
if FStopNewConnections then | |
AContext.Connection.Disconnect; | |
// evaluates security policy | |
case FSecurityPolicy of | |
cnsp_None: ; | |
cnsp_sslvTLSv1_2: | |
begin | |
// evaluates, if by some strange chance, the manager is not an SSL manager | |
if not (AContext.Connection.IOHandler is TIdSSLIOHandlerSocketOpenSSL) then | |
begin | |
AContext.Connection.Disconnect; | |
Exit; | |
end; | |
// if True, authentication is not handled (plaintext only) or is used for STARTTLS, if False handles TLS/SSL authentication | |
if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then | |
TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := False; | |
end; | |
end; | |
end; | |
procedure TAPITCPEngineServer.ServerExecute(AContext: TIdContext); | |
begin | |
// enables server request to be UTF8 compliant | |
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8; | |
TAPITCPServerContext(AContext).CmdCommandsBlockEnabled := FCmdCommandsBlockEnabled; | |
TAPITCPServerContext(AContext).SetCommandsBlockEnabled := FSetCommandsBlockEnabled; | |
TAPITCPServerContext(AContext).Execute; | |
end; | |
procedure TAPITCPEngineServer.SetCertificatesPath(const Value: string); | |
begin | |
if (FServer <> nil) and FServer.Active then Exit; | |
FCertificatesPath := Value; | |
end; | |
procedure TAPITCPEngineServer.SetListenPort(Value: Word); | |
begin | |
if (FServer <> nil) and FServer.Active then Exit; | |
FListenPort := Value; | |
end; | |
procedure TAPITCPEngineServer.SetOpenSSLDLLPath(const Value: string); | |
begin | |
if (FServer <> nil) and FServer.Active then Exit; | |
FOpenSSLDLLPath := Value; | |
end; | |
procedure TAPITCPEngineServer.SSLGetPassword(var Password: string); | |
begin | |
//### TODO: Used for debug. At moment it is never called at client connection!!! | |
Password := ''; | |
end; | |
procedure TAPITCPEngineServer.SSLGetPasswordEx(ASender: TObject; var VPassword: string; const AIsWrite: Boolean); | |
begin | |
//### TODO: Used for debug. At moment it is never called at client connection!!! | |
end; | |
procedure TAPITCPEngineServer.SSLStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string); | |
begin | |
//### TODO: Used for debug. At moment it is never called at client connection!!! | |
end; | |
procedure TAPITCPEngineServer.SSLStatusInfo(const AMsg: string); | |
begin | |
//### TODO: Used for debug. At moment it is never called at client connection!!! | |
end; | |
procedure TAPITCPEngineServer.SSLStatusInfoEx(ASender: TObject; const AsslSocket: PSSL; const AWhere, Aret: TIdC_INT; const AType, AMsg: string); | |
begin | |
//### TODO: Used for debug. At moment it is never called at client connection!!! | |
end; | |
function TAPITCPEngineServer.Start: Boolean; | |
begin | |
try | |
if (FServer <> nil) and (FServer.Active) then Exit(True); | |
if FServer = nil then | |
begin | |
FStopNewConnections := False; | |
// creates and sets tcp server | |
FServer := TIdTCPServer.Create(nil); | |
FServer.Active := False; | |
FServer.ContextClass := TAPITCPServerContext; | |
FServer.DefaultPort := FListenPort; | |
FServer.OnConnect := ServerConnect; | |
FServer.OnExecute := ServerExecute; | |
// sets OpenSLL library path | |
IdOpenSSLSetLibPath(FOpenSSLDLLPath); | |
// evaluates security policy | |
case FSecurityPolicy of | |
cnsp_None: ; | |
cnsp_sslvTLSv1_2: | |
begin | |
FIOHandlerSSLOpenSLL := TIdServerIOHandlerSSLOpenSSL.Create(nil); | |
FIOHandlerSSLOpenSLL.OnStatus := SSLStatus; | |
FIOHandlerSSLOpenSLL.OnStatusInfo := SSLStatusInfo; | |
FIOHandlerSSLOpenSLL.OnStatusInfoEx := SSLStatusInfoEx; | |
FIOHandlerSSLOpenSLL.OnGetPassword := SSLGetPassword; | |
FIOHandlerSSLOpenSLL.OnGetPasswordEx := SSLGetPasswordEx; | |
FIOHandlerSSLOpenSLL.SSLOptions.Mode := sslmServer; | |
FIOHandlerSSLOpenSLL.SSLOptions.Method := sslvTLSv1_2; | |
FIOHandlerSSLOpenSLL.SSLOptions.SSLVersions := [sslvTLSv1_2]; | |
FIOHandlerSSLOpenSLL.SSLOptions.DHParamsFile := ''; | |
FIOHandlerSSLOpenSLL.SSLOptions.CertFile := FCertificatesPath + 'server-cert.pem'; | |
FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := FCertificatesPath + 'server-key.pem'; | |
FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := ''; | |
FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := FCertificatesPath + 'root-cert.pem'; | |
{ | |
FIOHandlerSSLOpenSLL.SSLOptions.CipherList := SSL_DEFAULT_CIPHER_LIST; | |
FIOHandlerSSLOpenSLL.SSLOptions.CipherList := '!EXPORT:!LOW:!aNULL:!eNULL:!RC4:!ADK:!3DES:!DES:!MD5:!PSK:!SRP:!CAMELLIA'+ | |
':ECDHE-RSA-AES128-GCM-SHA256'+ | |
':ECDHE-RSA-AES256-GCM-SHA384'+ | |
':ECDHE-RSA-CHACHA20-POLY1305'+ | |
//to use this two you must create a dhparam.pem file with openssl in this way | |
//openssl dhparam -out dhparam.pem 4096 | |
//':DHE-RSA-AES128-GCM-SHA256'+ | |
//':DHE-RSA-AES256-GCM-SHA384'+ | |
''; | |
} | |
FServer.IOHandler := FIOHandlerSSLOpenSLL; | |
end; | |
end; | |
end; | |
FServer.Active := True; | |
Result := FServer.Active; | |
except | |
Result := False; | |
end; | |
end; | |
function TAPITCPEngineServer.Stop: Boolean; | |
function ActivitiesStop: Boolean; | |
var | |
I: Integer; | |
LList: TList; | |
Context: TAPITCPServerContext; | |
begin | |
Result := False; | |
LList := FServer.Contexts.LockList; | |
try | |
for I := 0 to LList.Count - 1 do | |
begin | |
Context := TAPITCPServerContext(LList[I]); | |
Context.ActivitiesStop := True; | |
Result := True; | |
end; | |
finally | |
FServer.Contexts.UnlockList; | |
end; | |
end; | |
function ActivitiesStoppedCheck: Boolean; | |
var | |
I: Integer; | |
LList: TList; | |
Context: TAPITCPServerContext; | |
begin | |
Result := False; | |
LList := FServer.Contexts.LockList; | |
try | |
for I := 0 to LList.Count - 1 do | |
begin | |
Context := TAPITCPServerContext(LList[I]); | |
Result := not Context.ActivitiesStopped; | |
if Result then Exit; | |
end; | |
finally | |
FServer.Contexts.UnlockList; | |
end; | |
end; | |
begin | |
Result := True; | |
try | |
if FServer = nil then Exit; | |
if FServer.Active then | |
begin | |
{** | |
* TAKE CARE | |
* ========= | |
* At this point we are in primary thread and we want to close all API Server connections but someone could be | |
* in waiting for Thread.Syncronize and stay in infinite loop because TApplication.Idle is not managed, and the | |
* related CheckSynchronize will never be called, we are in primary thread here. | |
* A valid solution, before to set server Active to False is: | |
* - Refuse any new connection on OnConnect with FStopNewConnections to True. | |
* - Ask clients context to stop any activity (get request and put a response which could call TThread.Synchronize. | |
* - Check when all client context accepted the stop to any activity. | |
* In the meanwhile call CheckSynchronize to manage possible pending TThread.Synchronize calls. | |
* | |
**} | |
FStopNewConnections := True; | |
if ActivitiesStop then | |
begin | |
while ActivitiesStoppedCheck do | |
begin | |
CheckSynchronize; | |
TThread.Sleep(1); | |
end; | |
end; | |
FServer.Active := False; | |
end; | |
// frees objects | |
SafeFreeAndNil(FServer); | |
SafeFreeAndNil(FIOHandlerSSLOpenSLL); | |
except | |
Result := False; | |
end; | |
end; | |
end. |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment