Home
> C/C++, Delphi, JavaScript, Object Pascal, QTX, Quartex Pascal > C/C++ porting, QTX and general status
C/C++ porting, QTX and general status
C is a language that I used to play around with a lot back in the Amiga days. I think the last time I used a C compiler to write a library must have been in 1992 or something like that? I held on to my Amiga 1200 for as long as i could – but having fallen completely in love with Pascal, I eventually switched to x86 and went down the Turbo Pascal road.
Lately however, C++ developers have been asking for their own Developer group on Facebook. I run several groups on Facebook in the so-called “developer” family. So you have Delphi Developer, FPC Developer, Node.JS Developer and now – C++Builder developer. The groups more or less tend to themselves, and the node.js and FPC groups are presently being seeded (meaning, that the member count is being grown for a period).
The C++Builder group however, is having the same activity level as the Delphi group almost, thanks to some really good developers that post links, tips and help solve questions. I was also fortunate enough to have David Millington come on the Admin team. David is leading the C++Builder project, so his insight and knowledge of both language and product is exemplary. Just like Jim McKeeth, he is a wonderful resource for the community and chime in with answers to tricky questions whenever he has time to spare.
Getting back in the saddle
Having working some 30 years with Pascal and Object Pascal, 25 of those years in Delphi, C/C++ is never far away. I have an article on the subject that i’ve written for the Idera Community website, so I wont dig too deep into that here — but needless to say, Rad Studio consists of two languages: Object Pascal and C/C++, so no matter how much you love either language, the other is never far away.
So I figured it was time for this old dog to learn some new tricks! I have always said that it’s wise to learn a language immediately below and above your comfort zone. So if Delphi is your favorite language, then C/C++ is below you (meaning: more low level and complex). Above you are languages like JavaScript and C#. Learning JavaScript makes strategic sense (or use DWScript to compile Pascal to JavaScript like I do).
When I started out, the immediate language below Object Pascal was never C, but assembler. So for the longest time I turned to assembler whenever I needed a speed boost; graphics manipulation and processing pixels is especially a field where assembly makes all the difference.
But since C++Builder is indeed an integral part of Rad Studio, and Object Pascal and C/C++ so intimately connected (they have evolved side by side), why not enjoy both assembly and C right?
So I decided to jump back into the saddle and see what I could make of it.
C/C++ is not as hard as you think
I’m having a ball writing C/C++, and just like Delphi – you can start where you are.
While I’m not going to rehash the article I have already prepared for the Idera Community pages here, I do want to encourage people to give it a proper try. I have always said that if you know an archetypal language, you can easily pick up other languages, because the archetypal languages will benefit you for a lifetime. This has to do with archetypal languages operating according to how computers really work; as opposed to optimistic languages (a term from the DB work, optimistic locking), also called contextual languages, like C#, Java, JavaScript etc. are based on how human beings would like things to be.
So I now had a chance to put my money where my mouth is.
When I left C back in the early 90s, I never bothered with OOP. I mean, I used C purely for shared libraries anyways, while the actual programs were done in Pascal or a hybrid language called Blitz Basic. The latter compiled to razor sharp machine code, and you could use inline assembly – which I used a lot back then (very few programmers on those machines went without assembler, it was almost given that you could use 68k in some capacity).
Without ruining the article about to be published, I had a great time with C++Builder. It took a few hours to get my bearings, but since both the VCL and FMX frameworks are there – you can approach C/C++ just like you would Object Pascal. So it’s a matter of getting an overview really.
Needless to say, I’ll be porting a fair share of my libraries to C/C++ when I have time (those that makes sense under that paradigme). It’s always good to push yourself and there are plenty of subtle differences that I found useful.
Quartex Media Desktop
When I last wrote about QTX we were nearing the completion of the FileSystem and Task Management service. The prototype had all its file-handling directly in the core service (or server) which worked just fine — but it was linked to the Smart Pascal RTL. It has taken time to write a new RTL + a full multi-user, platform independent service stack and desktop (phew!) but we are seeing progress!
The QTX Baseline backend services is now largely done
The filesystem service is now largely done! There are a few synchronous calls I want to get rid of, but thankfully my framework has both async and sync variations of all file procedures – so that is now finished.
To make that clearer: first I have to wrap and implement the functionality for the RTL. Once they are in the RTL, I can use those functions to build the service functions. So yeah, it’s been extremely elaborate — but thankfully it’s also become a rich, well organized codebase (both the RTL and the Quartex Media Desktop codebases) – so I think we are ready to get cracking on the core!
The core is still operating with the older API. So our next step is to remove that from the core and instead delegate calls to the filesystem to our new service. So the core will simply be reduced to a post-office or traffic officer if you like. Messages come in from the desktops, and the core delegates the messages to whatever service is in charge of them.
But, this also means that both the core and the desktop must use the new and fancy messages. And this is where I did something very clever.
While I was writing the service, I also write a client class to test (obviously). And the way the core works — means that the same client that the core use to talk to the services — can be used by the desktop as well.
So our work in the desktop to get file-access and drives running again, is to wrap the client in our TQTXDevice ancestor class. The desktop NEVER accesses the API directly. All it knows about are these device drivers (or object instances). Which is how we solve things like DropBox and Google Drive support. The desktop wont have the faintest clue that its using Dropbox, or copying files between a local disk and Google Drive for example — because it only communicates with these device classes.
Recursive stuff
One thing that sucked about node.js function for deleting a folder, is that it’s recursive parameter doesn’t work on Windows or OS X. So I had to implement a full recursive deletefolder routine manually. Not a big thing, but slightly more painful than expected under asynchronous execution. Thankfully, Object Pascal allows for inline defined procedures, so I didn’t have to isolate it in a separate class.
Here is some of the code, a tiny spec compared to the full shabam, but it gives you an idea of what life is like under async conditions:
unit service.file.core;
interface
{.$DEFINE DEBUG}
const
CNT_PREFS_DEFAULTPORT = 1883;
CNT_PREFS_FILENAME = 'QTXTaskManager.preferences.ini';
CNT_PREFS_DBNAME = 'taskdata.db';
CNT_ZCONFIG_SERVICE_NAME = 'TaskManager';
uses
qtx.sysutils,
qtx.json,
qtx.db,
qtx.logfile,
qtx.orm,
qtx.time,
qtx.node.os,
qtx.node.sqlite3,
qtx.node.zconfig,
qtx.node.cluster,
qtx.node.core,
qtx.node.filesystem,
qtx.node.filewalker,
qtx.fileapi.core,
qtx.network.service,
qtx.network.udp,
qtx.inifile,
qtx.node.inifile,
NodeJS.child_process,
ragnarok.types,
ragnarok.Server,
ragnarok.messages.base,
ragnarok.messages.factory,
ragnarok.messages.network,
service.base,
service.dispatcher,
service.file.messages;
type
TQTXTaskServiceFactory = class(TMessageFactory)
protected
procedure RegisterIntrinsic; override;
end;
TQTXFileWriteCB = procedure (TagValue: variant; Error: Exception);
TQTXFileStateCB = procedure (TagValue: variant; Error: Exception);
TQTXUnRegisterLocalDeviceCB = procedure (TagValue: variant; DiskName: string; Error: Exception);
TQTXRegisterLocalDeviceCB = procedure (TagValue: variant; LocalPath: string; Error: Exception);
TQTXFindDeviceCB = procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception);
TQTXGetDisksCB = procedure (TagValue: variant; Devices: JDeviceList; Error: Exception);
TQTXGetFileInfoCB = procedure (TagValue: variant; LocalName: string; Info: JStats; Error: Exception);
TQTXGetTranslatePathCB = procedure (TagValue: variant; Original, Translated: string; Error: Exception);
TQTXCheckDevicePathCB = procedure (TagValue: variant; PathName: string; Error: Exception);
TQTXServerExecuteCB = procedure (TagValue: variant; Data: string; Error: Exception);
TQTXTaskService = class(TRagnarokService)
private
FPrefs: TQTXIniFile;
FLog: TQTXLogEmitter;
FDatabase: TSQLite3Database;
FZConfig: TQTXZConfigClient;
FRegHandle: TQTXDispatchHandle;
FRegCount: integer;
procedure HandleGetDevices(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleGetDeviceByName(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleCreateLocalDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleDestroyDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileRead(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileReadPartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleGetFileInfo(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileDelete(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileWrite(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileWritePartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleFileRename(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleGetDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleMkDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure HandleRmDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
procedure ExecuteExternalJS(Params: array of string;
TagValue: variant; const CB: TQTXServerExecuteCB);
procedure SendError(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage; Message: string);
protected
function GetFactory: TMessageFactory; override;
procedure SetupPreferences(const CB: TRagnarokServiceCB);
procedure SetupLogfile(LogFileName: string;const CB: TRagnarokServiceCB);
procedure SetupDatabase(const CB: TRagnarokServiceCB);
procedure ValidateLocalDiskName(TagValue: variant; Username, DeviceName: string; CB: TQTXCheckDevicePathCB);
procedure RegisterLocalDevice(TagValue: variant; Username, DiskName: string; CB: TQTXRegisterLocalDeviceCB);
procedure UnRegisterLocalDevice(TagValue: variant; UserName, DiskName:string; CB: TQTXUnRegisterLocalDeviceCB);
procedure GetDevicesForUser(TagValue: variant; UserName: string; CB: TQTXGetDisksCB);
procedure FindDeviceByName(TagValue: variant; UserName, DiskName: string; CB: TQTXFindDeviceCB);
procedure FindDeviceByType(TagValue: variant; UserName: string; &Type: JDeviceType; CB: TQTXGetDisksCB);
procedure GetTranslatedPathFor(TagValue: variant; Username, FullPath: string; CB: TQTXGetTranslatePathCB);
procedure GetFileInfo(TagValue: variant; UserName: string; FullPath: string; CB: TQTXGetFileInfoCB);
procedure SetupTaskTable(const TagValue: variant; const CB: TRagnarokServiceCB);
procedure SetupOperationsTable(const TagValue: variant; const CB: TRagnarokServiceCB);
procedure SetupDeviceTable(const TagValue: variant; const CB: TRagnarokServiceCB);
procedure AfterServerStarted; override;
procedure BeforeServerStopped; override;
procedure Dispatch(Socket: TNJWebSocketSocket; Message: TQTXBaseMessage); override;
public
property Preferences: TQTXIniFile read FPrefs;
property Database: TSQLite3Database read FDatabase;
procedure SetupService(const CB: TRagnarokServiceCB);
constructor Create; override;
destructor Destroy; override;
end;
implementation
//#############################################################################
// TQTXFileenticationFactory
//#############################################################################
procedure TQTXTaskServiceFactory.RegisterIntrinsic;
begin
writeln("Registering task interface");
&Register(TQTXFileGetDeviceListRequest);
&Register(TQTXFileGetDeviceByNameRequest);
&Register(TQTXFileCreateLocalDeviceRequest);
&Register(TQTXFileDestroyDeviceRequest);
&Register(TQTXFileReadPartialRequest);
&Register(TQTXFileReadRequest);
&Register(TQTXFileWritePartialRequest);
&Register(TQTXFileWriteRequest);
&Register(TQTXFileDeleteRequest);
&Register(TQTXFileRenameRequest);
&Register(TQTXFileInfoRequest);
&Register(TQTXFileDirRequest);
&Register(TQTXMkDirRequest);
&Register(TQTXRmDirRequest);
&Register(TQTXFileRenameRequest);
&Register(TQTXFileDirRequest);
end;
//#############################################################################
// TQTXTaskService
//#############################################################################
constructor TQTXTaskService.Create;
begin
inherited Create;
FPrefs := TQTXIniFile.Create();
FLog := TQTXLogEmitter.Create();
FDatabase := TSQLite3Database.Create(nil);
FZConfig := TQTXZConfigClient.Create();
FZConfig.Port := 2292;
self.OnUserSignedOff := procedure (Sender: TObject; Username: string)
begin
WriteToLogF("We got a service signal! User [%s] has signed off completely", [Username]);
end;
MessageDispatch.RegisterMessage(TQTXFileGetDeviceListRequest, @HandleGetDevices);
MessageDispatch.RegisterMessage(TQTXFileGetDeviceByNameRequest, @HandleGetDeviceByName);
MessageDispatch.RegisterMessage(TQTXFileCreateLocalDeviceRequest, @HandleCreateLocalDevice);
MessageDispatch.RegisterMessage(TQTXFileDestroyDeviceRequest, @HandleDestroyDevice);
MessageDispatch.RegisterMessage(TQTXFileReadRequest, @HandleFileRead);
MessageDispatch.RegisterMessage(TQTXFileReadPartialRequest, @HandleFileReadPartial);
MessageDispatch.RegisterMessage(TQTXFileWriteRequest, @HandleFileWrite);
MessageDispatch.RegisterMessage(TQTXFileWritePartialRequest, @HandleFileWritePartial);
MessageDispatch.RegisterMessage(TQTXFileInfoRequest, @HandleGetFileInfo);
MessageDispatch.RegisterMessage(TQTXFileDeleteRequest, @HandleFileDelete);
MessageDispatch.RegisterMessage(TQTXMkDirRequest, @HandleMkDir);
MessageDispatch.RegisterMessage(TQTXRmDirRequest, @HandleRmDir);
MessageDispatch.RegisterMessage(TQTXFileRenameRequest, @HandleFileRename);
MessageDispatch.RegisterMessage(TQTXFileDirRequest, @HandleGetDir);
end;
destructor TQTXTaskService.Destroy;
begin
// decouple logger from our instance
self.logging := nil;
// Release prefs + log
FPrefs.free;
FLog.free;
FZConfig.free;
inherited;
end;
procedure TQTXTaskService.SendError(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage; Message: string);
begin
var reply := TQTXErrorMessage.Create(request.ticket);
try
reply.Code := CNT_MESSAGE_CODE_ERROR;
reply.Routing.TagValue := Request.Routing.TagValue;
reply.Response := Message;
if Socket.ReadyState = rsOpen then
begin
try
Socket.Send( reply.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end else
WriteToLog("Failed to dispatch error, socket is closed error");
finally
reply.free;
end;
end;
procedure TQTXTaskService.ExecuteExternalJS(Params: array of string;
TagValue: variant; const CB: TQTXServerExecuteCB);
begin
var LTask: JChildProcess;
var lOpts := TVariant.CreateObject();
lOpts.shell := false;
lOpts.detached := true;
Params.insert(0, '--no-warnings');
// Spawn a new process, this creates a new shell interface
try
LTask := child_process().spawn('node', Params, lOpts );
except
on e: exception do
begin
if assigned(CB) then
CB(TagValue, e.message, e);
exit;
end;
end;
// Map general errors on process level
LTask.on('error', procedure (error: variant)
begin
{$IFDEF DEBUG}
writeln("error->" + error.toString());
{$ENDIF}
WriteToLog(error.toString());
if assigned(CB) then
CB(TagValue, "", nil);
end);
// map stdout so we capture the output
LTask.stdout.on('data', procedure (data: variant)
begin
if assigned(CB) then
CB(TagValue, data.toString(), nil);
end);
// map stderr so we can capture exception messages
LTask.stderr.on('data', procedure (error:variant)
begin
{$IFDEF DEBUG}
writeln("stdErr->" + error.toString());
{$ENDIF}
if assigned(CB) then
CB(TagValue, "", nil);
WriteToLog(error.toString());
end);
end;
function TQTXTaskService.GetFactory: TMessageFactory;
begin
result := TQTXTaskServiceFactory.Create();
end;
procedure TQTXTaskService.SetupService(const CB: TRagnarokServiceCB);
begin
SetupPreferences( procedure (Error: Exception)
begin
// No logfile yet setup (!)
if Error nil then
begin
WriteToLog("Preferences setup: Failed!");
WriteToLog(error.message);
raise error;
end else
WriteToLog("Preferences setup: OK");
// logfile-name is always relative to the executable
var LLogFileName := TQTXNodeFileUtils.IncludeTrailingPathDelimiter( TQTXNodeFileUtils.GetCurrentDirectory );
LLogFileName += FPrefs.ReadString('log', 'logfile', 'log.txt');
// Port is defined in the ancestor, so we assigns it here
Port := FPrefs.ReadInteger('networking', 'port', CNT_PREFS_DEFAULTPORT);
SetupLogfile(LLogFileName, procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog("Logfile setup: Failed!");
WriteToLog(error.message);
raise error;
end else
WriteToLog("Logfile setup: OK");
SetupDatabase( procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog("Database setup: Failed!");
WriteToLog(error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
end else
WriteToLog("Database setup: OK");
if assigned(CB) then
CB(nil);
end);
end);
end);
end;
procedure TQTXTaskService.SetupPreferences(const CB: TRagnarokServiceCB);
begin
var lBasePath := TQTXNodeFileUtils.GetCurrentDirectory;
var LPrefsFile := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + CNT_PREFS_FILENAME;
if TQTXNodeFileUtils.FileExists(LPrefsFile) then
begin
FPrefs.LoadFromFile(nil, LPrefsFile, procedure (TagValue: variant; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end;
if assigned(CB) then
CB(nil);
end);
end else
begin
var LError := Exception.Create('Could not locate preferences file: ' + LPrefsFile);
WriteToLog(LError.message);
if assigned(CB) then
CB(LError)
else
raise LError;
end;
end;
procedure TQTXTaskService.SetupLogfile(LogFileName: string;const CB: TRagnarokServiceCB);
begin
// Attempt to open logfile
// Note: Log-object error options is set to throw exceptions
try
FLog.Open(LogFileName);
except
on e: exception do
begin
if assigned(CB) then
begin
CB(e);
exit;
end else
begin
writeln(e.message);
raise;
end;
end;
end;
// We inherit from TQTXLogObject, which means we can pipe
// all errors etc directly using built-in functions. So here
// we simply glue our instance to the log-file, and its all good
self.Logging := FLog as IQTXLogClient;
if assigned(CB) then
CB(nil);
end;
procedure TQTXTaskService.FindDeviceByType(TagValue: variant; UserName: string; &Type: JDeviceType; CB: TQTXGetDisksCB);
begin
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to lookup disk, username was invalid error");
var lError := EException.Create("Failed to lookup devices, invalid username");
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
GetDevicesForUser(TagValue, Username,
procedure (TagValue: variant; Devices: JDeviceList; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, nil, Error)
else
raise Error;
exit;
end;
var x := 0;
while x < Devices.dlDrives.Count do
begin
if Devices.dlDrives[x].&Type &Type then
begin
Devices.dlDrives.delete(x, 1);
continue;
end;
inc(x);
end;
if assigned(CB) then
CB(TagValue, Devices, nil);
end);
end;
procedure TQTXTaskService.FindDeviceByName(TagValue: variant; Username, DiskName: string; CB: TQTXFindDeviceCB);
begin
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
var lLogText := "Failed to lookup device, username was invalid error";
WriteToLog(lLogText);
var lError := EException.Create(lLogText);
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
DiskName := DiskName.trim();
if DiskName.length < 1 then
begin
var lLogText := "Failed to lookup device, disk-name was invalid error";
WriteToLog(lLogText);
var lError := EException.Create(lLogText);
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
GetDevicesForUser(TagValue, Username,
procedure (TagValue: variant; Devices: JDeviceList; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, nil, Error)
else
raise Error;
exit;
end;
DiskName := DiskName.trim().ToLower();
var lDiskInfo: JDeviceInfo := nil;
for var disk in Devices.dlDrives do
begin
if disk.Name.ToLower() = DiskName then
begin
lDiskInfo := disk;
break;
end;
end;
if assigned(CB) then
CB(TagValue, lDiskInfo, nil);
end);
end;
procedure TQTXTaskService.GetTranslatedPathFor(TagValue: variant; Username, FullPath: string; CB: TQTXGetTranslatePathCB);
begin
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(TagValue, UserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, FullPath, '', Error)
else
raise Error;
exit;
end;
if Device.&Type dtLocal then
begin
var lError := EException.CreateFmt('Failed to translate path, device [%s] is not local error', [Device.Name]);
if assigned(CB) then
CB(TagValue, FullPath, '', Error)
else
raise Error;
exit;
end;
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Return translated path
if assigned(CB) then
CB(TagValue, FullPath, lFullPath, nil);
end);
end else
begin
var lErr := EException.CreateFmt("Invalid path [%s] error", [FullPath]);
if assigned(CB) then
CB(TagValue, FullPath, '', lErr)
else
raise lErr;
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.GetFileInfo(TagValue: variant; UserName, FullPath: string; CB: TQTXGetFileInfoCB);
begin
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(TagValue, UserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, '', nil, Error)
else
raise Error;
exit;
end;
case Device.&Type of
dtLocal:
begin
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Call the underlying OS to get the file statistics
NodeJsFsAPI().lStat(lFullPath,
procedure (Error: JError; Stats: JStats)
begin
if Error nil then
begin
var lError := EException.Create(Error.message);
if assigned(CB) then
CB(TagValue, lFullPath, nil, lError)
else
raise lError;
exit;
end;
// And deliver
if assigned(CB) then
CB(TagValue, lFullPath, Stats, nil);
end);
end;
dtDropbox, dtGoogle, dtMsDrive:
begin
var lError := EException.Create("Cloud bindings not activated error");
if assigned(CB) then
CB(TagValue, '', nil, lError)
end;
end;
end);
end else
begin
var lErr := EException.CreateFmt("Invalid path [%s] error", [FullPath]);
if assigned(CB) then
CB(TagValue, '', nil, lErr)
else
raise lErr;
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.GetDevicesForUser(TagValue: variant; Username: string; CB: TQTXGetDisksCB);
begin
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to lookup devices, username was invalid error");
var lError := EException.Create("Failed to lookup devices, invalid username");
if assigned(CB) then
CB(TagValue, nil, lError)
else
raise lError;
exit;
end;
var lTransaction: TQTXReadTransaction;
if not TSQLite3Database(DataBase).CreateReadTransaction(lTransaction) then
begin
var lErr := EException.Create("Failed to create read-transaction error");
if assigned(cb) then
CB(TagValue, nil, lErr)
else
raise lErr;
exit;
end;
var lQuery := TSQLite3ReadTransaction(lTransaction);
lQuery.SQL := "select * from devices where owner=?";
lQuery.Parameters.AddValueOnly(Username);
lQuery.Execute(
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, nil, Error)
else
raise Error;
exit;
end;
var lDisks := new JDeviceList();
lDisks.dlUser := UserName;
for var x := 0 to lQuery.datarows.length-1 do
begin
var lInfo := new JDeviceInfo();
lInfo.Name := lQuery.datarows[x]["name"];
lInfo.&Type := JDeviceType( lQuery.datarows[x]["type"] );
lInfo.owner := lQuery.datarows[x]["owner"];
lInfo.location := lQuery.datarows[x]["location"];
lInfo.APIKey := lQuery.datarows[x]["apikey"];
lInfo.APISecret := lQuery.datarows[x]["apisecret"];
lInfo.APIPassword := lQuery.datarows[x]["apipassword"];
lInfo.APIUser := lQuery.datarows[x]["apiuser"];
lDisks.dlDrives.add(lInfo);
end;
try
if assigned(CB) then
CB(TagValue, lDisks, nil);
finally
lQuery.free;
end;
end);
end;
procedure TQTXTaskService.ValidateLocalDiskName(TagValue: variant; Username, DeviceName: string; CB: TQTXCheckDevicePathCB);
begin
var Filename := 'disk.' + username + '.' + DeviceName + '.' + ord(JDeviceType.dtLocal).ToString();
var LBasePath := TQTXNodeFileUtils.GetCurrentDirectory();
LBasePath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + 'userdevices';
// Make sure the device folder is there
if not TQTXNodeFileUtils.DirectoryExists(LBasePath) then
begin
var lError := EException.CreateFmt("Directory not found: %s", [lBasePath]);
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
lBasePath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + Filename;
if TQTXNodeFileUtils.DirectoryExists(LBasePath) then
begin
var lError := EException.CreateFmt("Path already exist error [%s]", [lBasePath]);
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
// OK, folder is not created yet, so its good to go
if assigned(CB) then
CB(TagValue, Filename, nil);
end;
procedure TQTXTaskService.UnRegisterLocalDevice(TagValue: variant; UserName, DiskName: string; CB: TQTXUnRegisterLocalDeviceCB);
begin
WriteToLogF("Removing local device [%s] for user [%s] ", [DiskName, Username]);
// Check username string
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to unregister device, username was invalid error");
var lError := EException.Create("Failed to register device, invalid username");
if assigned(CB) then
CB(TagValue, DiskName, lError)
else
raise lError;
exit;
end;
// Check diskname string
DiskName := DiskName.trim().ToLower();
if DiskName.length < 1 then
begin
WriteToLog("Failed to unregister device, disk-name was invalid error");
var lError := EException.Create("Failed to register device, invalid disk-name");
if assigned(CB) then
CB(TagValue, DiskName, lError)
else
raise lError;
exit;
end;
FindDeviceByName(TagValue, Username, DiskName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
// Did the search fail?
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(TagValue, DiskName, Error)
else
raise Error;
exit;
end;
// Make sure the device is local
if Device.&Type dtLocal then
begin
var lError := EException.CreateFmt('Failed to translate path, device [%s] is not local error', [Device.Name]);
if assigned(CB) then
CB(TagValue, DiskName, Error)
else
raise Error;
exit;
end;
// Delete record from database
var lWriter: TQTXWriteTransaction;
if FDatabase.CreateWriteTransaction(lWriter) then
begin
lWriter.SQL := "delete from profiles where user = ? and name = ?;";
lWriter.Parameters.AddValueOnly(Username);
lWriter.Parameters.AddValueOnly(DiskName);
lWriter.Execute(
procedure (Sender: TObject; Error: Exception)
begin
try
if Error nil then
begin
if assigned(CB) then
CB(TagValue, DiskName, Error)
else
raise Error;
exit;
end;
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
// Now delete the disk-drive directory
TQTXNodeFileUtils.DeleteDirectory(nil, lFullPath,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if assigned(CB) then
CB(TagValue, DiskName, Error)
end);
finally
lWriter.free;
lWriter := nil;
end;
end);
end;
end);
end;
procedure TQTXTaskService.RegisterLocalDevice(TagValue: variant; Username, DiskName: string; CB: TQTXRegisterLocalDeviceCB);
begin
WriteToLogF("Adding local device [%s] for user [%s] ", [DiskName, Username]);
UserName := username.trim().ToLower();
if Username.length < 1 then
begin
WriteToLog("Failed to register device, username was invalid error");
var lError := EException.Create("Failed to register device, invalid username");
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
DiskName := DiskName.trim().ToLower();
if DiskName.length < 1 then
begin
WriteToLog("Failed to register device, disk-name was invalid error");
var lError := EException.Create("Failed to register device, invalid disk-name");
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
FindDeviceByName(TagValue, Username, DiskName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
// Did the search fail?
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(TagValue, '', Error)
else
raise Error;
exit;
end;
// Does a device that match already exist?
if Device nil then
begin
var lError := EException.CreateFmt("Failed to create device [%s], device already exists", [DiskName]);
if assigned(CB) then
CB(TagValue, '', lError)
else
raise lError;
exit;
end;
// make sure the device-folder does not exist, so we can create it
ValidateLocalDiskName(TagValue, Username, DiskName,
procedure (TagValue: variant; PathName: string; Error: Exception)
begin
if Error nil then
begin
if assigned(CB) then
CB(TagValue, '', Error)
else
raise Error;
exit;
end;
// ValidateLocalDiskName only returns the valid directory-name,
// not a full path -- so we need to build up the full targetpath
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + PathName;
TQTXNodeFileUtils.CreateDirectory(nil, lFullPath,
procedure (TagValue: variant; Path: string; Error: exception)
begin
if Error nil then
begin
var lError := EException.CreateFmt("Failed to create device [%s] with path: %s", [DiskName, lFullPath]);
if assigned(CB) then
CB(TagValue, PathName, lError)
else
raise lError;
exit;
end;
FDatabase.Execute(
#'insert into devices (type, owner, name, location)
values(?, ?, ?, ?);',
[ord(JDeviceType.dtLocal), UserName, Diskname, PathName] ,
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(TagValue, PathName, Error)
else
raise Error;
exit;
end;
WriteToLogF("Device [%s] added to database user [%s]", [DiskName, UserName]);
if assigned(CB) then
CB(TagValue, PathName, nil);
end);
end);
end);
end);
end;
procedure TQTXTaskService.SetupDeviceTable(const TagValue: variant; const CB: TRagnarokServiceCB);
begin
FDatabase.Execute(
#'
create table if not exists devices
(
id integer primary key AUTOINCREMENT,
type integer,
owner text,
name text,
location text,
apikey text,
apisecret text,
apipassword text,
apiuser text
);
', [],
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
if assigned(CB) then
CB(nil);
end);
end;
procedure TQTXTaskService.SetupTaskTable(const TagValue: variant; const CB: TRagnarokServiceCB);
begin
FDatabase.Execute(
#'
create table if not exists tasks
(
id integer primary key AUTOINCREMENT,
state integer,
username text,
created real
);
', [],
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
if assigned(CB) then
CB(nil);
end);
end;
procedure TQTXTaskService.SetupOperationsTable(const TagValue: variant; const CB: TRagnarokServiceCB);
begin
FDatabase.Execute(
#'
create table if not exists operations
(
id integer primary key AUTOINCREMENT,
username text,
taskid integer,
name text,
filename text
);
', [],
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
if assigned(CB) then
CB(nil);
end);
end;
procedure TQTXTaskService.SetupDatabase(const CB: TRagnarokServiceCB);
begin
// Try to read database-path from preferences file
var LDbFileToOpen := FPrefs.ReadString("database", "database_name", "");
// Trim away spaces, check if there is a filename
LDbFileToOpen := LDbFileToOpen.trim();
if LDbFileToOpen.length < 1 then
begin
// No filename? Fall back on pre-defined file in CWD
var LBasePath := TQTXNodeFileUtils.GetCurrentDirectory();
LDbFileToOpen := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(LBasePath) + CNT_PREFS_DBNAME;
end;
FDatabase.AccessMode := TSQLite3AccessMode.sqaReadWriteCreate;
FDatabase.Open(LDbFileToOpen,
procedure (Sender: TObject; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end;
WriteToLog("Initializing task table");
SetupTaskTable(nil, procedure (Error: exception)
begin
if Error nil then
begin
WriteToLog("Tasks initialized: **failed");
WriteToLog(error.message);
if assigned(CB) then
CB(Error)
else
raise Error;
exit;
end else
writeToLog("Tasks initialized: OK");
WriteToLog("Initializing operations table");
SetupOperationsTable(nil, procedure (Error: exception)
begin
if Error nil then
begin
WriteToLog("Operations initialized: **failed");
WriteToLog(error.message);
if assigned(CB) then
CB(Error);
exit;
end else
writeToLog("Operations initialized: OK");
WriteToLog("Initializing device table");
SetupDeviceTable(nil, procedure (Error: exception)
begin
if Error nil then
begin
WriteToLog("Device-table initialized: **failed");
WriteToLog(error.message);
if assigned(CB) then
CB(Error);
exit;
end else
writeToLog("Device-table initialized: OK");
if assigned(CB) then
CB(nil);
end);
end);
end);
end);
end;
procedure TQTXTaskService.HandleFileRead(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileReadRequest(request);
var lUserName := lRequest.UserName;
var lFileName := lRequest.FileName;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lOptions: TReadFileOptions;
lOptions.encoding := 'binary';
NodeJsFsAPI().readFile(LocalFile, lOptions,
procedure (Error: JError; Data: JNodeBuffer)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileReadResponse.Create(Request.Ticket);
lResponse.UserName := lUserName;
lResponse.Routing.TagValue := request.routing.tagValue;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Convert filedata in one pass
try
var lConvert := TDataTypeConverter.Create();
try
lResponse.Attachment.AppendBytes( lConvert.TypedArrayToBytes(Data) );
finally
lConvert.free;
end;
except
on e: exception do
begin
WriteToLog(e.message);
SendError(Socket, Request, e.Message);
exit;
end;
end;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end;
procedure TQTXTaskService.HandleFileReadPartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileReadPartialRequest(request);
var lUserName := lRequest.UserName;
var lFileName := lRequest.FileName;
var lStart := lRequest.Offset;
var lSize := lRequest.Size;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
if lSize < 1 then
begin
SendError(Socket, Request, "Read failed, invalid size error");
exit;
end;
if lStart < 0 then
begin
SendError(Socket, Request, "Read failed, invalid offset error");
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if lStart > Info.size then
begin
SendError(Socket, Request, "Read failed, offset beyond filesize error");
exit;
end;
NodeJsFsAPI().open(LocalFile, "r",
procedure (Error: JError; Fd: THandle)
begin
if error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
var Data = new JNodeBuffer(lSize);
NodeJsFsAPI().read(Fd, Data, 0, lSize, lStart,
procedure (Error: JError; BytesRead: integer; buffer: JNodeBuffer)
begin
if Error nil then
begin
NodeJsFsAPI().closeSync(Fd);
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Close the file-handle and return data
NodeJsFsAPI().close(Fd, procedure (Error: JError)
begin
var lResponse := TQTXFileReadPartialResponse.Create(Request.Ticket);
lResponse.UserName := lUserName;
lResponse.Routing.TagValue := request.routing.tagValue;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Only encode data if read
if BytesRead > 0 then
begin
// Convert filedata in one pass
try
var lConvert := TDataTypeConverter.Create();
try
lResponse.Attachment.AppendBytes( lConvert.TypedArrayToBytes(buffer) );
finally
lConvert.free;
end;
except
on e: exception do
begin
WriteToLog(e.message);
SendError(Socket, Request, e.Message);
exit;
end;
end;
end;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end);
end);
end;
procedure TQTXTaskService.HandleFileWrite(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileWriteRequest(request);
var lFileName := lRequest.FileName.trim();
var lUserName := lRequest.UserName.trim();
var FullPath := lFileName;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(nil, lUserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
case Device.&Type of
dtLocal:
begin
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Extract data to be appended, if any
// note: null bytes should be allowed, it should just create the file
var lBytes: array of UInt8;
if lRequest.attachment.Size > 0 then
lBytes := lRequest.Attachment.ToBytes();
// Write the data to the file
NodeJsFsAPI().writeFile(lFullPath, lBytes,
procedure (Error: JError)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Setup response object
var lResponse := TQTXFileWriteResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end;
dtDropbox, dtGoogle, dtMsDrive:
begin
var lErrorText := Format("Clound bindings not active error [%s]", [lRequest.FileName]);
WriteToLog(lErrorText);
SendError(Socket, Request, lErrorText);
end;
end;
end);
end else
begin
SendError(Socket, Request, format("Invalid path [%s] error", [FullPath]));
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleFileWritePartial(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileWritePartialRequest(request);
var lFileName := lRequest.FileName.trim();
var lUserName := lRequest.UserName.trim();
var lFileOffset := lRequest.Offset;
// Check filename length
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var FullPath := lFileName;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(FullPath, lInfo) then
begin
// Locate the device for the path belonging to the user
FindDeviceByName(nil, lUserName, lInfo.MountPart,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
case Device.&Type of
dtLocal:
begin
// We want the path + filename, so we can append that to
// the actual localized filesystem
var lExtract := FullPath;
delete(lExtract, 1, lInfo.MountPart.Length + 1);
// Construct complete storage location
var lFullPath := TQTXNodeFileUtils.GetCurrentDirectory();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + 'userdevices';
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + Device.location.trim();
lFullPath := TQTXNodeFileUtils.IncludeTrailingPathDelimiter(lFullPath) + lExtract;
// Extract data to be appended, if any
// note: null bytes should be allowed, it should just create the file
var lBytes: array of UInt8;
if lRequest.attachment.Size > 0 then
lBytes := lRequest.Attachment.ToBytes();
var lAccess := TQTXNodeFile.Create();
lAccess.Open(lFullPath, TQTXNodeFileMode.nfWrite,
procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
lAccess.Write(lBytes, lFileOffset,
procedure (Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Setup response object
var lResponse := TQTXFileWriteResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end;
dtDropbox, dtGoogle, dtMsDrive:
begin
var lErrorText := Format("Clound bindings not active error [%s]", [lRequest.FileName]);
WriteToLog(lErrorText);
SendError(Socket, Request, lErrorText);
end;
end;
end);
end else
begin
SendError(Socket, Request, format("Invalid path [%s] error", [FullPath]));
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleRmDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXRmDirRequest(request);
var lUserName := lRequest.UserName.trim();
var lDirPath := lRequest.DirPath.trim();
if lDirPath.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lDirPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lParser.Parse(lDirPath, lInfo) then
begin
GetTranslatedPathFor(nil, lUserName, lDirPath,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if not TQTXNodeFileUtils.DirectoryExists(Translated) then
begin
WriteToLogF("RmDir Failed, directory [%s] does not exist", [Translated]);
SendError(Socket, Request, Format("RmDir failed, directory [%s] does not exist", [Original]));
exit;
end;
TQTXNodeFileUtils.DeleteDirectory(nil, Translated,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Setup response object
var lResponse := TQTXRmDirResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.DirPath := lDirPath;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
lResponse.Routing.TagValue := lRequest.Routing.TagValue;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end else
begin
var lText := format("RmDir failed, invalid path [%s] error", [lDirPath]);
WriteToLog(lText);
SendError(Socket, Request, lText);
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleMkDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXMkDirRequest(request);
var lUserName := lRequest.UserName.trim();
var lDirPath := lRequest.DirPath.trim();
if lDirPath.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lDirPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
var lParser := TQTXPathParser.Create();
try
var lInfo: TQTXPathData;
if lparser.Parse(lDirPath, lInfo) then
begin
GetTranslatedPathFor(nil, lUserName, lDirPath,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
TQTXNodeFileUtils.DirectoryExists(nil, Translated,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if Error nil then
begin
WriteToLogF("MkDir Failed, directory [%s] already exists", [Translated]);
SendError(Socket, Request, Format("MkDir Failed, directory [%s] already exists", [Original]));
exit;
end;
TQTXNodeFileUtils.CreateDirectory(nil, Translated,
procedure (TagValue: variant; Path: string; Error: Exception)
begin
if Error nil then
begin
WriteToLogF("MkDir Failed, directory [%s] could not be created", [Original]);
SendError(Socket, Request, Format("MkDir Failed, directory [%s] could not be created", [Translated]));
exit;
end;
// Setup response object
var lResponse := TQTXMkDirResponse.Create(lRequest.Ticket);
lResponse.UserName := lUserName;
lResponse.DirPath := lDirPath;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
lResponse.Routing.TagValue := lRequest.Routing.TagValue;
// Send success response
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end);
end else
begin
var lText := format("MkDir Failed, invalid path [%s] error", [lDirPath]);
WriteToLog(lText);
SendError(Socket, Request, lText);
end;
finally
lParser.free;
end;
end;
procedure TQTXTaskService.HandleFileDelete(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileDeleteRequest(Request);
var lUserName := lRequest.UserName.trim();
var lFileName := lRequest.FileName.trim();
if lFileName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if not Info.isFile then
begin
SendError(Socket, Request, "Filesystem object is not a file error");
exit;
end;
NodeJsFsAPI().unlink(LocalFile,
procedure (Error: JError)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.message);
exit;
end;
var lResponse := new TQTXFileDeleteResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end;
procedure TQTXTaskService.HandleFileRename(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileRenameRequest(Request);
var lUserName := lRequest.UserName.trim();
var lFileName := lRequest.FileName.trim();
var lNewName := lRequest.NewName.trim();
// Check filename length
if lFileName.length < 1 then
begin
SendError(Socket, Request, Format("Invalid or empty from-filename [%s] error", [lFileName]) );
exit;
end;
// check newname length
if lNewName.length 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
if pos(lTemp, lNewName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
if pos(lTemp, lNewName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
if not Info.isFile then
begin
SendError(Socket, Request, "Filesystem object is not a file error");
exit;
end;
GetTranslatedPathFor(nil, lUsername, lNewName,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
NodeJsFsAPI().rename(LocalFile, Translated,
procedure (Error: JError)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.message);
exit;
end;
var lResponse := new TQTXFileRenameResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end);
end);
end;
procedure TQTXTaskService.HandleGetDir(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileDirRequest(Request);
var lUserName := lRequest.UserName.trim();
var lPath := lRequest.Path.trim();
// prevent path escape attempts
var lTemp := "../";
if pos(lTemp, lPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lPath) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetTranslatedPathFor(nil, lUserName, lPath,
procedure (TagValue: variant; Original, Translated: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
//writeln("Translated path is:" + Translated);
if not TQTXNodeFileUtils.DirectoryExists(Translated) then
begin
WriteToLogF("GetDir Failed, directory [%s] does not exist", [Translated]);
SendError(Socket, Request, Format("GetDir failed, directory [%s] does not exist", [Original]));
exit;
end;
var lWalker := TQTXFileWalker.Create();
lWalker.Examine(Translated, procedure (Sender: TQTXFileWalker; Error: EException)
begin
if Error nil then
begin
WriteToLogF("GetDir Failed: %s", [Error.Message]);
SendError(Socket, Request, Format("GetDir failed: %s", [Error.Message]));
exit;
end;
// Get the directory data, swap out the path
// record with the original [amiga] style path
var lData := Sender.ExtractList();
lData.dlPath := Original;
var lResponse := new TQTXFileDirResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.Path := lPath;
lResponse.Assign( lData );
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
// release instance in 100ms
TQTXDispatch.execute(procedure ()
begin
try
lWalker.free
except
on e: exception do
begin
WriteToLogF("Failed to release file-walker instance: %s", [e.message]);
end;
end;
end, 100);
end);
end);
end;
procedure TQTXTaskService.HandleGetFileInfo(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lRequest := TQTXFileInfoRequest(Request);
var lUserName := lRequest.UserName.trim();
var lFileName := lRequest.FileName.trim();
// prevent path escape attempts
var lTemp := "../";
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
lTemp := './';
if pos(lTemp, lFileName) > 0 then
begin
SendError(Socket, Request, Format("Unsupported path sequence [%s] detected error", [lTemp]) );
exit;
end;
GetFileInfo(lRequest, lUserName, lFileName,
procedure (TagValue: variant; LocalFile: string; Info: JStats; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.message);
SendError(Socket, Request, Error.Message);
exit;
end;
// Collect the data
var lData := new JFileItem();
lData.diFileName := lFileName;
lData.diFileType := if Info.isFile then JFileItemType.wtFile else JFileItemType.wtFolder;
lData.diFileSize := Info.size;
lData.diFileMode := IntToStr(Info.mode);
lData.diCreated := TDateUtils.FromJsDate( Info.cTime );
lData.diModified := TDateUtils.FromJsDate( Info.mTime );
var lResponse := new TQTXFileInfoResponse(lRequest.Ticket);
lResponse.Routing.TagValue := request.Routing.TagValue;
lResponse.UserName := lUserName;
lResponse.FileName := lFileName;
lResponse.Assign(lData);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
WriteToLog(e.message);
end;
end);
end;
procedure TQTXTaskService.HandleDestroyDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileDestroyDeviceRequest(request);
// This will also destroy any files + unregister the device in the
// database table for the service -- do not mess with this!
UnRegisterLocalDevice(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; LocalPath: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileDestroyDeviceResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.DeviceName := lMessage.DeviceName;
lResponse.Routing.TagValue := Request.Routing.TagValue;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end;
procedure TQTXTaskService.HandleCreateLocalDevice(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileCreateLocalDeviceRequest(request);
// Attempt to register.
// NOTE: This will automatically create a matching folder
// under $cwd/userdevices/[calculated_name_of_device]
RegisterLocalDevice(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; LocalPath: string; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
FindDeviceByName(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileCreateLocalDeviceResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.Routing.TagValue := Request.Routing.TagValue;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
if Device nil then
lResponse.assign(Device);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end);
end;
procedure TQTXTaskService.HandleGetDeviceByName(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileGetDeviceByNameRequest(request);
FindDeviceByName(nil, lMessage.Username, lMessage.DeviceName,
procedure (TagValue: variant; Device: JDeviceInfo; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileGetDeviceByNameResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
if Device nil then
lResponse.assign(Device);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end;
procedure TQTXTaskService.HandleGetDevices(Socket: TNJWebSocketSocket; Request: TQTXBaseMessage);
begin
var lMessage := TQTXFileGetDeviceListRequest(Request);
GetDevicesForUser(nil, lMessage.Username,
procedure (TagValue: variant; Devices: JDeviceList; Error: Exception)
begin
if Error nil then
begin
WriteToLog(Error.Message);
SendError(Socket, Request, Error.Message);
exit;
end;
var lResponse := TQTXFileGetDeviceListResponse.Create(request.ticket);
lResponse.UserName := lMessage.UserName;
lResponse.Code := CNT_MESSAGE_CODE_OK;
lResponse.Response := CNT_MESSAGE_TEXT_OK;
if Devices nil then
lResponse.assign(Devices);
try
Socket.Send( lResponse.Serialize() );
except
on e: exception do
begin
WriteToLog(e.message);
end;
end;
end);
end;
procedure TQTXTaskService.AfterServerStarted;
begin
inherited;
// Check prefs if zconfig should be applied
if self.FPrefs.ReadBoolean("zconfig", "active", false) then
begin
// ZConfig should only run on the master instance.
// We dont want to register our endpoint for each worker
if NodeJSClusterAPI().isWorker then
exit;
writeln("Setting up Zero-Configuration layer");
FZConfig.port := FPrefs.ReadInteger('zconfig', 'bindport', 2109);
FZConfig.address := GetMachineIP();
FZConfig.Start(nil, procedure (Sender: TObject; TagValue: variant; Error: Exception)
begin
if FPrefs.ReadBoolean("zconfig", "broadcast", true) then
FZConfig.Socket.setBroadcast(true);
// Build up the endpoint (URL) for our websocket server
var lEndpoint := '';
if FPrefs.ReadBoolean('networking', 'secure', false) then
lEndpoint := 'wss://'
else
lEndpoint := 'ws://';
lEndpoint += GetMachineIP();
lEndpoint += ':' + Port.ToString();
// Ping the ZConfig service on interval, until our service is registered
// We keep track of the interval handle so we can stop calling on interval later
FRegHandle := TQTXDispatch.SetInterval( procedure ()
begin
inc(FRegCount);
// Only output once to avoid overkill in the log
if FRegCount = 1 then
WriteToLogF("ZConfig registration begins [%s]", [lEndpoint]);
FZConfig.RegisterService(nil, CNT_ZCONFIG_SERVICE_NAME, SERVICE_ID_TASKMANAGER, lEndpoint,
procedure (TagValue: variant; Error: Exception)
begin
if Error = nil then
begin
WriteToLog("Service registered");
TQTXDispatch.ClearInterval(FRegHandle);
FRegCount := 0;
exit;
end;
end);
end, 1000);
end);
end;
end;
procedure TQTXTaskService.BeforeServerStopped;
begin
inherited;
end;
procedure TQTXTaskService.Dispatch(Socket: TNJWebSocketSocket; Message: TQTXBaseMessage);
begin
var LInfo := MessageDispatch.GetMessageInfoForClass(Message);
if LInfo nil then
begin
try
LInfo.MessageHandler(Socket, Message);
except
on e: exception do
begin
//Log error
WriteToLog(e.message);
end;
end;
end;
end;
end.
Jon L. Aasenden 
“Needless to say, I’ll be porting a fair share of my libraries to C/C++ when I have time (those that makes sense under that paradigme).” – Interesting, why not use freepascal(wasm), remobjects(oxygene), or dwscript ?
It does make me question would emscripten be able to recompile fmx for web ?? (opengl->webgl, c++ -> wasm) being both are clang/llvm based ?
Looking forward to future articles.
Compiling to wasm is not really the hard part. Its a completely different underlying ecosystem. A large part of the FMX RTL would have to be re-written. WASM is completely barren, there are no standard functions or anything like that — you have to call out into the DOM context to get output etc. So its not just a matter of compiling to WASM, but having an RTL that provides the same features there.
I code in DWScript/QTX for web stuff. I have spent years making a solid system, so i have no need for FPC for example. And clang for hardcore WASM — the stdlib has been adapted for that