Jump to content

shineworld

Members
 View Profile  See their activity

  • Content Count

    343

  • Joined

  • Last visited

  • Days Won

    4

Posts posted by shineworld

  1. Posted

    3 minutes ago, pyscripter said:

    You could run the asyncio in a thread as in python - Running asyncio loop and tkinter gui - Stack Overflow.

    Also please submit an issue to the delphivcl project to expose the Application.OnIdle event.   That would make the use of timer unnecessary.

    In the first experiment, I tried to attach a method to the Application.OnIdle but, visible onto dir(Application) Python notice that is not published.
    What is the right python4delphi repo from https://github.com/Embarcadero/python4delphi and https://github.com/pyscripter/python4delphi ?

    Sincerely I don't know what to prefer and there are enought of differences between them.

  2. Posted

    A silly solution was to place DelphiVCL in a thread, but I don't know if it is the better way...
    Code presents a lot of global values, is just a test in waiting for a better idea from Python/DelphiVCL gurus 🙂
      

    import time
import asyncio
import logging
import threading

from asyncua import Client

from delphivcl import *

# == opc ua client settings ==
OPC_UA_SERVER_URL       = "opc.tcp://localhost:4840/"
OPC_UA_SERVER_URI       = "https://someone.com/opc-ua/server"
OPC_UA_ASYNC_SLEEP_TIME = 0.01

# == deveopment settings ==
DEBUG_LEVEL             = logging.CRITICAL      # avoid any log not critical
DEBUG_ENABLED           = False

# creates a logger
logger = logging.getLogger(__name__)

app = None
opcua_main_exit = False
program_position = []

async def opcua_main(form):

    global opcua_main_exit
    global program_position

    async with Client(url=OPC_UA_SERVER_URL) as client:
        # gets namespace index
        idx = await client.get_namespace_index(OPC_UA_SERVER_URI)

        # gets program position node
        program_position_node = client.get_node("ns=2;s=CNC.ProgramPosition")

        while not opcua_main_exit:
            await asyncio.sleep(OPC_UA_ASYNC_SLEEP_TIME)

            # reads program positions
            value = await program_position_node.read_value()
            program_position = list(value)

class DesktopView(Form):

    def __init__(self, owner):
        self.SetProps(Caption = "Welcome")

        # creates labels for program position axes values
        self.label_x = Label(self)
        self.label_x.SetProps(Parent=self, Top=40, Left=20)
        self.label_x.Caption = 'Z : {:15.3f}'.format(0.0)

        self.label_y = Label(self)
        self.label_y.SetProps(Parent=self, Top=60, Left=20)
        self.label_y.Caption = 'Y : {:15.3f}'.format(0.0)

        self.label_z = Label(self)
        self.label_z.SetProps(Parent=self, Top=80, Left=20)
        self.label_z.Caption = 'X : {:15.3f}'.format(0.0)

        # create and set update timer
        self.tmrUpdate = Timer(self)
        self.tmrUpdate.Enabled = False
        self.tmrUpdate.Interval = 1
        self.tmrUpdate.OnTimer = self.__on_timer_update
        self.tmrUpdate.Enabled = True

    def __on_timer_update(self, sender):
        global program_position
        if len(program_position) == 6:
            self.label_x.Caption = str(program_position[0])
            self.label_y.Caption = str(program_position[1])
            self.label_z.Caption = str(program_position[2])

def app_main():
    # initializes GUI Application
    Application.Initialize()
    Application.Title = "OPC UA Client Demo"

    # creates main application form
    app = DesktopView(Application)
    app.Show()
    FreeConsole()

    # enters in vcl main loop
    Application.Run()

    global opcua_main_exit
    opcua_main_exit = True

    # frees main application form
    app.Destroy()

if __name__ == "__main__":
    app_thread = threading.Thread(target=app_main)
    app_thread.start()

    logging.basicConfig(level=DEBUG_LEVEL)
    asyncio.run(opcua_main(app))

     

  3. Posted

    Hi all,

    it is possible to use the asyncio with a DelphiVCL ui-based program?

     

    I've implemented an asyncua Client to get data from an OPC UA Server.
    Here is a simple program that prints some values collected from an OPC UA server. 

    """CNC OPC UA Client."""
#-------------------------------------------------------------------------------
# Name:         cnc_opcua_client
#
# Purpose:      CNC OPC UA Client
#
# Note          Checked with Python 3.11.3
#
# Coding Style  https://www.python.org/dev/peps/pep-0008/
#-------------------------------------------------------------------------------
import time

import asyncio
import logging

from asyncua import Client

# == opc ua client settings ==
OPC_UA_SERVER_URL       = "opc.tcp://localhost:4840/"
OPC_UA_SERVER_URI       = "https://www.someone.com/opc-ua/server"
OPC_UA_ASYNC_SLEEP_TIME = 0.01

# == deveopment settings ==
DEBUG_LEVEL             = logging.CRITICAL      # avoid any log not critical
DEBUG_ENABLED           = False

# creates a logger
logger = logging.getLogger(__name__)

async def main():
    """Main entry point."""

    # creats opc ua client in with-exception-handled block
    async with Client(url=OPC_UA_SERVER_URL) as client:

        # gets namespace index
        idx = await client.get_namespace_index(OPC_UA_SERVER_URI)

        # gets program position node
        program_position_node = client.get_node("ns=2;s=CNC.ProgramPosition")

        # server updating loop
        while True:
            # does nothing, just process relax
            await asyncio.sleep(OPC_UA_ASYNC_SLEEP_TIME)

            # reads and prints program positions
            value = await program_position_node.read_value()
            print('X:{:10.3f}, Y:{:10.3f}, Z:{:10.3f}'. format(value[0], value[1], value[2]))

# checks if this module is running as the main program
if __name__ == "__main__":
    logging.basicConfig(level=DEBUG_LEVEL)
    asyncio.run(main(), debug=DEBUG_ENABLED)

    Getting: 

    *** Remote Interpreter Reinitialized ***
X:    51.206, Y:     0.000, Z:     0.000
X:    51.206, Y:     0.000, Z:     0.000
X:    51.206, Y:     0.000, Z:     0.000
X:    51.206, Y:     0.000, Z:     0.000

    At this point I would like to create a fashioned UI using DelphiVCL, but I'm unable to understand where to place the

    asyncio.run(main(), debug=DEBUG_ENABLED)

    because to get DelphiVCL UI the main loop is already done by Application.Run() call:

        # initializes GUI Application
        Application.Initialize()
        Application.Title = "OPC UA Client Demo"
     
        # creates main application form
        app = DesktopView(Application)
        app.Show()
        FreeConsole()
     
        # enters in vcl main loop
        Application.Run()
     
        # frees main application form
        app.Destroy()
     


    Thanks in advance for any suggestion.
    Best Regards
    Silverio

  4. Posted · Edited by shineworld

    4 hours ago, pyscripter said:

    Let's not start language wars in this thread, which is about a significant development in Python 12 and how take advantage of it using P4D.   P4D is about combining the strengths of python and Delphi, not choosing one versus the other.

    This was my case, in which the main UI and image analysis, with OpenCV, was managed with Python + DelphiVCL, and faster IP Camera commands and frames receiving were managed by a Delphi P4D, in this case, D4P, module using native Threads of Delphi.

    The attempt to manage frame acquisition via socket with python threads failed miserably.

    The combo was winning !!!

    I the future of Python I will be happy to have more power on threads and cores.

  5. Posted

    I am slightly confused about which repository of python4delphi
    is most correct to use to integrate Python into my Delphi applications.

    To date, I know of two repositories on which constant work is visible:
    - https://github.com/pyscripter/python4delphi
    - https://github.com/Embarcadero/python4delphi

    Comparing them it seems that they are managed by different people, but both make fixes and new features with quite a lot of activity, so they are both "alive."

    Does anyone know how this is organized and which one is preferable to use?

    Thanks in advance for the answers.

  6. Posted · Edited by shineworld

    I've tried to move from sslvSSLv23 to sslvTLSv1_2 as in the test code below but FileZilla says:

    2023-09-30 10:39:20 11520 1 Status: Connecting to 127.0.0.1:21...
    2023-09-30 10:39:20 11520 1 Status: Connection established, waiting for welcome message...

    and

    > openssl s_client -starttls ftp -connect 192.168.0.27:21
     

    says:
    P:\>openssl s_client -starttls ftp -connect 192.168.0.27:21
    CONNECTED(00000178)
    ... infinite wait without do nothing..

      

    {**
 *  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
  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;
  private
    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 := 'D:\x\develop\qem\rosetta_cnc_1\certificates\ftpserver\';
  FOpenSSLDLLPath := 'D:\x\develop\qem\rosetta_cnc_1\openssl.64';
  FPassword := '12345';
  FRootPath := 'D:\x\develop\qem\rosetta_cnc_1\certificates\';
//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;

  case FSecurityPolicy of
    fssp_None: ;

    fssp_sslvSSLv23:
    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 := sslvSSLv23;
      FIOHandlerSSLOpenSLL.SSLOptions.CertFile := FCertificatesPath + 'server-cert.pem';
      FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := FCertificatesPath + 'server-key.pem';
      FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := FCertificatesPath + 'root-cert.pem';
      FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := '';
      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);
      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 + 'server-cert.pem';
      FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := FCertificatesPath + 'server-key.pem';
      FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := FCertificatesPath + 'root-cert.pem';
      FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := '';
      FFTPServer.IOHandler := FIOHandlerSSLOpenSLL;
      FFTPServer.UseTLS := utUseRequireTLS;
    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;
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:
      ;

    fssp_sslvSSLv23:
      ;

    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.SSLGetPassword(var Password: string);
begin
  //###
  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;

end.

    Have you any suggestions?
    Thanks in advance for any suggestions.

  7. Posted

    Being really ignorant of security I put a few breakpoints in the sources and followed step by step changing the options from way to way.

    Something seems to be working now... 

    unit osFTPServer;

interface

uses
  IdCTypes,
  IdContext,
  IdComponent,

  IdFTPList,
  IdFTPServer,
  IdFTPListOutput,

  IdSSLOpenSSL,
  IdSSLOpenSSLHeaders;

type
  TFTPServer = class
  private
    FFTPServer: TIdFTPServer;
    FIOHandlerSSLOpenSLL: TIdServerIOHandlerSSLOpenSSL;
  private
    procedure ServerConnect(AContext: TIdContext);
    procedure ServerDisconnect(AContext: TIdContext);
    procedure ServerUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var VAuthenticated: Boolean);
    procedure ServerListDirectory(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd : String; const ASwitches : String);

    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);
    procedure SSLGetPassword(var Password: String);
    procedure SSLGetPasswordEx(ASender : TObject; var VPassword: String; const AIsWrite : Boolean);


  public
    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses
//IdSSL,
  IdExplicitTLSClientServerBase,

  osSysUtils;

{ TFTPServer }

constructor TFTPServer.Create;
begin
  inherited;

  // inits default members values
  FFTPServer := nil;
  FIOHandlerSSLOpenSLL := nil;

  // creates, sets and start FTP server
  IdOpenSSLSetLibPath('D:\x\develop\qem\rosetta_cnc_1\openssl.64');

  FFTPServer := TIdFTPServer.Create;
  FFTPServer.DefaultPort := 21;

  FFTPServer.OnConnect := ServerConnect;
  FFTPServer.OnDisconnect := ServerDisconnect;
  FFTPServer.OnUserLogin := ServerUserLogin;
  FFTPServer.OnListDirectory := ServerListDirectory;

  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 := sslvSSLv23; // sslvTLSv1_2;
  FIOHandlerSSLOpenSLL.SSLOptions.CertFile := 'D:\x\develop\qem\rosetta_cnc_1\certificates\ftpserver\server-cert.pem';
  FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := 'D:\x\develop\qem\rosetta_cnc_1\certificates\ftpserver\server-key.pem';
  FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := 'D:\x\develop\qem\rosetta_cnc_1\certificates\ftpserver\root-cert.pem';
  FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := '';

  FFTPServer.IOHandler := FIOHandlerSSLOpenSLL;
  FFTPServer.UseTLS := utUseRequireTLS;

  FFTPServer.Active := True;
end;

destructor TFTPServer.Destroy;
begin
  //### does jobs to deactivate server before to free it!!!

  // frees objects
  SafeFreeAndNil(FFTPServer);
  SafeFreeAndNil(FIOHandlerSSLOpenSLL);

  inherited;
end;

procedure TFTPServer.ServerConnect(AContext: TIdContext);
begin
  //###
{
  If AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then
    TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough := False; //This function must be set to false for it to handle SSL/TLS functionality.
}
end;

procedure TFTPServer.ServerDisconnect(AContext: TIdContext);
begin
  //###
end;

procedure TFTPServer.ServerListDirectory(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd, ASwitches: String);
begin
  //###
end;

procedure TFTPServer.ServerUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var VAuthenticated: Boolean);
begin
  //###
  VAuthenticated := True;
end;

procedure TFTPServer.SSLGetPassword(var Password: String);
begin
  //###
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;

end.

    Filezilla reply:

    Status:    Connecting to 192.168.0.27:21...
    Status:    Connection established, waiting for welcome message...
    Status:    Initializing TLS...
    Status:    TLS connection established.
    Status:    Logged in
    Status:    Retrieving directory listing...
    Status:    Directory listing of "/" successful

    Log is very close to what happens with Python code:
    Status:    Connecting to 127.0.0.1:21...
    Status:    Connection established, waiting for welcome message...
    Status:    Initializing TLS...
    Status:    TLS connection established.
    Status:    Logged in
    Status:    Retrieving directory listing...
    Status:    Directory listing of "/" successful

  8. Posted

    Certificates are OK because I've tried to do the same thing with Python using them:
      

    # require pip install pyOpenSSL
# require pip install pyftpdlib

from pyftpdlib.authorizers import DummyAuthorizer
from pyftpdlib.handlers import FTPHandler, TLS_FTPHandler
from pyftpdlib.servers import FTPServer

def create_server():
    # Crea un'autorizzazione e aggiungi un utente
    authorizer = DummyAuthorizer()
    authorizer.add_user("user", "12345", "D:\\x\\develop\\qem\\rosetta_cnc_1\\certificates", perm="elradfmw")

    # Inizializza l'handler del server FTP e assegna l'autorizzatore
    handler = TLS_FTPHandler
    handler.authorizer = authorizer

    # Specifica i percorsi per i certificati SSL
    handler.certfile = "D:\\x\\develop\\qem\\rosetta_cnc_1\\certificates\\ftpserver\\server-cert.pem"  # Sostituisci con il percorso corretto del certificato
    handler.keyfile = "D:\\x\\develop\\qem\\rosetta_cnc_1\\certificates\\ftpserver\\server-key.pem"  # Sostituisci con il percorso corretto della chiave privata

    # Abilita TLS sull'handler
    handler.tls_control_required = True
    handler.tls_data_required = True

    # Configura altre opzioni dell'handler
    handler.passive_ports = range(60000, 65535)

    # Crea il server FTP e lo avvia
    server = FTPServer(("127.0.0.1", 21), handler)
    server.serve_forever()

if __name__ == "__main__":
    create_server()

    and Filezilla open now a TLS/SSL connection...

     

    Happy for a solution with Delphi 🙂

  9. Posted

    Hi all,

    sorry in advance for very newbie in TLS/SSL things.

    I'm trying to create a secure FTP Server (with TLS/SSL) using the latest Indy sources from the GitHub repository.
    I've created required certificates with OpenSSL and used openssl-1.0.2u-x64_86-win64 DLL's always from a GitHub repository (info from Embarcadero Delphi manual).

    This is an extract of dummy code to test an early connection using Filezilla FTP Client: 

    unit osFTPServer;

interface

uses
  IdContext,
  IdFTPList,
  IdFTPServer,
  IdFTPListOutput,

  IdSSLOpenSSL;

type
  TFTPServer = class
  private
    FFTPServer: TIdFTPServer;
    FIOHandlerSSLOpenSLL: TIdServerIOHandlerSSLOpenSSL;
  private
    procedure ServerConnect(AContext: TIdContext);
    procedure ServerDisconnect(AContext: TIdContext);
    procedure ServerUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var VAuthenticated: Boolean);
    procedure ServerListDirectory(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd : String; const ASwitches : String);

  public
    constructor Create;
    destructor Destroy; override;
  end;

implementation

uses
  IdSSLOpenSSLHeaders,

  osSysUtils;

{ TFTPServer }

constructor TFTPServer.Create;
begin
  inherited;

  // inits default members values
  FFTPServer := nil;
  FIOHandlerSSLOpenSLL := nil;

  // starts
  IdOpenSSLSetLibPath('D:\x\develop\qem\rosetta_cnc_1\openssl.64');

  FFTPServer := TIdFTPServer.Create;
  FFTPServer.DefaultPort := 21;

  FFTPServer.OnConnect := ServerConnect;
  FFTPServer.OnDisconnect := ServerDisconnect;
  FFTPServer.OnUserLogin := ServerUserLogin;
  FFTPServer.OnListDirectory := ServerListDirectory;

  FIOHandlerSSLOpenSLL := TIdServerIOHandlerSSLOpenSSL.Create(nil);
  FIOHandlerSSLOpenSLL.SSLOptions.Mode := sslmServer;
  FIOHandlerSSLOpenSLL.SSLOptions.Method := sslvTLSv1_2;
  FIOHandlerSSLOpenSLL.SSLOptions.CertFile := 'D:\x\develop\qem\rosetta_cnc_1\certificates\ftpserver\server-cert.pem';
  FIOHandlerSSLOpenSLL.SSLOptions.KeyFile := 'D:\x\develop\qem\rosetta_cnc_1\certificates\ftpserver\server-key.pem';
  FIOHandlerSSLOpenSLL.SSLOptions.RootCertFile := '';

  FFTPServer.IOHandler := FIOHandlerSSLOpenSLL;

  FFTPServer.Active := True;
end;

destructor TFTPServer.Destroy;
begin
  //### does jobs to deactivate server before to free it!!!

  // frees objects
  SafeFreeAndNil(FFTPServer);
  SafeFreeAndNil(FIOHandlerSSLOpenSLL);

  inherited;
end;

procedure TFTPServer.ServerConnect(AContext: TIdContext);
begin
  //###
end;

procedure TFTPServer.ServerDisconnect(AContext: TIdContext);
begin
  //###
end;

procedure TFTPServer.ServerListDirectory(ASender: TIdFTPServerContext; const APath: TIdFTPFileName; ADirectoryListing: TIdFTPListOutput; const ACmd, ASwitches: String);
begin
  //###
end;

procedure TFTPServer.ServerUserLogin(ASender: TIdFTPServerContext; const AUsername, APassword: string; var VAuthenticated: Boolean);
begin
  //###
  VAuthenticated := True;
end;

end.

    When I try to connect with FileZilla it say:
    image.png.31a6102fcea2812d59664a1be756db9b.png

     

    Status:    Connecting to 192.168.0.27:21...
    Status:    Connection established, waiting for welcome message...
    Status:    Insecure server, it does not support FTP over TLS.
    Status:    Logged in
    Status:    Retrieving directory listing...
    Status:    Directory listing of "/" successful

     

    What am I doing wrong?
    Thanks in advance for any suggestions.

  11. Posted

    Strange you have memory problems in compilation after 300000 lines of code.

    I have been compiling projects of almost 20,000,000 lines of code for years on a PC with 16GB of RAM without such problems.
    image.thumb.png.28f48cffdfe3b84a61005557ea932f5d.png
    Unfortunately, our software products are almost always free and related to the sale of cheap hardware so for the time

    being we have stopped at Sydney UP1 and so I don't know if the error problems with out of memory depend on the version....

    What I don't like about the system is that anyway as soon as a new version comes out there are no more patches for the most important stability bugs in the IDE and language server system....
     

  17. Posted

    Interesting and disheartening in the same way.


    Over the past 7 years, I have created an entire CNC ecosystem from logic boards to CNC control software running on Windows OS

    done entirely in Delphi (well it runs without any problem, and in some bought even better, in Linux environment under Wine,

    at least as far as memory management is concerned).

    For OPC UA server management I have already sketched out something following the OPC 40502 standard (OPC UA for Computerized Numerical Control (CNC) Systems),

    initially using Python opcua but then switched to a program external to Delphi made with QT.

    Not having native handling in Delphi makes things quite complex for me, and I have to do everything with an additional TCP layer between the two processes to exchange information, events, etc.

    I am precisely looking for a way to avoid all this and keep everything in one language and process.

  18. Posted

    Hi all.

    I need to implement an OPC UA Server in a Delphi program.

    Actually, I've used an external QT C++ application to do OPC UA things but is complex to

    maintain changes in the server and share an interface between this external program and the main program written with Delphi

    and I would like to know if there is a valid native Delphi library to use, better if open-source, but this is not mandatory.

     

    Thank you for your suggestions.

     

  21. Posted

    13 minutes ago, mvanrijnen said:
    8 minutes ago, mvanrijnen said:

    Just a quick question is the 16Mb limit still valid for the tool?

    I'm not an expert with PDB but that is what I've done and now seems to work:
     

    - Installed the latest version of VTune Profiler (2023.1.0).
    - Changed the original amplxe_media140.dll with an old version from Jan Rysavy (previous posts).
    - Enabled map in Detailed mode.
    - Compiled a project of 1.359.947 code lines (including library sources) which generate a map file of 49.696.190 bytes.
    - Executed map2pdb.exe rosettacncpph1.64.map -bind -v 

    D:\x\develop\qem\rosetta_cnc_1>map2pdb.exe rosettacncpph1.64.map -bind -v
map2pdb - Copyright (c) 2021 Anders Melander
Version 2.8.0

Constructed a new PDB GUID: {F2D8CB4B-DA08-4BBD-A399-DBC449AF1364}
Output filename not specified. Defaulting to rosettacncpph1.64.pdb
Reading MAP file
- Segments
- Modules
- Symbols
Warning: [116390] Failed to resolve symbol to module: [0004:00000000000002C8] SysInit.TlsLast
Warning: [116392] Failed to resolve symbol to module: [0003:00000000FE7F6000] SysInit.__ImageBase
- Line numbers
Collected 3.996 modules, 182.925 symbols, 525.223 lines, 985 source files
Constructing PDB file
- Collecting source file names
- Module streams
- Strings stream
- PDB Info stream
- TPI stream
- Symbols stream
- DBI stream
- IPI stream
- Finalizing PDB file
- 9.068 blocks written in 3 intervals
PE filename not specified. Defaulting to rosettacncpph1.64.exe
Patching PE file
- PE32+ image (64-bit)
- Adding .debug section.
- PDB file name has been stored in debug data.
- PE file has been updated.
Elapsed time: 00:00:00.895

    This has generated a PDB file of 37.142.528 bytes

    - Started profiling of EXE in VTune profiler which generates this log at the profiling stop: 

    Data collection is completed successfully

May 22 2023 18:06:59 The result file 'XXX\r001hs\r001hs.vtune' is successfully created and added to the project .

Finalization completed with warnings

May 22 2023 18:08:33 Result finalization has completed with warnings that may affect the representation of the analysis data. Please see details below.

