Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- 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.
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement