DelphiUdIT

I have no knowledge of any tool for automatic conversion (even partial). There are several contexts you should pay attention to when converting: 1) string: currently the definition is Unicode, in Delphi7 it was synonymous with AnsiString; 2) char: 1 character occupies two bytes. in Delphi7 it occupied 1 byte; 3) several definitions have changed in both core and third-party components; 4) several basic components distributed with Delphi7 are no longer distributed with Delphi 10.3, and obviously there must be third-party 64-bit components if you use them; 5) when converting between 32 and 64 bit you must pay attention to the various types of parameters, especially in third-party DLLs: PChar, PWChar, PAnsiChar.... 6) Integer, cardinal, nativeint, etc.... 7) Floating Extended type is 80 bit long in 32 bit application, but in 64 bit is an alias of double (64 bit long); 8 Pointers in 32 bit platforms are 4 bytes length, in 64 bit platforms they are 8 bytes length. 9) In 64 bit platforms you cannot mix assembler and pascal in the same method. 10) more other stuff Look here for more info: https://docwiki.embarcadero.com/RADStudio/Rio/en/Converting_32-bit_Delphi_Applications_to_64-bit_Windows Good luck and good work

My fault, sorry ... since the first post talked about "vcl.h" and in others the references to the compilation of "bcc32" were reported, I considered the discussion linked to the Embarcadero C++ environment. What is the reason for using Microsoft SDK headers instead of Embarcadero ones? I don't use C++ very often and when I need to I use Rad Studio on Windows or gcc on Linux. And I have never had any problems using the APIs (with the original headers of the respective environments). If I have to use "packed" structures, I septate and restore alignment. In Delphi, where there is no possibility to "push/pop" the settings, I have a small structure that I test to find out the original alignment and then restore it at the end of my needs. The example I gave in the previous post on the "imagedosheader" was the first alignment mistake (happened many decades ago) and at the time it drove me crazy...

This is "mine" windows.h first lines ... and there is an alignment forced at 8 bytes.

You are right. But I normally use it with Panels, GroupBoxs, or such containers and inside them I put only few controls. I use it for example to enable controls with various login and disable them after logout, I found it very simple, and manipulating the tag value only (1K = Login Level 1, 2K = Login Level 2, etc ...). If I need to modify only some properties, I don't need to know the class of the controls ... eg. Enabled, Visible are common to all TControls so not needs explicit use of "(CB as TButton)" ... or "IF (CB is TButton)" But like some others wrote there are more methods, surely better than this. N.B.: very often I create a lot of controls at runtime, and in that way assigning a tag value is enough. I don't need list or static enumeration.

I commented "vcl.h" (i don't use it) and put "windows.h" at the top. Same result, no warnings (Rad Studio 11.3).

One of the various ways is to "cycle" within the controls of the parent component: to identify the affected control you could give a value to the tag property during the design phase (for example from 1000 to the first Button, 1001 to the second, etc. ..), then this will be the code assuming you are looping through the controls of a Form (Form1): var CB: TControl; for var i := 0 to Form1.ControlCount-1 do begin CB := Form1.Controls[i]; if (CB is TButton) and ((CB as TButton).Tag > 1000) then begin (CB as TButton).Enabled := True; end; end;

I added the "#pragma pack" in one of my projects, but don't have this kind of Warning:

Windows API calls are generally 8-byte aligned on a 64-bit system. Compared to APIs, VCLs are simply wrappers and do not modify the structures. The result (outgoing) and the data (incoming) are and must conform to what is documented by Microsoft, the VCLs do not test, change or modify anything with respect to this, much less the required alignment. Where necessary, the includes files define the correct alignments if a different alignment is necessary (this in both C++ and Delphi) as required by the API. An example for everyone is the very old (almost archaic) definition of the _ImageDosHeader which is aligned to 2 bytes. Bye

You can find the WM_USER+xxxx used by Embarcadero components by running a grep -i -d WM_USER *.pas from the "source" directory in your Delphi installation (at least for versions that also have the source distribution). However, what should be clear is that Windows messages must be directed directly to a handle (therefore specific control). It is therefore absolutely not a given that a WM_USER+100 used for example in Vcl.DBGrids cannot be used within the application. And I would say that it would be somewhat "questionable" that WM messages are used internally by Embarcadero components in a generic manner and not "privately" solely and exclusively for that component.

It was is Rio too, but i remember that were some issuse about that. First the errorinsight was not working, but the compilation were OK. Other issues ,,, may be I think that no one used in that version the inline variables. Bye

@Tommi Prami If you want commit the code in your repository and insert the test for the available of RDRAND and RDSEED, this is the code. Project Jedi has more info about that and of course the Intel documentation has all the documentation. I don't know about AMD, so i presume that AMD has the same two bits in use (hope). Tested in Win32 and Win64 Protected Mode, tested in virtual mode (WINXP - WIN11 32 bit and 64 bit), not tested in real address mode. interface //Explicity check if RDRAND and RDSEEK ara avilable //Global use TCheck_RDRAND_RDSEED = record tc_RDRAND: boolean; //true if RDRAND is available tc_RDSEED: boolean; //true if RDSEED is available end; var RDRAND_RDSEED_Available: TCheck_RDRAND_RDSEED; implementation const //ID string to identify CPU Vendor, the are a multitude .. but we focalize on this VendorIDxIntel: array [0..11] of AnsiChar = 'GenuineIntel'; VendorIDxAMD: array [0..11] of AnsiChar = 'AuthenticAMD'; //Internal functions, may be usefull to implement other check //Tested in Win32 and Win64 Protected Mode, tested in virtual mode (WINXP - WIN11 32 bit and 64 bit), not tested in real address mode //The Intel Documentation has more detail about CPUID //Jedi project has implemented TCPUInfo with more details. //First check that the CPU supports CPUID instructions. There are some exceptions with this rule, //but with very very old processors function Is_CPUID_Valid: boolean; register; asm {$IFDEF WIN64} pushfq //Save EFLAGS pushfq //Store EFLAGS xor qword [esp], $00200000 //Invert the ID bit in stored EFLAGS popfq //Load stored EFLAGS (with ID bit inverted) pushfq //Store EFLAGS again (ID bit may or may not be inverted) pop rax //eax = modified EFLAGS (ID bit may or may not be inverted) xor rax, qword [esp] //eax = whichever bits were changed popfq //Restore original EFLAGS and RAX, $00200000 //eax = zero if ID bit can't be changed, else non-zero jz @quit mov RAX, $01 //If the Result is boolean, the return parameter should be in A??? (true if A??? <> 0) @quit: {$ELSE} pushfd //Save EFLAGS pushfd //Store EFLAGS xor dword [esp], $00200000 //Invert the ID bit in stored EFLAGS popfd //Load stored EFLAGS (with ID bit inverted) pushfd //Store EFLAGS again (ID bit may or may not be inverted) pop eax //eax = modified EFLAGS (ID bit may or may not be inverted) xor eax,[esp] //eax = whichever bits were changed popfd //Restore original EFLAGS and eax, $00200000 //eax = zero if ID bit can't be changed, else non-zero jz @quit mov EAX, $01 //If the Result is boolean, the return parameter should be in AL (true if AL <> 0) @quit: {$ENDIF} end; //1) Check that the CPU is an INTEL CPU, we don't know nothing about other's // We can presume the AMD modern processors have the same check of INTEL, but only for some instructions. // No test were made to verify this (no AMD processor available) // //2) Catch the features of the CPU in use // //3) Catch the new features of the CPU in use // procedure CPUID_GeneralCall(InEAX: cardinal; InECX: cardinal; out Reg_EAX, Reg_EBX, Reg_ECX, Reg_EDX); stdcall; asm {$IFDEF WIN64} // save context PUSH RBX // CPUID MOV EAX, InEAX //Generic function MOV ECX, InECX //Generic sub function // //For CPU VENDOR STRING EAX := $0 //ECX is not used when EAX = $0 // //For CPU Extension EAX := $01 //ECX is not used when EAX = $01 // //For CPU New Extension EAX := $07 //ECX should be $00 to read if RDSEED is available // CPUID // store results MOV R8, Reg_EAX MOV R9, Reg_EBX MOV R10, Reg_ECX MOV R11, Reg_EDX MOV Cardinal PTR [R8], EAX MOV Cardinal PTR [R9], EBX MOV Cardinal PTR [R10], ECX MOV Cardinal PTR [R11], EDX // restore context POP RBX {$ELSE} // save context PUSH EDI PUSH EBX // CPUID MOV EAX, InEAX //Generic function MOV ECX, InECX //Generic sub function // //For CPU VENDOR STRING EAX := $0 //ECX is not used when EAX = $0 // //For CPU Extension EAX := $01 //ECX is not used when EAX = $01 // //For CPU New Extension EAX := $07 //ECX should be $00 to read if RDSEED is available // CPUID // store results MOV EDI, Reg_EAX MOV Cardinal PTR [EDI], EAX MOV EAX, Reg_EBX MOV EDI, Reg_ECX MOV Cardinal PTR [EAX], EBX MOV Cardinal PTR [EDI], ECX MOV EAX, Reg_EDX MOV Cardinal PTR [EAX], EDX // restore context POP EBX POP EDI {$ENDIF} end; //Function called from Initialization function CPUID_RDRAND_RDSEEK_Check: TCheck_RDRAND_RDSEED; var tempVendorId: array [0..11] of AnsiChar; HighValBase: Cardinal; HighValExt1: Cardinal; VersionInfo: Cardinal; AdditionalInfo: Cardinal; ExFeatures: Cardinal; StdFeatures: Cardinal; UnUsed1, UnUsed2: Cardinal; NewFeatures: Cardinal; begin Result.tc_RDRAND := false; Result.tc_RDSEED := false; //Check if CPUID istruction is valid testing the bit 21 of EFLAGS if Is_CPUID_Valid then begin //Get the Vendor string with EAX = 0 and ECX = 0 CPUID_GeneralCall(0, 0, HighValBase, tempVendorID[0], tempVendorID[8], tempVendorID[4]); //Verifiy that we are on CPU that we support if (tempVendorId = VendorIDxIntel) OR (tempVendorId = VendorIDxAMD) then begin //Now check if RDRAND and RDSEED is supported inside the extended CPUID flags if HighValbase >=1 then //Supports extensions begin //With EAX = 1 AND ECX = 0 the Extension and the available of RDRAND can be read CPUID_GeneralCall(1, 0, VersionInfo, AdditionalInfo, ExFeatures, StdFeatures); //ExFeatures (ECX register) bit 30 is 1 if RDRAND is available if (ExFeatures and ($1 shl 30)) <> 0 then Result.tc_RDRAND := true; if HighValBase >= 7 then begin //With EAX = 7 AND ECX = 0 the NEW Extension and the available of RDSEED can be read CPUID_GeneralCall(7, 0, HighValExt1, NewFeatures, UnUsed1, UnUsed2); //New Features (EBX register) bit 18 is 1 if RDSEED is available if (NewFeatures and ($1 shl 18)) <> 0 then Result.tc_RDSEED := true; end; end; end; end; end; Initialization begin RDRAND_RDSEED_Available := CPUID_RDRAND_RDSEEK_Check; end; end. Bye

I also think we are misunderstanding each other. To close, without going too OT, what you said is clear but we are confusing the issues. The virtualized environment is one thing and is defined through VMX virtualization and other things are the various modes in which the various processes can run (Protect, Real, etc ...). NORMAL PROCESS (NOT VIRTUALIZED) In Intel hardware, the RING0 level is the level that has the highest priority and privilege for instructions in all modes. Very similar to RING1 and RING2, but which have major limitations on the use of privileged instructions. In fact, to the best of my knowledge, RING1 and RING2 are never used (with the exception of RING1 in VMX, or better in the real world implementation like in VirtualBox). RING3 is used for user processes, because it has the lowest privilege level and therefore everything that happens can be monitored by RING0. For example, a fault in the instructions at the RING3 level is managed by the RING0 (normally Kernel) to implement the appropriate countermeasures (which can be either effective repair of the operation such as its emulation, or the management of a "page fault" or its actual rejection with generation of an error (and if this does not come from a user program but from a driver or the kernel then the infamous BSOD will most likely appear). These functions have existed more or less since the first I386 was marketed. Then gradually perfected until we reach our times. All exception management at the instruction level (which obviously also concerns the hardware) is normally managed at the kernel level which can decide to do what it deems most appropriate. VIRTUALIZATION The virtualization process goes beyond this... a new level of control called VMX ROOT is inserted which runs with privileges in a certain sense superior to those of a RING0 and which normally uses the VMX NOT ROOT environment to run another system operating. This is the difference. Then, to make things easier, normally RING1 (ALWAYS IN VMX NOT ROOT) is used to run the guest OS and RING3 (ALWAYS IN VMX NOT ROOT) for user applications. While the VMX ROOT must coordinate with the normal HOST operating system, the VMX NOT ROOT has nothing to do with the host. The CUPID instruction of your GUEST is not managed by the HOST operating system nor from the GUEST KERNEL, but rather by the VMX ROOT which will do what it has to do (it could easily execute it on behalf of the VMX NOT ROOT and report the result perhaps masked). Why don't we see a pronounced slowdown in guest operating systems? Because none of these perform certain operations continuously. Do you really think that a kernel, like a driver or an application, continuously executes a CPUID? Among other things, a very heavy instruction (for dozens of machine cycles if I'm not mistaken). This process is very similar (but being in hardware it is obviously more efficient) to what happened before the use of VMX: VirtualBox works in a similar way even without VMX virtualization, again thanks to RING1 and RING3 but obviously with decidedly lower security compared to a VMX environment. To be clear: VirtualBox hypervisor intercept every single CPUID instruction from VMX NOT ROOT to mask the result (the features that they don't support or they don't want exposed to guest) ... for example in the past they didn't support nexted VT-D virtualization and so the relative CPUID features is set to 0 and the virtual guest (kernel o user) saw THAT ... This is announced support for RDSEED (9 years ago) always from VirtualBox: All as I mentioned if we talk about virtualizing 32-bit environments. In 64-bit environments, additional issues are introduced and the techniques are more complex. It's clear to me, but if there were to be any replies I would say to open another thread.

Intel's documentation specifically talks about that chapter regarding NON-ROOT virtualized code. But this does not mean that the software CRASHES, the virtual machine managers (aka supervisor, aka hypervisor) such as VirtualBox or others implement their own ROOT system alongside that of Intel and which outclasses the functioning and runs its own monitor on the entire virtual environment. From what I know, the VirtualBox hypervisor for example runs as VMX ROOT and the virtual machine runs in ring 1 (OS) and ring 3 (user space). VirtualBox performs all checks and handling of all exceptions of both the guest operating system (OS in ring 1) and USER (in ring 3) ... including CPUIDs and all others if they occur. All this for classic 32-bit VMs, while for 64-bit it's all more complex. I would also like to remind you that for any instruction that can generate an exception there is a specific test that can be used and if the test cannot be performed or the test itself fails then the instruction(s) MUST NOT BE USED... including the CPUID. Example to test if the CPUID is available. So, no software should crash if CPUID is used ONLY when it is available, and this is true also for RDRAND and RDSEED of course: Bye

It is natural that if the instruction is not supported by the processor / virtualization environment something will be generated (crash / AV / fault of code / .... ) but this depends on what the virtualization environment is "able to do ". RDRAND itself is expected to throw an exception in a virtualized environment (and depends by settings) :

I don't understand what you mean. The debugger in the disassembly windows doesn't execute the instruction that you see (wrong or right) but the real instruction. And so the results may be unexpected. But they are the right ones. This is because the mnemonic / symbolic view is only ... a view. Bye

I try to force the fault of the instructions (really simple for one, no fault in the other): the rdseed instruction set the register to zero and the CF to zero, after two (2) consecutive executions ; for the rdrand instruction, I was not able to make it in fault state so, at least for the rdseed instruction the register is set to zero (like you told @Kas Ob.) The rdrand instruction appears to be less sensitive to errors than the rdseed.

Lol, more than Intel ...

Yes, so count is not necessary. But i will try to put the hardware in fails mode and see whats occurs... (... "This will lead to the RDSEED instruction returning no data transitorily" .... is a little be confusing from hardware Intel reference). Stay tuned ...

Uhmm, yes and not ..... the manual says (for rdseed too): That means that the RAX (or EAX or ...) are not changed by the rdrand or rdseed, and the value of these registers is likely to be non-zero. It could instead happen that these registers, in the event of failures up to the end of the count, report repetitive data linked to the flow of the program... if the function is inserted in a single block it is very likely that the registers are always the same between the various calls. BUT ... I believe it is unlikely that there will be continuous "defects" which is why I have not included counts in the examples given, and it is equally likely (of course) that your cycle counts will never reach zero. Repeated failures of these functions are not documented by Intel or other sources. Bye

Hello @Kas Ob., if you really think that you need a "retry count" then you must add a parameter in the function that return also the fails ... otherwise the output value of the function could be constant and this would violate its functionality. Bye

You can also do like i show you in my example: in the asm function add a second loop that use the EDX register .... and you have a 64 bit random number for 32 bit application.

RDSEED and RDRAND are available since (https://www.intel.com/content/www/us/en/developer/articles/technical/intel-sdm.html) : RDRAND = 3rd Generation Intel Core processors, Intel Xeon processor E3-1200 v2 product family, Intel Xeon processor E5 v2 and E7 v2 families, Intel Atom processor based on Silvermont microarchitecture; RDSEED = Intel Core M processor family, 5th Generation Intel Core processor family, Intel Atom processor based on Goldmont microarchitecture; Like you told, the functions may fail and you must check the carry flag (CF=1) and loop until that. I don't check the opcode but i think you are able to use mnemonic notation to write asm code like this: {$IFDEF WIN64} function GetRandom: UInt64; register; asm @here: rdseed, RAX //RAX return value 64 bit (WIN64) jnc @here end; {$ELSE} function GetRandom: UInt32; register; asm @here: rdseed, EAX //EAX return value 32 bit (WIN32) jnc @here end; {$ENDIF} You can use also UInt64 with full random ( 😉 ) on 32 bit program like this: //ONLY ON WIN32 function GetRandom: UInt64; register; asm @here1: rdseed, EAX //EAX return value low 32 bit (WIN32) jnc @here1 @here2: rdseed, EDX //EDX return value high 32 bit (WIN32) jnc @here2 // UInt64 value on 32bit = EDX:EAX end; Bye

See this: https://docwiki.embarcadero.com/RADStudio/Alexandria/en/Debugging_Service_Applications

The source file of Image List Editor is: "C:\Program Files (x86)\Embarcadero\Studio\22.0\source\Property Editors\ImgEdit.pas" How to construct a new property editor and register it is behind my knowledge. P.S.: I don't know if the releases (Community, Professional) have those sources.

Some little changes ... take care of port use ... in Indy too (better to use bindings with explicit port). Some methods included, some excluded (the password ask in the SSLIoHandler is for the "certificate key file", not for user). I use to assign the SSLIoHandler to TFTPServer immediately. {** * TAKE CARE * ========= * This unit is purely for study purposes in which to learn the basics about building and testing an FTP server with * various levels of security. Server activation is in class constructor, and server properties manually placed before * its activation. On final class will be implemented a Start & Stop method to control it, with a property to get the * current state. The server settings will be placed in properties to be set before to activate the server. * **} unit osFTPServer; interface uses System.Classes, IdCTypes, IdContext, IdComponent, IdFTPList, IdFTPServer, IdFTPListOutput, IdSSLOpenSSL, IdSSLOpenSSLHeaders; type TMyIdSSLContext = class(TIdSSLContext) end; type TFTPServerSecurityPolicy = ( fssp_None, fssp_sslvSSLv23, fssp_sslvTLSv1_2 ); TFTPServer = class private FCertificatesPath: string; FFTPServer: TIdFTPServer; FIOHandlerSSLOpenSLL: TIdServerIOHandlerSSLOpenSSL; FOpenSSLDLLPath: string; FPassword: string; FRootPath: string; FSecurityPolicy: TFTPServerSecurityPolicy; FUsername: string; FSSLContext1: TMyIdSSLContext; private procedure IdFTPServer1QuerySSLPort(APort: Word; var VUseSSL: Boolean); procedure IdFTPServer1UserAccount(ASender: TIdFTPServerContext; const AUsername, APassword, AAcount: string; var AAuthenticated: Boolean); procedure ServerChangeDirectory(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName); procedure ServerConnect(AContext: TIdContext); procedure ServerDeleteFile(ASender: TIdFTPServerContext; const APathName: TIdFTPFileName); procedure ServerDisconnect(AContext: TIdContext); procedure ServerListDirectory(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd: string; const ASwitches: string); procedure ServerMakeDirectory(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName); procedure ServerRemoveDirectory(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName); procedure ServerStoreFile(ASender: TIdFTPServerContext; const AFileName: TIdFTPFileName; AAppend: Boolean; var VStream: TStream); procedure ServerUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var VAuthenticated: Boolean); 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); private function FixPath(const APath: string): string; public constructor Create; destructor Destroy; override; end; implementation uses System.IOUtils, System.SysUtils, IdSSL, IdExplicitTLSClientServerBase; function FixTailPathDelimiter(const S: string): string; begin Result := IncludeTrailingPathDelimiter(ExcludeTrailingPathDelimiter(S)); end; procedure SafeFreeAndNil(var Obj); var Temp: TObject; begin try Temp := TObject(Obj); if Temp <> nil then begin Pointer(Obj) := nil; Temp.Free; end; except end; end; { TFTPServer } constructor TFTPServer.Create; begin inherited; // inits default members values FCertificatesPath := ''; FFTPServer := nil; FIOHandlerSSLOpenSLL := nil; FOpenSSLDLLPath := ''; FPassword := ''; FRootPath := ''; FSecurityPolicy := fssp_None; FUsername := ''; // TEMPORARY: manually set FTP settings (WILL BE PLACED ON PROPERTIES) FCertificatesPath := '.\'; FOpenSSLDLLPath := '.\'; FPassword := '12345'; FRootPath := '.\'; //FSecurityPolicy := fssp_sslvSSLv23; FSecurityPolicy := fssp_sslvTLSv1_2; FUsername := 'user'; // TEMPORARY: creates, sets and start FTP server IdOpenSSLSetLibPath(FOpenSSLDLLPath); FFTPServer := TIdFTPServer.Create; FFTPServer.DefaultPort := 21; FFTPServer.OnChangeDirectory := ServerChangeDirectory; FFTPServer.OnConnect := ServerConnect; FFTPServer.OnDeleteFile := ServerDeleteFile; FFTPServer.OnDisconnect := ServerDisconnect; FFTPServer.OnListDirectory := ServerListDirectory; FFTPServer.OnMakeDirectory := ServerMakeDirectory; FFTPServer.OnRemoveDirectory := ServerRemoveDirectory; FFTPServer.OnStoreFile := ServerStoreFile; FFTPServer.OnUserLogin := ServerUserLogin; FFTPServer.OnQuerySSLPort := IdFTPServer1QuerySSLPort; FFTPServer.OnUserAccount := IdFTPServer1UserAccount; case FSecurityPolicy of fssp_None: ; fssp_sslvSSLv23: begin FIOHandlerSSLOpenSLL := TIdServerIOHandlerSSLOpenSSL.Create(nil); FFTPServer.IOHandler := FIOHandlerSSLOpenSLL; FIOHandlerSSLOpenSLL.OnStatus := SSLStatus; FIOHandlerSSLOpenSLL.OnStatusInfo := SSLStatusInfo; FIOHandlerSSLOpenSLL.OnStatusInfoEx := SSLStatusInfoEx; //FIOHandlerSSLOpenSLL.OnGetPassword := SSLGetPassword; //FIOHandlerSSLOpenSLL.OnGetPasswordEx := SSLGetPasswordEx; FIOHandlerSSLOpenSLL.SSLOptions.Mode := sslmServer; FIOHandlerSSLOpenSLL.SSLOptions.Method := sslvSSLv23; FIOHandlerSSLOpenSLL.SSLOptions.CertFile := FCertificatesPath + 'certonly.pem'; FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := FCertificatesPath + 'privatekey.pem'; FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := FCertificatesPath + 'lets-encrypt-r3.pem'; //FFTPServer.IOHandler := FIOHandlerSSLOpenSLL; FFTPServer.UseTLS := utUseRequireTLS; end; fssp_sslvTLSv1_2: begin {$DEFINE USES_DHPARAM} // NOTE: to use this create a dhparam.pem file with openssl in this way openssl dhparam -out dhparam.pem 4096 FIOHandlerSSLOpenSLL := TIdServerIOHandlerSSLOpenSSL.Create(nil); FFTPServer.IOHandler := FIOHandlerSSLOpenSLL; FIOHandlerSSLOpenSLL.OnStatus := SSLStatus; FIOHandlerSSLOpenSLL.OnStatusInfo := SSLStatusInfo; FIOHandlerSSLOpenSLL.OnStatusInfoEx := SSLStatusInfoEx; //FIOHandlerSSLOpenSLL.OnGetPassword := SSLGetPassword; //FIOHandlerSSLOpenSLL.OnGetPasswordEx := SSLGetPasswordEx; FIOHandlerSSLOpenSLL.SSLOptions.Mode := sslmServer; FIOHandlerSSLOpenSLL.SSLOptions.Method := sslvTLSv1_2; {$IFDEF USES_DHPARAM} 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' + ':DHE-RSA-AES128-GCM-SHA256' + ':DHE-RSA-AES256-GCM-SHA384' + '' ); FIOHandlerSSLOpenSLL.SSLOptions.DHParamsFile := FCertificatesPath + 'dhparam.pem'; {$ELSE} 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' ); FIOHandlerSSLOpenSLL.SSLOptions.DHParamsFile := ''; {$ENDIF} FIOHandlerSSLOpenSLL.SSLOptions.CertFile := FCertificatesPath + 'certonly.pem'; FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := FCertificatesPath + 'privatekey.pem'; FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := FCertificatesPath + 'lets-encrypt-r3.pem'; //FFTPServer.IOHandler := FIOHandlerSSLOpenSLL; FFTPServer.UseTLS := utUseExplicitTLS; end; end; // sets passive boundary ports range to permit more than one file operation (eg: client multiple copy file to server) FFTPServer.PASVBoundPortMin := 60000; FFTPServer.PASVBoundPortMax := 65535; FFTPServer.Active := True; //After activation FSSLContext1 := TMyIdSSLContext(FIOHandlerSSLOpenSLL.SSLContext); SSL_CTX_set_ecdh_auto(FSSLContext1.fContext, 1); SSL_CTX_set_options(FSSLContext1.fContext, SSL_OP_CIPHER_SERVER_PREFERENCE); end; destructor TFTPServer.Destroy; begin //### does jobs to deactivate server before to free it!!! // frees objects SafeFreeAndNil(FFTPServer); SafeFreeAndNil(FIOHandlerSSLOpenSLL); inherited; end; function TFTPServer.FixPath(const APath: string): string; begin Result := StringReplace(APath, '/', '\', [rfReplaceAll]); Result := StringReplace(Result, '\\', '\', [rfReplaceAll]); end; procedure TFTPServer.ServerChangeDirectory(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName); begin //### end; procedure TFTPServer.ServerConnect(AContext: TIdContext); begin case FSecurityPolicy of fssp_None: begin // PassThroung must be set to False for it to handle SSL/TLS functionality if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := True; end; fssp_sslvSSLv23: begin // PassThroung must be set to False for it to handle SSL/TLS functionality if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := False; end; fssp_sslvTLSv1_2: begin // PassThroung must be set to False for it to handle SSL/TLS functionality if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := False; end; end; end; procedure TFTPServer.ServerDeleteFile(ASender: TIdFTPServerContext; const APathName: TIdFTPFileName); begin DeleteFile(FixPath(FRootPath + ASender.CurrentDir + '\' + APathname)); end; procedure TFTPServer.ServerDisconnect(AContext: TIdContext); begin //### end; procedure TFTPServer.ServerListDirectory(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd, ASwitches: string); var Status: Integer; SearchRec: TSearchRec; Item: TIdFTPListOutputItem; begin try ADirectoryListing.DirFormat := doWin32; ADirectoryListing.Switches := ASwitches; {$WARN SYMBOL_PLATFORM OFF} Status := FindFirst(FixPath(FRootPath + FixTailPathDelimiter(APath) + '*.*'), faAnyFile - faHidden - faSysFile, SearchRec); {$WARN SYMBOL_PLATFORM ON} try while Status = 0 do begin Item := ADirectoryListing.Add; if SearchRec.Attr and faDirectory = 0 then Item.ItemType := ditFile else Item.ItemType := ditDirectory; Item.FileName := SearchRec.Name; Item.Size := SearchRec.Size; Item.ModifiedDate := SearchRec.TimeStamp; Status := FindNext(SearchRec); end; finally FindClose(SearchRec); end; except end; end; procedure TFTPServer.ServerMakeDirectory(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName); begin try ForceDirectories(FixPath(FRootPath + VDirectory)); except end; end; procedure TFTPServer.ServerRemoveDirectory(ASender: TIdFTPServerContext; var VDirectory: TIdFTPFileName); begin try TDirectory.Delete(FixPath(FRootPath + VDirectory), True); except end; end; procedure TFTPServer.ServerStoreFile(ASender: TIdFTPServerContext; const AFileName: TIdFTPFileName; AAppend: Boolean; var VStream: TStream); var Path: string; begin // extracts path and forces creation if does not exits Path := ExtractFilePath(FixPath(FRootPath + AFilename)); if not DirectoryExists(Path) then ForceDirectories(Path); // opens a file stream for cration or append if not AAppend then VStream := TFileStream.Create(FixPath(FRootPath + AFilename), fmCreate) else VStream := TFileStream.Create(FixPath(FRootPath + AFilename), fmOpenWrite) end; procedure TFTPServer.ServerUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var VAuthenticated: Boolean); begin // checks user and password validity case FSecurityPolicy of fssp_None: begin VAuthenticated := True; end; fssp_sslvSSLv23: begin VAuthenticated := ( (FUsername = Trim(AUserName)) and (FPassword = Trim(APassword)) ); end; fssp_sslvTLSv1_2: begin VAuthenticated := ( (FUsername = Trim(AUserName)) and (FPassword = Trim(APassword)) ); end; end; end; procedure TFTPServer.IdFTPServer1UserAccount(ASender: TIdFTPServerContext; const AUsername, APassword, AAcount: string; var AAuthenticated: Boolean); begin AAuthenticated := True; end; procedure TFTPServer.SSLGetPassword(var Password: string); begin //### //THIS IS THE PASSWROD FOR THE KEY CERTIFICATION FILE //Password := FPassword; end; procedure TFTPServer.SSLGetPasswordEx(ASender: TObject; var VPassword: string; const AIsWrite: Boolean); begin //### end; procedure TFTPServer.SSLStatus(ASender: TObject; const AStatus: TIdStatus; const AStatusText: string); begin //### end; procedure TFTPServer.SSLStatusInfo(const AMsg: string); begin //### end; procedure TFTPServer.SSLStatusInfoEx(ASender: TObject; const AsslSocket: PSSL; const AWhere, Aret: TIdC_INT; const AType, AMsg: string); begin //### end; procedure TFTPServer.IdFTPServer1QuerySSLPort(APort: Word; var VUseSSL: Boolean); begin VUseSSL := (APort = 21); end; end. Bye