Cannot locate debugging information for file `C:\WINDOWS\System32\msvcrt.dll'.
Cannot locate debugging information for file `C:\WINDOWS\WinSxS\amd64_microsoft.windows.common-controls_6595b64144ccf1df_6.0.19041.1110_none_60b5254171f9507e\COMCTL32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\WinSxS\amd64_microsoft.windows.gdiplus_6595b64144ccf1df_1.1.19041.2251_none_91a40448cc8846c1\gdiplus.dll'.
Cannot locate debugging information for file `C:\WINDOWS\SYSTEM32\ntdll.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\GDI32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\SETUPAPI.DLL'.
Cannot locate debugging information for file `C:\WINDOWS\System32\KERNEL32.DLL'.
Cannot locate debugging information for file `C:\WINDOWS\System32\cfgmgr32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\gdi32full.dll'.
Cannot locate debugging information for file `C:\Program Files\Bitdefender\Endpoint Security\bdhkm\dlls_266262988153465131\bdhkm64.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\user32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\combase.dll'.
Cannot locate debugging information for file `C:\Program Files\Bitdefender\Endpoint Security\atcuf\dlls_266575548366517634\atcuf64.dll'.
Cannot locate debugging information for file `C:\WINDOWS\system32\mswsock.dll'.
Cannot locate debugging information for file `C:\WINDOWS\system32\uxtheme.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\ole32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\SYSTEM32\opengl32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\SYSTEM32\DEVOBJ.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\KERNELBASE.dll'.
Cannot locate debugging information for file `C:\WINDOWS\SYSTEM32\TextShaping.dll'.
Cannot locate debugging information for file `C:\Windows\System32\msxml6.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\WS2_32.dll'.
Cannot locate debugging information for file `C:\WINDOWS\System32\DriverStore\FileRepository\nv_dispi.inf_amd64_c1a085cc86772d3f\nvoglv64.dll'.
Cannot locate debugging information for file `C:\WINDOWS\SYSTEM32\HID.DLL'.
Cannot locate debugging information for file `C:\WINDOWS\System32\win32u.dll'.
Cannot locate debugging information for file `C:\Program Files (x86)\Intel\oneAPI\vtune\latest\bin64\tpsstool.dll'.:

    And all symbols project symbols are visible (not for below list of DLL):
    image.thumb.png.379a0032676cb7178ad974109308ea1b.png





  23. Posted

    2 hours ago, Jan Rysavy said:

     

    I can confirm replacing C:\Program Files (x86)\Intel\oneAPI\vtune\2023.1.0\bin64\amplxe_msdia140.dll (version 14.34.31942.0) with version 14.28.29910.0 from VTune 2022.4.1 solves this problem!

    Can you attach the working DLL to try ?

     

  24. Posted

    9 minutes ago, Jan Rysavy said:

    I just want to add that I installed an older version of VTune 2022.4.1 and the function names are displayed correctly. The problem seems to be related to the new version VTune 2023.1.

    I've tried to find a way to download the older version (2022.4.1) but no way found on the intel VTune pages....

  25. Posted · Edited by shineworld

    Incredible tool, congrats.


    I've tried to use it with Sydney 10.4.1 and VTune 2023.1.0.
     

    Unfortunately, I was not able to get the function as name, I get only func addresses:
    image.thumb.png.829647b085ce0c09b7d8e2041edbc34f.png

     

    I've tried with: 

    D:\x\develop\qem\rosetta_cnc_1>map2pdb.exe rosettacncpph1.64.map -bind
map2pdb - Copyright (c) 2021 Anders Melander
Version 2.8.0

    and also with: 

    D:\x\develop\qem\rosetta_cnc_1>map2pdb.exe -bind rosettacncpph1.64.map
map2pdb - Copyright (c) 2021 Anders Melander
Version 2.8.0

    Map is set to Detailed on Sydney 10.4.1:
    image.thumb.png.c7ddcff82caf64eba091f142282eaeb7.png

      

    D:\x\develop\qem\rosetta_cnc_1>map2pdb.exe rosettacncpph1.64.map -bind -v
map2pdb - Copyright (c) 2021 Anders Melander
Version 2.8.0

Constructed a new PDB GUID: {5D8591F1-8F38-4E7B-BAE4-1BB55536733F}
Output filename not specified. Defaulting to rosettacncpph1.64.pdb
Reading MAP file
- Segments
- Modules
- Symbols
Warning: [116390] Failed to resolve symbol to module: [0004:00000000000002C8] SysInit.TlsLast
Warning: [116392] Failed to resolve symbol to module: [0003:00000000FE7F6000] SysInit.__ImageBase
- Line numbers
Collected 3.996 modules, 182.925 symbols, 525.223 lines, 985 source files
Constructing PDB file
- Collecting source file names
- Module streams
- Strings stream
- PDB Info stream
- TPI stream
- Symbols stream
- DBI stream
- IPI stream
- Finalizing PDB file
- 9.068 blocks written in 3 intervals
PE filename not specified. Defaulting to rosettacncpph1.64.exe
Patching PE file
- PE32+ image (64-bit)
- Adding .debug section.
- PDB file name has been stored in debug data.
- PE file has been updated.
Elapsed time: 00:00:00.874

     

    I hope you have a simple solution to my possible mistakes.

×