2447 lines
85 KiB
ObjectPascal
2447 lines
85 KiB
ObjectPascal
/// shared DDD Infrastructure: Application/Daemon implementation classes
|
|
// - this unit is a part of the freeware Synopse mORMot framework,
|
|
// licensed under a MPL/GPL/LGPL tri-license; version 1.18
|
|
unit dddInfraApps;
|
|
|
|
{
|
|
This file is part of Synopse mORMot framework.
|
|
|
|
Synopse mORMot framework. Copyright (C) 2022 Arnaud Bouchez
|
|
Synopse Informatique - https://synopse.info
|
|
|
|
*** BEGIN LICENSE BLOCK *****
|
|
Version: MPL 1.1/GPL 2.0/LGPL 2.1
|
|
|
|
The contents of this file are subject to the Mozilla Public License Version
|
|
1.1 (the "License"); you may not use this file except in compliance with
|
|
the License. You may obtain a copy of the License at
|
|
http://www.mozilla.org/MPL
|
|
|
|
Software distributed under the License is distributed on an "AS IS" basis,
|
|
WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
|
|
for the specific language governing rights and limitations under the License.
|
|
|
|
The Original Code is Synopse mORMot framework.
|
|
|
|
The Initial Developer of the Original Code is Arnaud Bouchez.
|
|
|
|
Portions created by the Initial Developer are Copyright (C) 2022
|
|
the Initial Developer. All Rights Reserved.
|
|
|
|
Contributor(s):
|
|
|
|
|
|
Alternatively, the contents of this file may be used under the terms of
|
|
either the GNU General Public License Version 2 or later (the "GPL"), or
|
|
the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
|
|
in which case the provisions of the GPL or the LGPL are applicable instead
|
|
of those above. If you wish to allow use of your version of this file only
|
|
under the terms of either the GPL or the LGPL, and not to allow others to
|
|
use your version of this file under the terms of the MPL, indicate your
|
|
decision by deleting the provisions above and replace them with the notice
|
|
and other provisions required by the GPL or the LGPL. If you do not delete
|
|
the provisions above, a recipient may use your version of this file under
|
|
the terms of any one of the MPL, the GPL or the LGPL.
|
|
|
|
***** END LICENSE BLOCK *****
|
|
|
|
TODO:
|
|
- store settings in database, or a centralized service?
|
|
- allow to handle authentication via a centralized service or REST server
|
|
|
|
}
|
|
|
|
{$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER
|
|
|
|
interface
|
|
|
|
uses
|
|
{$ifdef MSWINDOWS}
|
|
Windows,
|
|
{$else}
|
|
{$ifdef FPC}
|
|
SynFPCLinux,
|
|
{$endif}
|
|
{$endif}
|
|
mORMotService, // for running the daemon as a regular Windows Service
|
|
SysUtils,
|
|
Classes,
|
|
Variants,
|
|
SynCommons,
|
|
SynTable,
|
|
SynLog,
|
|
SynCrypto,
|
|
SynEcc,
|
|
mORMot,
|
|
mORMotDDD,
|
|
dddInfraSettings,
|
|
SynCrtSock,
|
|
SynBidirSock,
|
|
mORMotHttpServer, // for publishing a TSQLRestServer over HTTP
|
|
mORMotHttpClient; // for publishing a TSQLRestClientURI over HTTP
|
|
|
|
|
|
{ ----- Implements Service/Daemon Applications }
|
|
|
|
type
|
|
/// abstract class to handle any kind of service/daemon executable
|
|
// - would implement either a Windows Service, a stand-alone remotely
|
|
// administrated daemon, or a console application, according to the command line
|
|
// - you should inherit from this class, then override the abstract NewDaemon
|
|
// protected method to launch and return a IAdministratedDaemon instance
|
|
{$M+}
|
|
|
|
{ TDDDDaemon }
|
|
|
|
TDDDDaemon = class
|
|
protected
|
|
fSettings: TDDDAdministratedDaemonSettings;
|
|
fSettingsRef: IUnknown;
|
|
/// the service/daemon will be stopped when this interface is set to nil
|
|
fDaemon: IAdministratedDaemon;
|
|
/// this abstract method should be overriden to return a new service/daemon
|
|
// instance, using the (inherited) fSettings as parameters
|
|
function NewDaemon: TDDDAdministratedDaemon; virtual;
|
|
/// returns some text to be supplied to the console for /help - '' by default
|
|
function CustomHelp: string; virtual;
|
|
procedure DoStart{$ifdef MSWINDOWS}(Sender: TService=nil){$endif};
|
|
procedure DoStop{$ifdef MSWINDOWS}(Sender: TService=nil){$endif};
|
|
public
|
|
/// initialize the service/daemon application thanks to some information
|
|
// - actual settings would inherit from TDDDAdministratedDaemonSettingsFile,
|
|
// to define much more parameters, according to the service/daemon process
|
|
// - the supplied settings will be owned by this TDDDDaemon instance
|
|
constructor Create(aSettings: TDDDAdministratedDaemonSettings); virtual;
|
|
/// finalize the service/daemon application, and release its resources
|
|
destructor Destroy; override;
|
|
/// interpret the command line to run the application as expected
|
|
// - under Windows, /install /uninstall /start /stop would control the
|
|
// daemon as a Windows Service - you should run the program with
|
|
// administrator rights to be able to change the Services settings
|
|
// - /console or /c would run the program as a console application
|
|
// - /verbose would run the program as a console application, in verbose mode
|
|
// - /daemon or /d would run the program as a remotely administrated
|
|
// daemon, using a published IAdministratedDaemon service
|
|
// - /version would show the current revision information of the application
|
|
// - no command line argument will run the program as a Service dispatcher
|
|
// under Windows (as a regular service), or display the syntax - or would
|
|
// run the service in /verbose mode if ForceRun is TRUE (may be useful e.g.
|
|
// to debug an associated .dll using this daemon as host application)
|
|
// - any invalid switch, or no switch under Linux, will display the syntax
|
|
// - this method will output any error or information to the console
|
|
// - as a result, a project .dpr could look like the following:
|
|
//!begin
|
|
//! with TMyApplicationDaemon.Create(TMyApplicationDaemonSettings.Create) do
|
|
//! try
|
|
//! ExecuteCommandLine;
|
|
//! finally
|
|
//! Free;
|
|
//! end;
|
|
//!end.
|
|
procedure ExecuteCommandLine(ForceRun: boolean=false);
|
|
/// start the daemon, until the instance is released
|
|
procedure Execute;
|
|
/// wait for Daemon property to be set
|
|
// - Execute method should have been previously caleld
|
|
// - returns true if the daemon has been started in the specified time
|
|
function WaitStarted(TimeoutMS: integer=10000): boolean;
|
|
/// start the daemon and wait for Daemon property to be set
|
|
// - returns true if the daemon has been started in the specified time
|
|
function ExecuteAndWaitStarted(TimeoutMS: integer=10000): boolean;
|
|
/// read-only access to the underlying daemon instance
|
|
// - equals nil if the daemon is not started
|
|
property Daemon: IAdministratedDaemon read fDaemon;
|
|
/// returns the class instance implementing the underlying Daemon
|
|
// - you should transtype the returned instance using e.g.
|
|
// ! myDaemon := mainDaemon.DaemonInstance as TMyDaemonClass;
|
|
function DaemonInstance: TObject;
|
|
published
|
|
end;
|
|
{$M-}
|
|
|
|
/// abstract class to implement a IAdministratedDaemon service via a TThread
|
|
// - as hosted by TDDDDaemon service/daemon application
|
|
TDDDThreadDaemon = class(TDDDAdministratedThreadDaemon)
|
|
protected
|
|
// returns the system memory info as current state
|
|
function InternalRetrieveState(var Status: variant): boolean; override;
|
|
function GetAdministrationHTTPServer: TSQLHttpServer;
|
|
{$ifdef HASINLINE}inline;{$endif}
|
|
public
|
|
/// IAdministratedDaemon command to subscribe to a set of events for
|
|
// real-time remote monitoring of the specified log events
|
|
// - this overriden method would disallow remote logs if low-level frames
|
|
// logging is set (i.e. HttpClientFullWebSocketsLog / HttpServerFullWebSocketsLog)
|
|
// to avoid an unexpected race condition
|
|
procedure SubscribeLog(const Levels: TSynLogInfos; const Callback: ISynLogCallback;
|
|
ReceiveExistingKB: cardinal); override;
|
|
/// reference to the HTTP server publishing IAdministratedDaemon service
|
|
// - may equal nil if TDDDAdministratedDaemonSettingsFile.AuthHttp.BindPort=''
|
|
property AdministrationHTTPServer: TSQLHttpServer read GetAdministrationHTTPServer;
|
|
end;
|
|
|
|
/// abstract class to implement a IAdministratedDaemon service via a TSQLRestServer
|
|
// - as hosted by TDDDDaemon service/daemon application
|
|
TDDDRestDaemon = class(TDDDAdministratedRestDaemon, IAdministratedDaemon)
|
|
protected
|
|
fPreviousMonitorTix: Int64;
|
|
function GetAdministrationHTTPServer: TSQLHttpServer;
|
|
{$ifdef HASINLINE}inline;{$endif}
|
|
// returns the current state from fRest.Stat() + system memory
|
|
function InternalRetrieveState(var Status: variant): boolean; override;
|
|
procedure InternalLogMonitoring; virtual;
|
|
public
|
|
/// IAdministratedDaemon command to subscribe to a set of events for
|
|
// real-time remote monitoring of the specified log events
|
|
// - this overriden method would disallow remote logs if low-level frames
|
|
// logging is set (i.e. HttpClientFullWebSocketsLog / HttpServerFullWebSocketsLog)
|
|
// to avoid an unexpected race condition
|
|
procedure SubscribeLog(const Levels: TSynLogInfos; const Callback: ISynLogCallback;
|
|
ReceiveExistingKB: cardinal); override;
|
|
/// reference to the HTTP server publishing IAdministratedDaemon service
|
|
// - may equal nil if TDDDAdministratedDaemonSettingsFile.AuthHttp.BindPort=''
|
|
property AdministrationHTTPServer: TSQLHttpServer read GetAdministrationHTTPServer;
|
|
end;
|
|
|
|
/// abstract class to implement a IAdministratedDaemon service via a
|
|
// TSQLRestServer, publishing its services as HTTP
|
|
// - as hosted by TDDDDaemon service/daemon application
|
|
TDDDRestHttpDaemon = class(TDDDRestDaemon)
|
|
protected
|
|
fHttpServer: TSQLHttpServer;
|
|
fServicesLogRest: TSQLRest;
|
|
function Settings: TDDDAdministratedDaemonHttpSettings;
|
|
{$ifdef HASINLINE}inline;{$endif}
|
|
// initialize HTTP Server into fHttpServer
|
|
// (fRest should have been set by the overriden method)
|
|
procedure InternalStart; override;
|
|
// finalize HTTP Server and SOA log database
|
|
procedure InternalStop; override;
|
|
public
|
|
/// generate API documentation corresponding to REST SOA interfaces
|
|
procedure WrapperGenerate(const DestFile: TFileName;
|
|
const Template: TFileName = 'API.adoc.mustache');
|
|
/// reference to the main HTTP server publishing this daemon Services
|
|
// - may be nil outside a Start..Stop range
|
|
property HttpServer: TSQLHttpServer read fHttpServer;
|
|
/// reference to the associated REST server storing the SOA log database
|
|
// - may be nil if the daemon did not implement this feature
|
|
property ServicesLogRest: TSQLRest read fServicesLogRest;
|
|
end;
|
|
|
|
|
|
{ ----- Implements ORM/SOA REST Client access }
|
|
|
|
type
|
|
/// exception raised by TDDDRestClientSettings classes
|
|
EDDDRestClient = class(EDDDException);
|
|
|
|
/// advanced parameters for TDDDRestClientSettings definition
|
|
TDDDRestClientDefinition = class(TSynPersistentWithPassword)
|
|
protected
|
|
fRoot: RawUTF8;
|
|
fConnectRetrySeconds: integer;
|
|
published
|
|
/// the URI Root to be used for the REST Model
|
|
property Root: RawUTF8 read fRoot write fRoot;
|
|
/// the encrypted password to be used to connect with WebSockets
|
|
property WebSocketsPassword: RawUTF8 read fPassWord write fPassWord;
|
|
/// how many seconds the client may try to connect after open socket failure
|
|
property ConnectRetrySeconds: integer read fConnectRetrySeconds write fConnectRetrySeconds;
|
|
end;
|
|
|
|
/// storage class for initializing an ORM/SOA REST Client class
|
|
// - this class will contain some generic properties to initialize a
|
|
// TSQLRestClientURI pointing to a remote server, using WebSockets by default
|
|
// - WebSockets support is the reason why this class is defined in
|
|
// dddInfraApps, and not dddInfraSettings
|
|
TDDDRestClientSettings = class(TSynAutoCreateFields)
|
|
protected
|
|
fORM: TSynConnectionDefinition;
|
|
fClient: TDDDRestClientDefinition;
|
|
fTimeout, fWebSocketsLoopDelay: integer;
|
|
public
|
|
/// set the default values for Client.Root, ORM.ServerName,
|
|
// Client.WebSocketsPassword and ORM.Password
|
|
procedure SetDefaults(const Root, Port, WebSocketPassword, UserPassword: RawUTF8;
|
|
const User: RawUTF8 = 'User'; const Server: RawUTF8 = 'localhost';
|
|
ForceSetCredentials: boolean = false; ConnectRetrySeconds: integer = 0;
|
|
WebSocketsLoopDelayMS: integer = 0);
|
|
/// is able to instantiate a Client REST instance for the stored definition
|
|
// - Definition.Kind is expected to specify a TSQLRestClient class to be
|
|
// instantiated, not a TSQLRestServer instance
|
|
// - will return nil if the supplied Definition is not correct
|
|
// - note that the supplied Model.Root is expected to be the default root
|
|
// URI, which will be overriden with this TDDDRestSettings.Root property
|
|
// - will also set the TSQLRest.LogFamily.Level from LogLevels value,
|
|
function NewRestClientInstance(aRootSettings: TDDDAppSettingsAbstract;
|
|
aModel: TSQLModel = nil; aOptions: TDDDNewRestInstanceOptions = [riOwnModel,
|
|
riCreateVoidModelIfNone, riHandleAuthentication, riRaiseExceptionIfNoRest]): TSQLRestClientURI; virtual;
|
|
/// you may assign this method to a TSQLRestClientURI.OnAuthentificationFailed
|
|
// property, so that the client would automatically try to re-connect
|
|
function OnAuthentificationFailed(Retry: integer; var aUserName, aPassword: string;
|
|
out aPasswordHashed: boolean): boolean;
|
|
/// you can overload here the TCP timeout delay, in seconds
|
|
property Timeout: integer read fTimeout write fTimeout;
|
|
/// you can overload here the WebSockets internal loop delay, in milliseconds
|
|
property WebSocketsLoopDelay: integer read fWebSocketsLoopDelay write fWebSocketsLoopDelay;
|
|
published
|
|
/// defines a mean of access to a TSQLRest instance
|
|
// - using Kind/ServerName/DatabaseName/User/Password properties: Kind
|
|
// would define the TSQLRest class to be instantiated by NewRestClientInstance()
|
|
property ORM: TSynConnectionDefinition read fORM;
|
|
/// advanced connection options
|
|
// - ORM.Password defines the authentication main password, and
|
|
// Client.WebSocketsPassword is used for WebSockets binary encryption
|
|
property Client: TDDDRestClientDefinition read fClient;
|
|
end;
|
|
|
|
/// abstract client to connect to any daemon service via WebSockets
|
|
// - will monitor the connection, to allow automatic reconnection, with proper
|
|
// services resubscription
|
|
TDDDRestClientWebSockets = class(TSQLHttpClientWebsockets)
|
|
protected
|
|
fApplicationName: RawUTF8;
|
|
fOwnedSettings: TDDDRestClientSettings;
|
|
fConnected: boolean;
|
|
fServicesRegistered: boolean;
|
|
fOnConnect, fOnDisconnect: TOnRestClientNotify;
|
|
// called after connection, before fOnConnect event - to register callbacks
|
|
procedure AfterConnection; virtual;
|
|
// called after disconnection, before fOnDisconnect event - unregister callbacks
|
|
procedure AfterDisconnection; virtual;
|
|
// call ClientDisconnect if HTTP_NOTIMPLEMENTED (i.e. websocket link broken)
|
|
procedure ClientFailed(Sender: TSQLRestClientURI; E: Exception;
|
|
Call: PSQLRestURIParams); virtual;
|
|
// notify AfterDisconnection + fOnDisconnect if needed
|
|
procedure ClientDisconnect;
|
|
procedure WebSocketsClosed(Sender: TObject); virtual;
|
|
// notify AfterDisconnection+fOnDisconnect if needed, then AfterConnection+fOnConnect
|
|
procedure ClientSetUser(Sender: TSQLRestClientURI); virtual;
|
|
// inherited classes should override those abstract methods
|
|
procedure DefineApplication; virtual; abstract;
|
|
procedure RegisterServices; virtual; abstract;
|
|
function CreateModel(aSettings: TDDDRestClientSettings): TSQLModel; virtual;
|
|
public
|
|
/// initialize the client instance with the supplied settings
|
|
constructor Create(aSettings: TDDDRestClientSettings;
|
|
aOnConnect: TOnRestClientNotify = nil;
|
|
aOnDisconnect: TOnRestClientNotify = nil); reintroduce; overload; virtual;
|
|
/// finalize the client instance
|
|
destructor Destroy; override;
|
|
/// returns the server version, using timestamp/info method-based service
|
|
property ApplicationVersion: RawUTF8 read GetSessionVersion;
|
|
/// reflects the current WebSockets connection state
|
|
property Connected: boolean read fConnected;
|
|
/// human-friendly application name, as set by overriden DefineApplication
|
|
property ApplicationName: RawUTF8 read fApplicationName;
|
|
end;
|
|
|
|
/// abstract client to connect to any daemon service via HTTP or HTTPS
|
|
// - defines a simple REST client, without connection tracking
|
|
TDDDRestClientHttp = class(TSQLHttpsClient)
|
|
protected
|
|
fApplicationName: RawUTF8;
|
|
// inherited classes should override those abstract methods
|
|
procedure DefineApplication; virtual; abstract;
|
|
procedure RegisterServices; virtual; abstract;
|
|
public
|
|
/// returns the server version, using timestamp/info method-based service
|
|
property ApplicationVersion: RawUTF8 read GetSessionVersion;
|
|
/// human-friendly application name, as set by overriden DefineApplication
|
|
property ApplicationName: RawUTF8 read fApplicationName;
|
|
end;
|
|
|
|
/// create a client safe asynchronous connection to a IAdministratedDaemon service
|
|
function AdministratedDaemonClient(Definition: TDDDRestClientSettings;
|
|
Model: TSQLModel = nil): TSQLHttpClientWebsockets;
|
|
|
|
{
|
|
/// create a client safe asynchronous connection to a IAdministratedDaemon service
|
|
// via a IAdministratedDaemonProxy service
|
|
function AdministratedDaemonClientFromProxy(Definition: TDDDRestClientSettings;
|
|
const ProxyIPPort: RawUTF8; Model: TSQLModel = nil): IAdministratedDaemon;
|
|
}
|
|
|
|
/// create a WebSockets server instance, publishing a IAdministratedDaemon service
|
|
function AdministratedDaemonServer(Settings: TDDDAdministratedDaemonSettings;
|
|
DaemonClass: TDDDAdministratedDaemonClass): TDDDAdministratedDaemon;
|
|
|
|
|
|
{ ----- Implements Thread Processing to access a TCP server }
|
|
|
|
type
|
|
TDDDSocketThread = class;
|
|
|
|
/// the current connection state of the TCP client associated to a
|
|
// TDDDSocketThread thread
|
|
TDDDSocketThreadState = (tpsDisconnected, tpsConnecting, tpsConnected);
|
|
|
|
/// the monitoring information of a TDDDSocketThread thread
|
|
TDDDSocketThreadMonitoring = class(TDDDAdministratedDaemonMonitor)
|
|
protected
|
|
fState: TDDDSocketThreadState;
|
|
fOwner: TObject;
|
|
function GetSocket: variant;
|
|
public
|
|
/// may be a TDDDSocketThread instance, or not (to maintain a global state
|
|
// over several threads)
|
|
property Owner: TObject read fOwner write fOwner;
|
|
published
|
|
/// how this thread is currently connected to its associated TCP server
|
|
property State: TDDDSocketThreadState read fState write fState;
|
|
/// information about the associated socket
|
|
property Socket: variant read GetSocket;
|
|
end;
|
|
|
|
/// interface allowing to customize/mock a socket connection
|
|
IDDDSocket = interface
|
|
/// connect to the host via the (mocked) socket
|
|
// - should raise an exception on error
|
|
procedure Connect;
|
|
/// returns instance identifier
|
|
// - e.g. the TCrtSocket.Sock number as text
|
|
function Identifier: RawUTF8;
|
|
/// get some low-level information about the last occurred error
|
|
// - e.g. TCrtSocket.LastLowSocketError value
|
|
function LastError: RawUTF8;
|
|
/// returns the number of bytes pending in the (mocked) socket
|
|
// - call e.g. TCrtSocket.SockInPending() with aSocketForceCheck=true,
|
|
// to return bytes both in the instance memory buffer and the socket API
|
|
function DataInPending(aTimeOut: integer): integer;
|
|
/// get Length bytes from the (mocked) socket
|
|
// - returns the number of bytes read into the Content buffer
|
|
// - call e.g. TCrtSocket.SockInRead() method
|
|
function DataIn(Content: PAnsiChar; ContentLength: integer): integer;
|
|
/// send Length bytes to the (mocked) socket
|
|
// - returns false on any error, true on success
|
|
// - call e.g. TCrtSocket.TrySndLow() method
|
|
function DataOut(Content: PAnsiChar; ContentLength: integer): boolean;
|
|
/// returns the low-level handle of this connection
|
|
// - is e.g. the socket file description
|
|
function Handle: integer;
|
|
end;
|
|
|
|
/// implements IDDDSocket using a SynCrtSock.TCrtSocket instance
|
|
// - used e.g. by TDDDSocketThread for its default network communication
|
|
// - this class will also create two mutexes, one for DataIn/DataInPending,
|
|
// another for DataOut thread-safe process
|
|
TDDDSynCrtSocket = class(TInterfacedObjectLocked, IDDDSocket)
|
|
protected
|
|
fSocket: TCrtSocket;
|
|
fOwner: TThread;
|
|
fHost, fPort: SockString;
|
|
fInternalBufferSize: integer;
|
|
fOutput: TSynLocker; // input lock is TInterfacedObjectLocked.Safe
|
|
public
|
|
/// initialize the internal TCrtSocket instance
|
|
constructor Create(aOwner: TThread; const aHost, aPort: SockString;
|
|
aSocketTimeout, aInternalBufferSize: integer); reintroduce; virtual;
|
|
/// finalize the internal TCrtSocket instance
|
|
destructor Destroy; override;
|
|
/// call TCrtSocket.OpenBind
|
|
procedure Connect;
|
|
/// returns TCrtSocket.Sock number as text
|
|
function Identifier: RawUTF8;
|
|
/// get information from TCrtSocket.LastLowSocketError
|
|
function LastError: RawUTF8;
|
|
/// call TCrtSocket.SockInPending() method
|
|
// - with aSocketForceCheck=true, to return bytes both in the instance
|
|
// memory buffer and the socket API
|
|
function DataInPending(aTimeOut: integer): integer;
|
|
/// call TCrtSocket.SockInRead() method
|
|
function DataIn(Content: PAnsiChar; ContentLength: integer): integer;
|
|
/// call TCrtSocket.TrySndLow() method
|
|
function DataOut(Content: PAnsiChar; ContentLength: integer): boolean;
|
|
/// returns TCrtsocket.Sock
|
|
function Handle: integer;
|
|
/// read-only access to the associated processing thread
|
|
// - not published, to avoid stack overflow since TDDDSocketThreadMonitoring
|
|
// would point to this instance
|
|
property Owner: TThread read fOwner;
|
|
published
|
|
/// read-only access to the associated processing socket
|
|
property Socket: TCrtSocket read fSocket;
|
|
end;
|
|
|
|
/// defines the potential mocked actions for TDDDMockedSocket.MockException()
|
|
TDDDMockedSocketException = (msaConnectRaiseException, msaDataInPendingTimeout,
|
|
msaDataInPendingFails, msaDataInRaiseException, msaDataOutRaiseException,
|
|
msaDataOutReturnsFalse);
|
|
|
|
/// defines a set of mocked actions for TDDDMockedSocket.MockException()
|
|
TDDDMockedSocketExceptions = set of TDDDMockedSocketException;
|
|
|
|
/// defines the potential mocked actions for TDDDMockedSocket.MockLatency()
|
|
TDDDMockedSocketLatency = (mslConnect, mslDataIn, mslDataOut);
|
|
|
|
/// defines a set of mocked actions for TDDDMockedSocket.MockLatency()
|
|
TDDDMockedSocketLatencies = set of TDDDMockedSocketLatency;
|
|
|
|
/// the default exception class raised by TDDDMockedSocket
|
|
EDDDMockedSocket = class(EDDDInfraException);
|
|
|
|
/// implements IDDDSocket using a fake/mocked in-memory input/ouput storage
|
|
// - may be supplied to TDDDSocketThread to bypass its default network communication
|
|
// - you could fake input/output of TCP/IP packets by calling MockDataIn() and
|
|
// MockDataOut() methods - incoming and outgoing packets would be merged in
|
|
// the internal in-memory buffers, as with a regular Socket
|
|
// - you could fake exception, for any upcoming method call, via MockException()
|
|
// - you could emulate network latency, for any upcoming method call, via
|
|
// MockLatency() - to emulate remote/wireless access, or thread pool contention
|
|
// - this implementation is thread-safe, so multiple threads could access
|
|
// the same IDDDSocket instance, and settings be changed in real time
|
|
TDDDMockedSocket = class(TInterfacedObjectLocked, IDDDSocket)
|
|
protected
|
|
fInput, fOutput: RawByteString;
|
|
fExceptionActions: TDDDMockedSocketExceptions;
|
|
fExceptionMessage: string;
|
|
fExceptionClass: ExceptClass;
|
|
fLatencyActions: TDDDMockedSocketLatencies;
|
|
fLatencyMS: integer;
|
|
fOwner: TThread;
|
|
function GetPendingInBytes: integer;
|
|
function GetPendingOutBytes: integer;
|
|
procedure CheckLatency(Action: TDDDMockedSocketLatency);
|
|
procedure CheckRaiseException(Action: TDDDMockedSocketException);
|
|
public
|
|
/// initialize the mocked socket instance
|
|
constructor Create(aOwner: TThread); reintroduce; virtual;
|
|
/// add some bytes to the internal fake input storage
|
|
// - would be made accessible to the DataInPending/DataIn methods
|
|
// - the supplied buffer would be gathered to any previous MockDataIn()
|
|
// call, which has not been read yet by the DataIn() method
|
|
procedure MockDataIn(const Content: RawByteString);
|
|
/// return the bytes from the internal fake output storage
|
|
// - as has be previously set by the DataOut() method
|
|
// - will gather all data from several DataOut() calls in a single buffer
|
|
function MockDataOut: RawByteString;
|
|
/// the specified methods would raise an exception
|
|
// - only a single registration is memorized: once raised, any further
|
|
// method execution would continue as usual
|
|
// - optional Exception.Message which should be raised with the exception
|
|
// - also optional exception class instead of default EDDDMockedSocket
|
|
// - msaDataOutReturnsFalse won't raise any exception, but let DataOut
|
|
// method return false (which is the normal way of indicating a socket
|
|
// error) - in this case, ExceptionMessage would be available from LastError
|
|
// - msaDataInPendingTimeout won't raise any exception, but let DataInPending
|
|
// sleep for the timeout period, and return 0
|
|
// - msaDataInPendingFails won't raise any exception, but let DataInPending
|
|
// fails immediately, and return -1 (emulating a broken socket)
|
|
// - you may use ALL_DDDMOCKED_EXCEPTIONS to set all possible actions
|
|
// - you could reset any previous registered exception by calling
|
|
// ! MockException([]);
|
|
procedure MockException(NextActions: TDDDMockedSocketExceptions;
|
|
const ExceptionMessage: string = ''; ExceptionClass: ExceptClass = nil);
|
|
/// will let the specified methods to wait for a given number of milliseconds
|
|
// - allow to emulate network latency, on purpose
|
|
// - you may use ALL_DDDMOCKED_LATENCIES to slow down all possible actions
|
|
procedure MockLatency(NextActions: TDDDMockedSocketLatencies; MilliSeconds: integer);
|
|
public
|
|
/// IDDDSocket method to connect to the host via the mocked socket
|
|
// - won't raise any exception unless ConnectShouldCheckRaiseException is set
|
|
procedure Connect;
|
|
/// IDDDSocket method to return a fake instance identifier
|
|
// - in fact, the hexa pointer of the TDDDMockedSocket instance
|
|
function Identifier: RawUTF8;
|
|
/// IDDDSocket method to get some low-level information about the last error
|
|
// - i.e. the latest ExceptionMessage value as set by MockException()
|
|
function LastError: RawUTF8;
|
|
/// IDDDSocket method to return the number of bytes pending
|
|
// - note that the total length of all pending data is returned as once,
|
|
// i.e. all previous calls to MockDataIn() would be sum as a single count
|
|
// - this method will emulate blocking process, just like a regular socket:
|
|
// if there is no pending data, it will wait up to aTimeOut milliseconds
|
|
function DataInPending(aTimeOut: integer): integer;
|
|
/// IDDDSocket method to get Length bytes from the mocked socket
|
|
// - returns the number of bytes read into the Content buffer
|
|
// - note that all pending data is returned as once, i.e. all previous
|
|
// calls to MockDataIn() would be gathered in a single buffer
|
|
function DataIn(Content: PAnsiChar; ContentLength: integer): integer;
|
|
/// IDDDSocket method to send Length bytes to the mocked socket
|
|
// - returns false on any error, true on success
|
|
// - then MockDataOut could be used to retrieve the sent data
|
|
function DataOut(Content: PAnsiChar; ContentLength: integer): boolean;
|
|
/// returns 0 (no associated file descriptor)
|
|
function Handle: integer;
|
|
/// read-only access to the associated processing thread
|
|
// - not published, to avoid stack overflow since TDDDSocketThreadMonitoring
|
|
// would point to this instance
|
|
property Owner: TThread read fOwner;
|
|
published
|
|
/// how many bytes are actually in the internal input buffer
|
|
property PendingInBytes: integer read GetPendingInBytes;
|
|
/// how many bytes are actually in the internal output buffer
|
|
property PendingOutBytes: integer read GetPendingOutBytes;
|
|
end;
|
|
|
|
/// a generic TThread able to connect and reconnect to a TCP server
|
|
// - initialize and own a TCrtSocket instance for TCP transmission
|
|
// - allow automatic reconnection
|
|
// - inherit from TSQLRestThread, so should be associated with a REST instance
|
|
TDDDSocketThread = class(TSQLRestThread)
|
|
protected
|
|
fSettings: TDDDSocketThreadSettings;
|
|
fMonitoring: TDDDSocketThreadMonitoring;
|
|
fPreviousMonitorTix: Int64;
|
|
fSocket: IDDDSocket;
|
|
fPerformConnection: boolean;
|
|
fHost, fPort: SockString;
|
|
fSocketInputBuffer: RawByteString;
|
|
fShouldDisconnect: boolean;
|
|
fSocketDisable: boolean;
|
|
procedure InternalExecute; override;
|
|
procedure ExecuteConnect;
|
|
procedure ExecuteDisconnect;
|
|
procedure ExecuteDisconnectAfterError;
|
|
procedure ExecuteSocket;
|
|
function TrySend(const aFrame: RawByteString;
|
|
ImmediateDisconnectAfterError: boolean = true): Boolean; virtual;
|
|
// inherited classes could override those methods for process customization
|
|
procedure InternalExecuteConnected; virtual;
|
|
procedure InternalExecuteDisconnect; virtual;
|
|
procedure InternalExecuteIdle; virtual;
|
|
procedure InternalExecuteSocket; virtual; abstract; // process FSocketInputBuffer
|
|
procedure InternalLogMonitoring; virtual;
|
|
public
|
|
/// initialize the thread for a given REST instance
|
|
constructor Create(aSettings: TDDDSocketThreadSettings; aRest: TSQLRest;
|
|
aMonitoring: TDDDSocketThreadMonitoring);
|
|
/// finalize the thread process, and its associted REST instance
|
|
destructor Destroy; override;
|
|
/// returns the Monitoring and Rest statistics as a JSON object
|
|
// - resulting format is
|
|
// $ {...MonitoringProperties...,"Rest":{...RestStats...}}
|
|
function StatsAsJson: RawUTF8;
|
|
/// will pause any communication with the associated socket
|
|
// - could be used before stopping the service for cleaner shutdown
|
|
procedure Shutdown(andTerminate: boolean); virtual;
|
|
/// the parameters used to setup this thread process
|
|
property Settings: TDDDSocketThreadSettings read fSettings;
|
|
published
|
|
/// the IP Host name used to connect with TCP
|
|
property Host: SockString read fHost;
|
|
/// the IP Port value used to connect with TCP
|
|
property Port: SockString read fPort;
|
|
end;
|
|
|
|
const
|
|
/// map realistic exceptions steps for a mocked socket
|
|
// - could be used to simulate a global socket connection drop
|
|
ALL_DDDMOCKED_EXCEPTIONS = [msaConnectRaiseException, msaDataInPendingFails,
|
|
msaDataInRaiseException, msaDataOutReturnsFalse];
|
|
|
|
/// map realistic latencies steps for a mocked socket
|
|
// - could be used to simulate a slow network
|
|
ALL_DDDMOCKED_LATENCIES = [Low(TDDDMockedSocketLatency)..high(TDDDMockedSocketLatency)];
|
|
|
|
/// a Mustache template of a .rc version information
|
|
// - could be used to compile a custom .res version file in an automated way
|
|
// - if you use this generated .res, ensure your "Version Info" is disabled
|
|
// (unchecked) in the Delphi IDE project options
|
|
EXEVERSION_RCTEMPLATE: RawUTF8 =
|
|
'1 VERSIONINFO'#13#10 +
|
|
'FILEVERSION {{maj}},{{min}},{{rel}},{{build}}'#13#10 +
|
|
'PRODUCTVERSION {{maj}},{{min}},{{rel}},{{build}}'#13#10 +
|
|
'FILEOS 0x4'#13#10 +
|
|
'FILETYPE 0x1'#13#10 +
|
|
'{'#13#10 +
|
|
'BLOCK "StringFileInfo"'#13#10 +
|
|
'{'#13#10 +
|
|
' BLOCK "040904E4"'#13#10 +
|
|
' {'#13#10 +
|
|
' VALUE "CompanyName", "{{compname}}\0"'#13#10 +
|
|
' VALUE "FileDescription", "{{compname}}, {{product}} {{name}}{{#isDaemon}} Daemon{{/isDaemon}}\0"'#13#10 +
|
|
' VALUE "FileVersion", "{{maj}}.{{min}}.{{rel}}.{{build}}\0"'#13#10 +
|
|
' VALUE "InternalName", "{{name}}\0"'#13#10 +
|
|
' VALUE "LegalCopyright", "(c){{year}} {{compname}}\0"'#13#10 +
|
|
' VALUE "LegalTrademarks", "All rights reserved to {{compname}}\0"'#13#10 +
|
|
' VALUE "OriginalFilename", "{{name}}\0"'#13#10 +
|
|
' VALUE "ProductName", "{{product}} {{name}}\0"'#13#10 +
|
|
' VALUE "ProductVersion", "{{maj}}.{{min}}.{{rel}}.{{build}}\0"'#13#10 +
|
|
' }'#13#10 +
|
|
'}'#13#10 +
|
|
#13#10 +
|
|
'BLOCK "VarFileInfo"'#13#10 +
|
|
'{'#13#10 +
|
|
' VALUE "Translation", 0x0409 0x04E4'#13#10 +
|
|
'}'#13#10 +
|
|
'}';
|
|
|
|
var
|
|
/// you could set a text to this global variable at runtime, so that
|
|
// it would be displayed as copyright older name for the console
|
|
GlobalCopyright: string = '';
|
|
|
|
function ToText(st: TDDDSocketThreadState): PShortString; overload;
|
|
function ToText(exc: TDDDMockedSocketException): PShortString; overload;
|
|
|
|
|
|
{ ----- Applications Securization }
|
|
|
|
type
|
|
/// result codes of the ECCAuthorize() function
|
|
TECCAuthorize = (eaSuccess, eaInvalidSecret, eaMissingUnlockFile,
|
|
eaInvalidUnlockFile, eaInvalidJson);
|
|
|
|
/// any sensitive, or licensed program, could call this method to check for
|
|
// authorized execution for a given user on a given computer, using very secure
|
|
// asymmetric ECC cryptography
|
|
// - applock.public/.private keys pair should have been generated, applock.public
|
|
// stored as aAppLockPublic64 in the executables, and applock.private kept secret
|
|
// - will search for encrypted authorization in a local user@host.unlock file
|
|
// - if no user@host.unlock file is found, will create local user@host.public
|
|
// and user@host.secret files and return eaMissingUnlockFile: user should then send
|
|
// user@host.public to the product support to receive its user@host.unlock file
|
|
// (a dedicated UI may be developped, or an uncrypted email can be used for
|
|
// transfer with the support team, thanks to asymmetric cryptography)
|
|
// - local user@host.secret file is encrypted via DPAPI/CryptDataForCurrentUser
|
|
// for the specific computer and user (to avoid .unlock reuse on another PC)
|
|
// - support team should create a user@host.json file matching aContent: TObject
|
|
// published properties, containing all application-specific settings and
|
|
// authorization scope; then it could create the unlock file using e.g. an
|
|
// unlock.bat file running the ECC tool over secret applock.private keys:
|
|
// $ @echo off
|
|
// $ echo Usage: unlock user@host
|
|
// $ echo.
|
|
// $ ecc sign -file %1.json -auth applock -pass applockprivatepassword -rounds 60000
|
|
// $ ecc crypt -file %1.json -out %1.unlock -auth %1 -saltpass decryptsalt -saltrounds 10000
|
|
// $ del %1.json.sign
|
|
// - returns eaInvalidUnlockFile if the local user@host.unlock file is not
|
|
// correctly signed and encrypted for this user (e.g. corrupted or deprecated)
|
|
// - eaInvalidJson will indicate some error in the .json created by support team,
|
|
// i.e. if it does not match aContent: TObject published properties
|
|
// - eaSuccess should let the application execute, on the returned scope
|
|
// - returns eaSuccess if a local user@host.unlock file has been successfully
|
|
// decrypted and validated (using ECDSA over aAppLockPublic64) and successfully
|
|
// unserialized from JSON into aContent object instance
|
|
// - user@host.* files are searched in the executable folder if aSearchFolder='',
|
|
// but you may specify a custom location, e.g. use ECCKeyFileFolder
|
|
// - aSecretPass could be entered by the end-user, to authenticate its identity;
|
|
// you may specify a string constant if local applock.public/.private key files
|
|
// is enough secure for your application
|
|
// - will use the supplied aDPAPI/aDecryptSalt parameters to restrict
|
|
// this authorization to a specific product (i.e. isolate the execution context
|
|
// to reduce forensic scope), for dedicated applock.public/.private keys pair -
|
|
// just pass some application-specific string constant to those parameters
|
|
// - aSecretInfo^ could be set to retrieve the user@host.secret information
|
|
// (e.g. validity dates), and aLocalFile^ the'<fullpath>user@host' file prefix
|
|
function ECCAuthorize(aContent: TObject; aSecretDays: integer; const aSecretPass,
|
|
aDPAPI, aDecryptSalt, aAppLockPublic64: RawUTF8; const aSearchFolder: TFileName = '';
|
|
aSecretInfo: PECCCertificateSigned = nil; aLocalFile: PFileName = nil): TECCAuthorize;
|
|
|
|
function ToText(auth: TECCAuthorize): PShortString; overload;
|
|
|
|
|
|
implementation
|
|
|
|
{ ----- Implements Service/Daemon Applications }
|
|
|
|
function ToText(st: TDDDSocketThreadState): PShortString;
|
|
begin
|
|
result := GetEnumName(TypeInfo(TDDDSocketThreadState),ord(st));
|
|
end;
|
|
|
|
function ToText(exc: TDDDMockedSocketException): PShortString;
|
|
begin
|
|
result := GetEnumName(TypeInfo(TDDDMockedSocketException),ord(exc));
|
|
end;
|
|
|
|
|
|
{ TDDDDaemon }
|
|
|
|
constructor TDDDDaemon.Create(aSettings: TDDDAdministratedDaemonSettings);
|
|
begin
|
|
inherited Create;
|
|
if aSettings = nil then
|
|
raise EDDDInfraException.CreateUTF8('%.Create(settings=nil)', [self]);
|
|
fSettings := aSettings;
|
|
fSettingsRef := aSettings;
|
|
end;
|
|
|
|
function TDDDDaemon.DaemonInstance: TObject;
|
|
begin
|
|
result := ObjectFromInterface(fDaemon);
|
|
end;
|
|
|
|
destructor TDDDDaemon.Destroy;
|
|
begin
|
|
fDaemon := nil;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDDDDaemon.DoStart{$ifdef MSWINDOWS}(Sender: TService){$endif};
|
|
var log: ISynLog;
|
|
res: TCQRSResult;
|
|
begin
|
|
{$ifdef WITHLOG}
|
|
{$ifdef MSWINDOWS}
|
|
SQLite3Log.Add.LogThreadName('Service Start Handler', true);
|
|
{$endif}
|
|
log := SQLite3Log.Enter(self, 'DoStart');
|
|
if log<>nil then
|
|
with ExeVersion do
|
|
log.Log(sllNewRun, 'Daemon Start svc=% ver=% usr=%',
|
|
[fSettings.ServiceName, Version.Detailed, LowerCase(User)], self);
|
|
{$endif}
|
|
fDaemon := NewDaemon;
|
|
res := fDaemon.Start;
|
|
if log <> nil then
|
|
log.Log(sllTrace, 'fDaemon.Start=%', [ToText(res)^], self);
|
|
end;
|
|
|
|
procedure TDDDDaemon.DoStop{$ifdef MSWINDOWS}(Sender: TService){$endif};
|
|
{$ifdef WITHLOG}
|
|
var log: ISynLog;
|
|
begin
|
|
{$ifdef MSWINDOWS}
|
|
SQLite3Log.Add.LogThreadName('Service Stop Handler', true);
|
|
{$endif}
|
|
log := SQLite3Log.Enter(self, 'DoStop');
|
|
if log<>nil then
|
|
log.Log(sllNewRun, 'Daemon Stop svc=% ver=% usr=%', [fSettings.ServiceName,
|
|
ExeVersion.Version.Detailed, LowerCase(ExeVersion.User)], self);
|
|
{$else}
|
|
begin
|
|
{$endif}
|
|
fDaemon := nil; // will stop the daemon
|
|
end;
|
|
|
|
function TDDDDaemon.NewDaemon: TDDDAdministratedDaemon;
|
|
begin
|
|
if Assigned(fSettings) then begin
|
|
if fSettings.Log.LowLevelWebSocketsFrames then begin
|
|
{$ifdef WITHLOG}
|
|
WebSocketLog := SQLite3Log;
|
|
{$endif}
|
|
HttpServerFullWebSocketsLog := true;
|
|
HttpClientFullWebSocketsLog := true;
|
|
end;
|
|
SQLite3Log.Family.AutoFlushTimeOut := fSettings.Log.AutoFlushTimeOut; // after /fork
|
|
{$ifdef MSWINDOWS} // Windows 7+
|
|
SetAppUserModelID(fSettings.AppUserModelID);
|
|
{$endif}
|
|
end;
|
|
result := nil;
|
|
end;
|
|
|
|
procedure TDDDDaemon.Execute;
|
|
{$ifdef WITHLOG}
|
|
var log: ISynLog;
|
|
begin
|
|
log := SQLite3Log.Enter(self, 'Execute');
|
|
{$else}
|
|
begin
|
|
{$endif}
|
|
fDaemon := NewDaemon;
|
|
fDaemon.Start;
|
|
end;
|
|
|
|
function TDDDDaemon.WaitStarted(TimeoutMS: integer): boolean;
|
|
var
|
|
tix: Int64;
|
|
begin
|
|
tix := GetTickCount64 + TimeoutMS;
|
|
repeat
|
|
SleepHiRes(50);
|
|
result := Daemon <> nil;
|
|
until result or (GetTickCount64 > tix);
|
|
end;
|
|
|
|
function TDDDDaemon.ExecuteAndWaitStarted(TimeoutMS: integer): boolean;
|
|
begin
|
|
try
|
|
Execute;
|
|
result := WaitStarted(TimeoutMS);
|
|
except
|
|
result := false;
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TExecuteCommandLineCmd = (
|
|
cNone, cInstall, cUninstall, cStart, cStop, cState,
|
|
cVersion, cVerbose, cHelp, cHardenPasswords, cPlainPasswords,
|
|
cConsole, cDaemon, cRun, cFork, cKill);
|
|
|
|
procedure TDDDDaemon.ExecuteCommandLine(ForceRun: boolean);
|
|
var
|
|
name, param: RawUTF8;
|
|
p: PUTF8Char;
|
|
passwords, exe: RawByteString;
|
|
cmd: TExecuteCommandLineCmd;
|
|
daemon: TDDDAdministratedDaemon;
|
|
{$ifdef MSWINDOWS}
|
|
service: TServiceSingle;
|
|
ctrl: TServiceController;
|
|
depend: string;
|
|
i: integer;
|
|
{$endif}
|
|
{$I-} // no IO error for writeln() below
|
|
|
|
function cmdText: RawUTF8;
|
|
begin
|
|
result := GetEnumNameTrimed(TypeInfo(TExecuteCommandLineCmd), cmd);
|
|
end;
|
|
|
|
procedure HardenSettings(const folder: TFileName; P: PUTF8Char);
|
|
var B: PUTF8Char;
|
|
fn, bak: TFileName;
|
|
pass, appsec, plain, new: RawUTF8;
|
|
doc: TDocVariantData;
|
|
modified, any: boolean;
|
|
v: PVariant;
|
|
begin
|
|
TextColor(ccLightCyan);
|
|
writeln('Executing /', cmdText, ' with User "', ExeVersion.User, '"'#13#10);
|
|
any := false;
|
|
repeat
|
|
B := pointer(GetNextLine(P,P));
|
|
if B=nil then
|
|
exit;
|
|
fn := FormatString('%%.settings', [folder, GetNextItem(B, '=')]);
|
|
doc.InitJSONFromFile(fn, JSON_OPTIONS_FAST, true);
|
|
modified := false;
|
|
if doc.Count > 0 then
|
|
while B <> nil do begin
|
|
GetNextItem(B, '@', appsec);
|
|
v := doc.GetPVariantByPath(GetNextItem(B));
|
|
if v = nil then
|
|
continue;
|
|
if VariantToUTF8(v^, pass) and (pass <> '') then begin
|
|
plain := TSynPersistentWithPassword.ComputePlainPassword(pass, 0, appsec);
|
|
if plain = '' then
|
|
continue; // may occur with unexpected user
|
|
case cmd of
|
|
cHardenPasswords:
|
|
new := FormatUTF8('%:%', [ExeVersion.User,
|
|
BinToBase64(CryptDataForCurrentUser(plain, appsec, true))]);
|
|
cPlainPasswords:
|
|
new := TSynPersistentWithPassword.ComputePassword(plain);
|
|
else
|
|
exit;
|
|
end;
|
|
FillZero(plain);
|
|
if new <> pass then begin
|
|
RawUTF8ToVariant(new, v^); // replace
|
|
modified := true;
|
|
end;
|
|
end;
|
|
end;
|
|
if modified then begin
|
|
bak := ChangeFileExt(fn, '.bak');
|
|
DeleteFile(bak);
|
|
RenameFile(fn, bak);
|
|
FileFromString(doc.ToJSON('', '', jsonHumanReadable), fn);
|
|
any := true;
|
|
TextColor(ccLightCyan);
|
|
end
|
|
else
|
|
TextColor(ccDarkGray);
|
|
writeln(' ', fn);
|
|
doc.Clear;
|
|
until P=nil;
|
|
if any and (cmd = cHardenPasswords) then begin
|
|
TextColor(ccYellow);
|
|
writeln(#13#10' Warning:'#13#10' /', cmdText,
|
|
' new .settings will work only with user "', ExeVersion.User, '"');
|
|
end;
|
|
end;
|
|
|
|
procedure Show(Success: Boolean);
|
|
var
|
|
msg: RawUTF8;
|
|
error: integer;
|
|
begin
|
|
if Success then begin
|
|
msg := 'Successfully executed';
|
|
TextColor(ccWhite);
|
|
end
|
|
else begin
|
|
error := GetLastError;
|
|
msg := FormatUTF8('Error % [%] occured with',
|
|
[error, StringToUTF8(SysErrorMessage(error))]);
|
|
TextColor(ccLightRed);
|
|
ExitCode := 1; // notify error to caller batch
|
|
end;
|
|
msg := FormatUTF8('% [%] (%) on Service [%]',
|
|
[msg, param, cmdText, fSettings.ServiceName]);
|
|
writeln(msg);
|
|
AppendToTextFile(ExeVersion.User + ' ' +msg,
|
|
ChangeFileExt(ExeVersion.ProgramFileName, '.txt'));
|
|
end;
|
|
|
|
procedure Syntax;
|
|
var spaces: string;
|
|
begin
|
|
writeln('Try with one of the switches:');
|
|
writeln({$ifdef MSWINDOWS}' '{$else}' ./'{$endif}, ExeVersion.ProgramName,
|
|
' /console -c /verbose /daemon -d /help -h /version');
|
|
spaces := StringOfChar(' ', length(ExeVersion.ProgramName) + 4);
|
|
{$ifdef MSWINDOWS}
|
|
writeln(spaces, '/install /uninstall /start /stop /state');
|
|
{$else}
|
|
writeln(spaces, '/run -r /fork -f /kill -k');
|
|
{$endif}
|
|
if passwords <> '' then
|
|
writeln(spaces, '/hardenpasswords /plainpasswords');
|
|
writeln(spaces, CustomHelp);
|
|
end;
|
|
|
|
begin
|
|
try
|
|
if fSettings.ServiceDisplayName = '' then begin
|
|
fDaemon := NewDaemon; // should initialize the default .settings
|
|
fDaemon := nil;
|
|
end;
|
|
ResourceSynLZToRawByteString('passwords', passwords);
|
|
TextColor(ccLightGreen);
|
|
name := StringToUTF8(fSettings.ServiceDisplayName);
|
|
if name = '' then // perhaps the settings file is still void
|
|
name := ExeVersion.ProgramName;
|
|
if ExeVersion.Version.Version32 <> 0 then
|
|
name := FormatUTF8('% %', [name, ExeVersion.Version.Detailed]);
|
|
writeln(#10' ', name);
|
|
writeln(StringOfChar('-', length(name) + 2));
|
|
TextColor(ccGreen);
|
|
if fSettings.Description <> '' then
|
|
writeln(fSettings.Description);
|
|
if GlobalCopyright <> '' then
|
|
writeln('(c)', CurrentYear, ' ', GlobalCopyright);
|
|
writeln;
|
|
TextColor(ccLightCyan);
|
|
if ForceRun then
|
|
param := '/verbose' else
|
|
param := trim(StringToUTF8(paramstr(1)));
|
|
if (param = '') or not (param[1] in ['/', '-']) then
|
|
cmd := cNone
|
|
else begin
|
|
p := @param[2];
|
|
if p^ = '-' then // allow e.g. --fork switch (idem to /f -f /fork -fork)
|
|
inc(p);
|
|
case NormToUpper[p^] of
|
|
'C':
|
|
cmd := cConsole;
|
|
'D':
|
|
cmd := cDaemon;
|
|
'R':
|
|
cmd := cRun;
|
|
'F':
|
|
cmd := cFork;
|
|
'K':
|
|
cmd := cKill;
|
|
else
|
|
byte(cmd) := ord(cInstall) + IdemPCharArray(p,
|
|
['INST', 'UNINST', 'START', 'STOP', 'STAT', 'VERS', 'VERB', 'HELP',
|
|
'HARDEN', 'PLAIN']);
|
|
end;
|
|
end;
|
|
case cmd of
|
|
cHelp:
|
|
Syntax;
|
|
cVersion:
|
|
begin
|
|
exe := StringFromFile(ExeVersion.ProgramFileName);
|
|
writeln(' ', ExeVersion.ProgramFileName,
|
|
#13#10' Size: ', length(exe), ' bytes (', KB(exe), ')' +
|
|
#13#10' Build date: ', ExeVersion.Version.BuildDateTimeString,
|
|
#13#10' MD5: ', MD5(exe),
|
|
#13#10' SHA256: ', SHA256(exe));
|
|
if ExeVersion.Version.Version32 <> 0 then
|
|
writeln(' Version: ', ExeVersion.Version.Detailed);
|
|
TextColor(ccCyan);
|
|
writeln(#10'Powered by Synopse mORMot ' + SYNOPSE_FRAMEWORK_VERSION);
|
|
end;
|
|
cConsole, cDaemon, cVerbose:
|
|
begin
|
|
writeln('Launched in ', cmdText, ' mode'#10);
|
|
TextColor(ccLightGray);
|
|
{$ifdef WITHLOG}
|
|
case cmd of
|
|
cVerbose: // leave as in settings for -c (cConsole)
|
|
SQLite3Log.Family.EchoToConsole := LOG_VERBOSE;
|
|
end;
|
|
SQLite3Log.Add.Log(sllNewRun, 'Start % /% %', [fSettings.ServiceName,cmdText,
|
|
ExeVersion.Version.DetailedOrVoid], self);
|
|
{$endif}
|
|
daemon := NewDaemon;
|
|
try
|
|
fDaemon := daemon;
|
|
{$ifdef WITHLOG}
|
|
if cmd = cDaemon then
|
|
if (daemon.AdministrationServer = nil) or not ({$ifdef MSWINDOWS}
|
|
daemon.AdministrationServer.ExportedAsMessageOrNamedPipe or {$endif}
|
|
(daemon.InheritsFrom(TDDDThreadDaemon) and
|
|
(TDDDThreadDaemon(daemon).fAdministrationHTTPServer <> nil))) then
|
|
daemon.Log.Synlog.Log(sllWarning, 'ExecuteCommandLine as Daemon ' +
|
|
'without external admnistrator acccess', self);
|
|
{$endif}
|
|
daemon.Execute(cmd = cDaemon);
|
|
finally
|
|
SQLite3Log.Add.Log(sllNewRun, 'Stop /%', [cmdText], self);
|
|
fDaemon := nil; // will stop the daemon
|
|
end;
|
|
end;
|
|
cHardenPasswords, cPlainPasswords:
|
|
if passwords <> '' then
|
|
HardenSettings(IncludeTrailingPathDelimiter(fSettings.SettingsFolder),
|
|
pointer(passwords))
|
|
else begin
|
|
TextColor(ccLightRed);
|
|
writeln('No "passwords" resource bound to ', ExeVersion.ProgramFullSpec);
|
|
end;
|
|
{$ifdef MSWINDOWS} // implement the daemon as a Windows Service
|
|
else with fSettings do
|
|
if ServiceName = '' then
|
|
if cmd = cNone then
|
|
Syntax
|
|
else begin
|
|
TextColor(ccLightRed);
|
|
writeln('No ServiceName specified - please fix the settings');
|
|
end
|
|
else
|
|
case cmd of
|
|
cNone:
|
|
if param = '' then begin // executed as a background service
|
|
service := TServiceSingle.Create(ServiceName, ServiceDisplayName);
|
|
try
|
|
service.OnStart := DoStart;
|
|
service.OnStop := DoStop;
|
|
service.OnShutdown := DoStop; // sometimes, is called without Stop
|
|
if ServicesRun then // blocking until service shutdown
|
|
Show(true)
|
|
else if GetLastError = 1063 then
|
|
Syntax
|
|
else
|
|
Show(false);
|
|
finally
|
|
service.Free;
|
|
end;
|
|
end
|
|
else
|
|
Syntax;
|
|
cInstall:
|
|
begin
|
|
if ServiceDependencies <> nil then begin
|
|
depend := ServiceDependencies[0];
|
|
for i := 1 to high(ServiceDependencies) do
|
|
depend := depend + #0 + ServiceDependencies[i];
|
|
end else if (ParamCount >= 3) and SameText(ParamStr(2), '/depend') then begin
|
|
depend := ParamStr(3);
|
|
for i := 4 to ParamCount do
|
|
depend := depend + #0 + ParamStr(i);
|
|
end;
|
|
if depend <> '' then
|
|
depend := depend + #0; // ensure ends with dual #0
|
|
Show(TServiceController.Install(ServiceName, ServiceDisplayName,
|
|
Description, ServiceAutoStart, '', depend) <> ssNotInstalled);
|
|
end;
|
|
else
|
|
begin
|
|
ctrl := TServiceController.CreateOpenService('', '', ServiceName);
|
|
try
|
|
case cmd of
|
|
cStart:
|
|
Show(ctrl.Start([]));
|
|
cStop:
|
|
Show(ctrl.Stop);
|
|
cUninstall:
|
|
begin
|
|
ctrl.Stop;
|
|
Show(ctrl.Delete);
|
|
end;
|
|
cState:
|
|
writeln(ServiceName, ' State=', ServiceStateText(ctrl.State));
|
|
else
|
|
Show(false);
|
|
end;
|
|
finally
|
|
ctrl.Free;
|
|
end;
|
|
end;
|
|
end;
|
|
{$else}
|
|
cRun, cFork:
|
|
RunUntilSigTerminated(self, (cmd=cFork), DoStart, DoStop
|
|
{$ifdef WITHLOG},SQLite3Log.Add, fSettings.ServiceName{$endif});
|
|
cKill:
|
|
if not RunUntilSigTerminatedForKill then
|
|
raise EServiceException.Create('No forked process found to be killed');
|
|
else
|
|
Syntax;
|
|
{$endif MSWINDOWS}
|
|
end;
|
|
except
|
|
on E: Exception do begin
|
|
ConsoleShowFatalException(E);
|
|
ExitCode := 1; // indicates error
|
|
end;
|
|
end;
|
|
TextColor(ccLightGray);
|
|
ioresult;
|
|
end;
|
|
{$I+}
|
|
|
|
function TDDDDaemon.CustomHelp: string;
|
|
begin
|
|
result := '';
|
|
end;
|
|
|
|
|
|
{ TDDDThreadDaemon }
|
|
|
|
function TDDDThreadDaemon.GetAdministrationHTTPServer: TSQLHttpServer;
|
|
begin
|
|
result := fAdministrationHTTPServer as TSQLHttpServer;
|
|
end;
|
|
|
|
function TDDDThreadDaemon.InternalRetrieveState(var Status: variant): boolean;
|
|
begin
|
|
Status := _ObjFast(['SystemMemory', TSynMonitorMemory.ToVariant]);
|
|
result := true;
|
|
end;
|
|
|
|
function CanSubscribeLog(const Callback: ISynLogCallback): Boolean;
|
|
begin
|
|
result := false;
|
|
if Assigned(Callback) then
|
|
if {$ifdef WITHLOG}(WebSocketLog<>nil) or{$endif}
|
|
HttpClientFullWebSocketsLog or HttpServerFullWebSocketsLog then begin
|
|
Callback.Log(sllError, FormatUTF8(
|
|
'%00% SubscribeLog is not allowed when low-level WebSockets ' +
|
|
'frame logging is enabled (otherwise a race condition happens)',
|
|
[NowToString(False), LOG_LEVEL_TEXT[sllError]]));
|
|
exit;
|
|
end
|
|
else
|
|
result := true;
|
|
end;
|
|
|
|
procedure TDDDThreadDaemon.SubscribeLog(const Levels: TSynLogInfos;
|
|
const Callback: ISynLogCallback; ReceiveExistingKB: cardinal);
|
|
begin
|
|
if CanSubscribeLog(Callback) then
|
|
inherited SubscribeLog(Levels, Callback, ReceiveExistingKB);
|
|
end;
|
|
|
|
|
|
{ TDDDRestDaemon }
|
|
|
|
function TDDDRestDaemon.GetAdministrationHTTPServer: TSQLHttpServer;
|
|
begin
|
|
result := TSQLHttpServer(fAdministrationHTTPServer);
|
|
end;
|
|
|
|
procedure TDDDRestDaemon.InternalLogMonitoring;
|
|
var
|
|
status: variant;
|
|
begin
|
|
{$ifdef WITHLOG}
|
|
if fLog <> nil then
|
|
if (sllMonitoring in fLog.Level) and InternalRetrieveState(status) then
|
|
fLog.SynLog.Log(sllMonitoring, '%', [status], Self);
|
|
{$endif}
|
|
end;
|
|
|
|
function TDDDRestDaemon.InternalRetrieveState(var Status: variant): boolean;
|
|
begin
|
|
if fRest <> nil then begin
|
|
Status := _ObjFast(['Rest', fRest.StatsAsDocVariant,
|
|
'SystemMemory', TSynMonitorMemory.ToVariant]);
|
|
result := true;
|
|
end
|
|
else
|
|
result := false;
|
|
end;
|
|
|
|
procedure TDDDRestDaemon.SubscribeLog(const Levels: TSynLogInfos;
|
|
const Callback: ISynLogCallback; ReceiveExistingKB: cardinal);
|
|
begin
|
|
if CanSubscribeLog(Callback) then
|
|
inherited SubscribeLog(Levels, Callback, ReceiveExistingKB);
|
|
end;
|
|
|
|
|
|
{ TDDDRestHttpDaemon }
|
|
|
|
function TDDDRestHttpDaemon.Settings: TDDDAdministratedDaemonHttpSettings;
|
|
begin
|
|
result := TDDDAdministratedDaemonHttpSettings(fInternalSettings);
|
|
end;
|
|
|
|
procedure TDDDRestHttpDaemon.InternalStart;
|
|
begin
|
|
if Settings.Http.BindPort <> '' then
|
|
fHttpServer := TSQLHttpServer.Create(fRest, Settings.Http);
|
|
end;
|
|
|
|
procedure TDDDRestHttpDaemon.InternalStop;
|
|
begin
|
|
try
|
|
if Assigned(fRest) then
|
|
fRest.Shutdown; // no incoming TSQLRestServer.URI allowed from now on
|
|
FreeAndNil(fHttpServer);
|
|
FreeAndNil(fServicesLogRest);
|
|
finally
|
|
inherited InternalStop; // FreeAndNil(fRest)
|
|
end;
|
|
end;
|
|
|
|
|
|
{ ----- Implements Thread Processing to access a TCP server }
|
|
|
|
procedure TDDDRestHttpDaemon.WrapperGenerate(const DestFile, Template: TFileName);
|
|
begin
|
|
Settings.Rest.WrapperGenerate(Rest, GetInteger(pointer(HttpServer.Port)), DestFile, Template);
|
|
end;
|
|
|
|
|
|
{ TDDDSocketThreadMonitoring }
|
|
|
|
function TDDDSocketThreadMonitoring.GetSocket: variant;
|
|
begin
|
|
if (fOwner = nil) or not fOwner.InheritsFrom(TDDDSocketThread) or
|
|
(TDDDSocketThread(fOwner).fSocket = nil) then
|
|
SetVariantNull(result)
|
|
else
|
|
ObjectToVariant(ObjectFromInterface(TDDDSocketThread(fOwner).fSocket), result);
|
|
end;
|
|
|
|
|
|
{ TDDDSocketThread }
|
|
|
|
constructor TDDDSocketThread.Create(aSettings: TDDDSocketThreadSettings;
|
|
aRest: TSQLRest; aMonitoring: TDDDSocketThreadMonitoring);
|
|
begin
|
|
if aSettings = nil then
|
|
raise EDDDInfraException.CreateUTF8('%.Create(aSettings=nil)', [self]);
|
|
fSettings := aSettings;
|
|
if aMonitoring = nil then
|
|
raise EDDDInfraException.CreateUTF8('%.Create(aMonitoring=nil)', [self]);
|
|
fMonitoring := aMonitoring;
|
|
if fMonitoring.fOwner=nil then
|
|
fMonitoring.fOwner := self;
|
|
if fSettings.Host = '' then
|
|
fSettings.Host := '127.0.0.1';
|
|
fHost := fSettings.Host;
|
|
if fSettings.Port = 0 then
|
|
raise EDDDInfraException.CreateUTF8('%.Create(Port=0)', [self]);
|
|
fPort := UInt32ToUtf8(fSettings.Port);
|
|
if fSettings.SocketLoopPeriod < 10 then
|
|
fSettings.SocketLoopPeriod := 10;
|
|
if fSettings.SocketTimeout < fSettings.SocketLoopPeriod then
|
|
fSettings.SocketTimeout := 2000;
|
|
fPerformConnection := true;
|
|
inherited Create(aRest, true, true); // aOwnRest=true, aCreateSuspended=true
|
|
end;
|
|
|
|
destructor TDDDSocketThread.Destroy;
|
|
var
|
|
timeOut: Int64;
|
|
begin
|
|
{$ifdef WITHLOG}
|
|
if fLog<>nil then // no log after NotifyThreadEnded call
|
|
fLog.Family.SynLog.Log(sllTrace,'Destroy %:%',[fHost,fPort],self);
|
|
{$endif}
|
|
Terminate;
|
|
timeOut := GetTickCount64 + 10000;
|
|
repeat // wait until properly disconnected from remote TCP server
|
|
SleepHiRes(10);
|
|
until (fMonitoring.State = tpsDisconnected) or (GetTickCount64 > timeOut);
|
|
inherited Destroy;
|
|
if fMonitoring.fOwner=self then
|
|
FreeAndNil(fMonitoring);
|
|
end;
|
|
|
|
procedure TDDDSocketThread.ExecuteConnect;
|
|
{$ifdef WITHLOG}
|
|
var log: ISynLog;
|
|
begin
|
|
log := FLog.Enter('ExecuteConnect %:%',[fHost,fPort],self);
|
|
{$else}
|
|
begin
|
|
{$endif}
|
|
if fSocket <> nil then
|
|
raise EDDDInfraException.CreateUTF8('%.ExecuteConnect: fSocket<>nil', [self]);
|
|
if fMonitoring.State <> tpsDisconnected then
|
|
raise EDDDInfraException.CreateUTF8('%.ExecuteConnect: State=%',
|
|
[self, ToText(fMonitoring.State)^]);
|
|
fMonitoring.State := tpsConnecting;
|
|
try
|
|
if fSettings.SocketBufferBytes <= 0 then
|
|
fSettings.SocketBufferBytes := 32768;
|
|
if Assigned(fSettings.OnIDDDSocketThreadCreate) then
|
|
fSettings.OnIDDDSocketThreadCreate(self, fSocket)
|
|
else
|
|
fSocket := TDDDSynCrtSocket.Create(self, fHost, fPort,
|
|
fSettings.SocketTimeout, fSettings.SocketBufferBytes);
|
|
fSocket.Connect;
|
|
fMonitoring.State := tpsConnected; // to be done ASAP to allow sending
|
|
InternalExecuteConnected;
|
|
{$ifdef WITHLOG}
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ExecuteConnect: Connected via Socket % - %',
|
|
[fSocket.Identifier, fMonitoring], self);
|
|
{$endif}
|
|
except
|
|
on E: Exception do begin
|
|
fMonitoring.ProcessException(E);
|
|
{$ifdef WITHLOG}
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ExecuteConnect: Impossible to Connect to %:% (%) %',
|
|
[Host, Port, E.ClassType, fMonitoring], self);
|
|
{$endif}
|
|
fSocket := nil;
|
|
fMonitoring.State := tpsDisconnected;
|
|
end;
|
|
end;
|
|
if (fMonitoring.State <> tpsConnected) and not Terminated then
|
|
if fSettings.ConnectionAttemptsInterval < 0 then
|
|
Terminate
|
|
else if fSettings.ConnectionAttemptsInterval > 0 then // on error, retry
|
|
if SleepOrTerminated(fSettings.ConnectionAttemptsInterval * 1000) then
|
|
{$ifdef WITHLOG} begin
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ExecuteConnect: thread terminated', self)
|
|
end
|
|
else if log<>nil then
|
|
log.Log(sllTrace, 'ExecuteConnect: wait finished -> retry connect', self)
|
|
{$endif};
|
|
end;
|
|
|
|
procedure TDDDSocketThread.ExecuteDisconnect;
|
|
var
|
|
info: RawUTF8;
|
|
{$ifdef WITHLOG}
|
|
log: ISynLog;
|
|
begin
|
|
log := FLog.Enter('ExecuteDisconnect %:%',[fHost,fPort],self);
|
|
{$else}
|
|
begin
|
|
{$endif}
|
|
try
|
|
fSafe.Lock;
|
|
try
|
|
fShouldDisconnect := false;
|
|
fMonitoring.State := tpsDisconnected;
|
|
try
|
|
if fSocket = nil then
|
|
info := '[Unknown]'
|
|
else
|
|
info := fSocket.Identifier;
|
|
InternalExecuteDisconnect;
|
|
finally
|
|
fSocket := nil;
|
|
end;
|
|
{$ifdef WITHLOG}
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'Socket % disconnected', [info], self);
|
|
{$endif}
|
|
InternalLogMonitoring;
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
except
|
|
on E: Exception do begin
|
|
fMonitoring.ProcessException(E);
|
|
{$ifdef WITHLOG}
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'Socket disconnection error (%)', [E.ClassType], self);
|
|
{$endif}
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDSocketThread.ExecuteDisconnectAfterError;
|
|
begin
|
|
{$ifdef WITHLOG}
|
|
if fSocket <> nil then
|
|
FLog.Log(sllError, '%.ExecuteDisconnectAfterError: Sock=% LastError=%',
|
|
[ClassType, fSocket.Identifier, fSocket.LastError], self);
|
|
{$endif}
|
|
ExecuteDisconnect;
|
|
FSocketInputBuffer := '';
|
|
if fSettings.AutoReconnectAfterSocketError then
|
|
FPerformConnection := true;
|
|
end;
|
|
|
|
procedure TDDDSocketThread.ExecuteSocket;
|
|
var
|
|
pending, len: integer;
|
|
begin
|
|
if Terminated or fSocketDisable then
|
|
exit;
|
|
if (fSettings.SocketMaxBufferBytes = 0) or
|
|
(length(FSocketInputBuffer) < fSettings.SocketMaxBufferBytes) then begin
|
|
pending := fSocket.DataInPending(fSettings.SocketLoopPeriod);
|
|
if Terminated or (pending = 0) then
|
|
exit;
|
|
if pending < 0 then begin
|
|
ExecuteDisconnectAfterError;
|
|
exit;
|
|
end;
|
|
len := length(FSocketInputBuffer);
|
|
SetLength(FSocketInputBuffer, len + pending);
|
|
if fSocket.DataIn(@PByteArray(FSocketInputBuffer)[len], pending) <> pending then begin
|
|
ExecuteDisconnectAfterError;
|
|
exit;
|
|
end;
|
|
FMonitoring.Server.AddSize(pending, 0);
|
|
end;
|
|
InternalExecuteSocket;
|
|
end;
|
|
|
|
procedure TDDDSocketThread.InternalExecute;
|
|
begin
|
|
fPreviousMonitorTix := GetTickCount64;
|
|
try
|
|
repeat
|
|
if fMonitoring.State = tpsConnected then
|
|
ExecuteSocket
|
|
else if fPerformConnection then
|
|
ExecuteConnect
|
|
else
|
|
SleepHiRes(100);
|
|
if Terminated then
|
|
break;
|
|
try
|
|
if Elapsed(fPreviousMonitorTix, fSettings.MonitoringLogInterval) then
|
|
InternalLogMonitoring;
|
|
InternalExecuteIdle;
|
|
except
|
|
on E: Exception do begin
|
|
fMonitoring.ProcessException(E);
|
|
{$ifdef WITHLOG}
|
|
FLog.Log(sllWarning, 'Skipped % exception in %.InternalExecuteIdle',
|
|
[E, ClassType], self);
|
|
{$endif}
|
|
end;
|
|
end;
|
|
until Terminated;
|
|
finally
|
|
ExecuteDisconnect;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDSocketThread.InternalExecuteConnected;
|
|
begin
|
|
end;
|
|
|
|
procedure TDDDSocketThread.InternalExecuteDisconnect;
|
|
begin
|
|
end;
|
|
|
|
procedure TDDDSocketThread.InternalExecuteIdle;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
if fShouldDisconnect then
|
|
ExecuteDisconnectAfterError;
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDSocketThread.InternalLogMonitoring;
|
|
var
|
|
cached, flushed: integer;
|
|
begin // CachedMemory method will also purge any outdated cached entries
|
|
cached := fRest.CacheOrNil.CachedMemory(@flushed);
|
|
{$ifdef WITHLOG}
|
|
FLog.Log(sllMonitoring, '% CachedMemory=% Flushed=%',
|
|
[FMonitoring, cached, flushed], Self);
|
|
{$endif}
|
|
fPreviousMonitorTix := GetTickCount64;
|
|
end;
|
|
|
|
procedure TDDDSocketThread.Shutdown(andTerminate: boolean);
|
|
begin
|
|
if (self <> nil) and not fSocketDisable then begin
|
|
fSocketDisable := true;
|
|
fRest.LogClass.Add.Log(sllDebug, 'Shutdown: % will stop any communication ' +
|
|
'with %:%', [ClassType, fHost, fPort], self);
|
|
if andTerminate and not Terminated then begin
|
|
SleepHiRes(100);
|
|
Terminate;
|
|
WaitFor;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDDDSocketThread.StatsAsJson: RawUTF8;
|
|
begin
|
|
with TJSONSerializer.CreateOwnedStream do
|
|
try
|
|
WriteObject(FMonitoring);
|
|
CancelLastChar('}');
|
|
if fRest.InheritsFrom(TSQLRestServer) then begin
|
|
AddShort(',"Rest":');
|
|
AddNoJSONEscapeUTF8(TSQLRestServer(fRest).StatsAsJson);
|
|
end;
|
|
Add(',"Version":"%","DateTime":"%"}',
|
|
[ExeVersion.Version.Detailed, NowUTCToString(True, 'T')]);
|
|
SetText(result);
|
|
finally
|
|
Free;
|
|
end;
|
|
end;
|
|
|
|
function TDDDSocketThread.TrySend(const aFrame: RawByteString;
|
|
ImmediateDisconnectAfterError: boolean): Boolean;
|
|
var
|
|
tmpSock: IDDDSocket; // avoid GPF if fSocket=nil after fSafe.UnLock (unlikely)
|
|
begin
|
|
if fSocketDisable then begin
|
|
result := false;
|
|
exit;
|
|
end;
|
|
fSafe.Lock;
|
|
try
|
|
result := (aFrame <> '') and (fSocket <> nil) and
|
|
(fMonitoring.State = tpsConnected) and not fShouldDisconnect;
|
|
if result then
|
|
tmpSock := fSocket;
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
if not result then
|
|
exit;
|
|
result := tmpSock.DataOut(pointer(aFrame), length(aFrame));
|
|
if result then
|
|
fMonitoring.Server.AddSize(0, length(aFrame))
|
|
else if ImmediateDisconnectAfterError then
|
|
ExecuteDisconnectAfterError
|
|
else begin
|
|
fSafe.Lock;
|
|
try
|
|
fShouldDisconnect := true; // notify for InternalExecuteIdle
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TDDDSynCrtSocket }
|
|
|
|
constructor TDDDSynCrtSocket.Create(aOwner: TThread; const aHost, aPort: SockString;
|
|
aSocketTimeout, aInternalBufferSize: integer);
|
|
begin
|
|
inherited Create;
|
|
fOwner := aOwner;
|
|
fHost := aHost;
|
|
fPort := aPort;
|
|
fSocket := TCrtSocket.Create(aSocketTimeout);
|
|
if aInternalBufferSize < 512 then
|
|
aInternalBufferSize := 512;
|
|
fInternalBufferSize := aInternalBufferSize;
|
|
fOutput.Init; // uses two locks to avoid race condition on multi-thread
|
|
end;
|
|
|
|
destructor TDDDSynCrtSocket.Destroy;
|
|
begin
|
|
FreeAndNil(fSocket);
|
|
fOutput.Done;
|
|
inherited;
|
|
end;
|
|
|
|
procedure TDDDSynCrtSocket.Connect;
|
|
begin
|
|
fSocket.OpenBind(fHost, fPort, False);
|
|
fSocket.CreateSockIn(tlbsCRLF, fInternalBufferSize); // use SockIn safe buffer
|
|
end;
|
|
|
|
function TDDDSynCrtSocket.DataIn(Content: PAnsiChar; ContentLength: integer): integer;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
result := fSocket.SockInRead(Content, ContentLength, false);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDSynCrtSocket.DataInPending(aTimeOut: integer): integer;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
result := fSocket.SockInPending(aTimeOut,{aPendingAlsoInSocket=}true);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDSynCrtSocket.DataOut(Content: PAnsiChar; ContentLength: integer): boolean;
|
|
begin
|
|
fOutput.Lock;
|
|
try
|
|
result := fSocket.TrySndLow(Content, ContentLength);
|
|
finally
|
|
fOutput.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDSynCrtSocket.Identifier: RawUTF8;
|
|
begin
|
|
result := Int32ToUtf8(fSocket.Sock);
|
|
end;
|
|
|
|
function TDDDSynCrtSocket.LastError: RawUTF8;
|
|
begin
|
|
if fSocket.LastLowSocketError=0 then
|
|
result := '' else
|
|
StringToUTF8(SocketErrorMessage(fSocket.LastLowSocketError),result);
|
|
end;
|
|
|
|
function TDDDSynCrtSocket.Handle: integer;
|
|
begin
|
|
result := fSocket.Sock;
|
|
end;
|
|
|
|
|
|
{ TDDDMockedSocket }
|
|
|
|
constructor TDDDMockedSocket.Create(aOwner: TThread);
|
|
begin
|
|
inherited Create;
|
|
fOwner := aOwner;
|
|
end;
|
|
|
|
procedure TDDDMockedSocket.Connect;
|
|
begin
|
|
CheckLatency(mslConnect);
|
|
fSafe.Lock;
|
|
try
|
|
CheckRaiseException(msaConnectRaiseException);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.DataIn(Content: PAnsiChar; ContentLength: integer): integer;
|
|
begin
|
|
CheckLatency(mslDataIn);
|
|
fSafe.Lock;
|
|
try
|
|
CheckRaiseException(msaDataInRaiseException);
|
|
result := length(fInput);
|
|
if ContentLength < result then
|
|
result := ContentLength;
|
|
if result <= 0 then
|
|
exit;
|
|
MoveFast(pointer(fInput)^, Content^, result);
|
|
Delete(fInput, 1, result);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.DataInPending(aTimeOut: integer): integer;
|
|
var
|
|
forcedTimeout: boolean;
|
|
endTix: Int64;
|
|
begin
|
|
forcedTimeout := false;
|
|
endTix := GetTickCount64 + aTimeOut;
|
|
repeat
|
|
fSafe.Lock;
|
|
try
|
|
CheckRaiseException(msaDataInRaiseException);
|
|
if msaDataInPendingFails in fExceptionActions then begin
|
|
fExceptionActions := [];
|
|
result := -1; // cspSocketError
|
|
exit;
|
|
end;
|
|
if not forcedTimeout then
|
|
if msaDataInPendingTimeout in fExceptionActions then begin
|
|
fExceptionActions := [];
|
|
forcedTimeout := true;
|
|
end;
|
|
if forcedTimeout then
|
|
result := 0
|
|
else
|
|
result := length(fInput);
|
|
finally
|
|
fSafe.UnLock; // wait outside the instance lock
|
|
end;
|
|
if (result <> 0) or ((fOwner <> nil) and TSQLRestThread(fOwner).Terminated)
|
|
or (aTimeOut = 0) then
|
|
break;
|
|
SleepHiRes(1); // emulate blocking process, just like a regular socket
|
|
if (fOwner <> nil) and TSQLRestThread(fOwner).Terminated then
|
|
break;
|
|
until GetTickCount64 > endTix; // warning: 10-16 ms resolution under Windows
|
|
end;
|
|
|
|
function TDDDMockedSocket.DataOut(Content: PAnsiChar; ContentLength: integer): boolean;
|
|
var
|
|
previous: integer;
|
|
begin
|
|
CheckLatency(mslDataOut);
|
|
fSafe.Lock;
|
|
try
|
|
CheckRaiseException(msaDataOutRaiseException);
|
|
if msaDataOutReturnsFalse in fExceptionActions then begin
|
|
fExceptionActions := [];
|
|
result := false;
|
|
exit;
|
|
end;
|
|
result := true;
|
|
if ContentLength <= 0 then
|
|
exit;
|
|
previous := length(fOutput);
|
|
SetLength(fOutput, previous + ContentLength);
|
|
MoveFast(Content^, PByteArray(fOutput)^[previous], ContentLength);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.Identifier: RawUTF8;
|
|
begin
|
|
result := PointerToHex(self);
|
|
end;
|
|
|
|
function TDDDMockedSocket.LastError: RawUTF8;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
StringToUTF8(fExceptionMessage, result);
|
|
fExceptionMessage := '';
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDMockedSocket.MockDataIn(const Content: RawByteString);
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
fInput := fInput + Content;
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.MockDataOut: RawByteString;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
result := fOutput;
|
|
fOutput := '';
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDMockedSocket.MockException(NextActions: TDDDMockedSocketExceptions;
|
|
const ExceptionMessage: string; ExceptionClass: ExceptClass);
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
fExceptionActions := NextActions;
|
|
fExceptionMessage := ExceptionMessage;
|
|
fExceptionClass := ExceptionClass;
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDMockedSocket.CheckRaiseException(Action: TDDDMockedSocketException);
|
|
begin
|
|
if not (Action in fExceptionActions) then
|
|
exit;
|
|
fExceptionActions := [];
|
|
if fExceptionMessage = '' then
|
|
FormatString('Mocked Exception for %', [ToText(Action)^], fExceptionMessage);
|
|
if fExceptionClass = nil then
|
|
fExceptionClass := EDDDMockedSocket;
|
|
raise fExceptionClass.Create(fExceptionMessage);
|
|
end;
|
|
|
|
procedure TDDDMockedSocket.MockLatency(NextActions: TDDDMockedSocketLatencies;
|
|
MilliSeconds: integer);
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
fLatencyActions := NextActions;
|
|
fLatencyMS := MilliSeconds;
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDMockedSocket.CheckLatency(Action: TDDDMockedSocketLatency);
|
|
var
|
|
waitMS: integer;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
if Action in fLatencyActions then
|
|
waitMS := fLatencyMS
|
|
else
|
|
waitMS := 0;
|
|
finally
|
|
fSafe.UnLock; // wait outside the instance lock
|
|
end;
|
|
while (waitMS > 0) and not ((fOwner <> nil) and TSQLRestThread(fOwner).Terminated) do begin
|
|
SleepHiRes(1); // do not use GetTickCount64 (poor resolution under Windows)
|
|
dec(waitMS);
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.GetPendingInBytes: integer;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
result := Length(fInput);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.GetPendingOutBytes: integer;
|
|
begin
|
|
fSafe.Lock;
|
|
try
|
|
result := Length(fOutput);
|
|
finally
|
|
fSafe.UnLock;
|
|
end;
|
|
end;
|
|
|
|
function TDDDMockedSocket.Handle: integer;
|
|
begin
|
|
result := 0;
|
|
end;
|
|
|
|
|
|
{ ----- Implements ORM/SOA REST Client access }
|
|
|
|
{ TDDDRestClientSettings }
|
|
|
|
function TDDDRestClientSettings.NewRestClientInstance(aRootSettings:
|
|
TDDDAppSettingsAbstract; aModel: TSQLModel; aOptions: TDDDNewRestInstanceOptions): TSQLRestClientURI;
|
|
var
|
|
pass: RawUTF8;
|
|
begin
|
|
if aModel = nil then
|
|
if riCreateVoidModelIfNone in aOptions then begin
|
|
aModel := TSQLModel.Create([], '');
|
|
include(aOptions, riOwnModel);
|
|
end
|
|
else
|
|
raise EDDDRestClient.CreateUTF8('%.NewRestClientInstance(aModel=nil)', [self]);
|
|
if fClient.Root = '' then // supplied TSQLModel.Root is the default root URI
|
|
fClient.Root := aModel.Root
|
|
else
|
|
aModel.Root := fClient.Root;
|
|
if fORM.Kind = '' then
|
|
fORM.Kind := 'TSQLHttpClientWebsockets'; // assume we need HTTP + callbacks
|
|
if fORM.ServerName = '' then
|
|
fORM.ServerName := 'localhost';
|
|
result := nil;
|
|
try
|
|
try
|
|
result := TSQLRest.CreateTryFrom(aModel, ORM, // will call SetUser()
|
|
riHandleAuthentication in aOptions) as TSQLRestClientURI;
|
|
if result = nil then
|
|
exit; // no match or wrong parameters
|
|
pass := fClient.PasswordPlain;
|
|
if pass <> '' then
|
|
(result as TSQLHttpClientWebsockets).WebSocketsConnect(pass)
|
|
else if not result.ServerTimestampSynchronize then
|
|
raise EDDDRestClient.CreateUTF8('%.Create: HTTP access failure on %/%',
|
|
[self, ORM.ServerName, aModel.Root]);
|
|
result.OnAuthentificationFailed := OnAuthentificationFailed;
|
|
except
|
|
FreeAndNil(result);
|
|
end;
|
|
finally
|
|
if riOwnModel in aOptions then
|
|
if result = nil then // avoid memory leak
|
|
aModel.Free
|
|
else
|
|
aModel.Owner := result;
|
|
if (result = nil) and (riRaiseExceptionIfNoRest in aOptions) then
|
|
raise EDDDRestClient.CreateUTF8('Impossible to initialize % on %/%', [fORM.Kind,
|
|
fORM.ServerName, fClient.Root]);
|
|
end;
|
|
end;
|
|
|
|
function TDDDRestClientSettings.OnAuthentificationFailed(Retry: integer;
|
|
var aUserName, aPassword: string; out aPasswordHashed: boolean): boolean;
|
|
begin
|
|
if (Retry = 1) and (fORM.User <> '') then begin
|
|
aUserName := UTF8ToString(fORM.User);
|
|
aPassword := UTF8ToString(fORM.PasswordPlain);
|
|
aPasswordHashed := true;
|
|
result := true;
|
|
end
|
|
else
|
|
result := false;
|
|
end;
|
|
|
|
procedure TDDDRestClientSettings.SetDefaults(const Root, Port, WebSocketPassword,
|
|
UserPassword, User, Server: RawUTF8; ForceSetCredentials: boolean;
|
|
ConnectRetrySeconds, WebSocketsLoopDelayMS: integer);
|
|
begin
|
|
if fClient.Root = '' then
|
|
fClient.Root := Root;
|
|
if fORM.Kind = '' then
|
|
if WebSocketPassword <> '' then
|
|
fORM.Kind := 'TSQLHttpClientWebsockets'
|
|
else
|
|
fORM.Kind := TSQLHttpClient.ClassName;
|
|
if ForceSetCredentials or (fORM.ServerName = '') then begin
|
|
if fORM.ServerName = '' then
|
|
if Port = '' then
|
|
fORM.ServerName := Server else
|
|
if Server = '' then
|
|
fORM.ServerName := 'http://localhost:' + Port else
|
|
if PosExChar(':', Server) = 0 then
|
|
fORM.ServerName := 'http://' + Server + ':' + Port else
|
|
fORM.ServerName := Server;
|
|
if fClient.WebSocketsPassword = '' then
|
|
fClient.WebSocketsPassword := WebSocketPassword;
|
|
fWebSocketsLoopDelay := WebSocketsLoopDelayMS;
|
|
fClient.ConnectRetrySeconds := ConnectRetrySeconds;
|
|
if UserPassword <> '' then begin
|
|
fORM.User := User;
|
|
fORM.PasswordPlain := UserPassword;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function AdministratedDaemonClient(Definition: TDDDRestClientSettings; Model: TSQLModel): TSQLHttpClientWebsockets;
|
|
begin
|
|
result := Definition.NewRestClientInstance(nil, Model) as TSQLHttpClientWebsockets;
|
|
try
|
|
result.ServiceDefine(IAdministratedDaemon, sicShared);
|
|
except
|
|
result.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TDDDAdministratedDaemonAsProxy }
|
|
|
|
{ FIXME: Proxy feature not finished yet (but not needed any more) }
|
|
|
|
type
|
|
TDDDAdministratedDaemonAsProxy = class(TCQRSService, IAdministratedDaemonAsProxy)
|
|
protected
|
|
fProxy: IAdministratedDaemon;
|
|
fProxyClient: TSQLHttpClientWebsockets;
|
|
/// IAdministratedDaemon methods
|
|
function RetrieveState(out Status: variant): TCQRSResult;
|
|
function Start: TCQRSResult;
|
|
function Stop(out Information: variant): TCQRSResult;
|
|
function Halt(out Information: variant): TCQRSResult;
|
|
function DatabaseList: TRawUTF8DynArray;
|
|
function DatabaseTables(const DatabaseName: RawUTF8): TRawUTF8DynArray;
|
|
function DatabaseExecute(const DatabaseName, SQL: RawUTF8): TServiceCustomAnswer;
|
|
procedure SubscribeLog(const Levels: TSynLogInfos; const Callback:
|
|
ISynLogCallback; ReceiveExistingKB: cardinal);
|
|
procedure CallbackReleased(const callback: IInvokable; const interfaceName: RawUTF8);
|
|
function StartProxy(const aDDDRestClientSettings: variant): TCQRSResult;
|
|
public
|
|
destructor Destroy; override;
|
|
end;
|
|
|
|
procedure TDDDAdministratedDaemonAsProxy.CallbackReleased(const callback:
|
|
IInvokable; const interfaceName: RawUTF8);
|
|
begin
|
|
fProxy.CallbackReleased(callback, interfaceName);
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.DatabaseExecute(const DatabaseName, SQL:
|
|
RawUTF8): TServiceCustomAnswer;
|
|
begin
|
|
result := fProxy.DatabaseExecute(DatabaseName, SQL);
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.DatabaseList: TRawUTF8DynArray;
|
|
begin
|
|
result := fProxy.DatabaseList;
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.DatabaseTables(const DatabaseName:
|
|
RawUTF8): TRawUTF8DynArray;
|
|
begin
|
|
result := fProxy.DatabaseTables(DatabaseName);
|
|
end;
|
|
|
|
destructor TDDDAdministratedDaemonAsProxy.Destroy;
|
|
begin
|
|
fProxy := nil;
|
|
FreeAndNil(fProxyClient);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.Halt(out Information: variant): TCQRSResult;
|
|
begin
|
|
result := fProxy.Halt(Information);
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.RetrieveState(out Status: variant): TCQRSResult;
|
|
begin
|
|
result := fProxy.RetrieveState(Status);
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.Start: TCQRSResult;
|
|
begin
|
|
result := fProxy.Start;
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.StartProxy(const aDDDRestClientSettings:
|
|
variant): TCQRSResult;
|
|
var
|
|
def: TDDDRestClientSettings;
|
|
valid: boolean;
|
|
begin
|
|
CqrsBeginMethod(qaNone, result);
|
|
if (fProxy <> nil) or (fProxyClient <> nil) then begin
|
|
CqrsSetResult(cqrsAlreadyExists,result);
|
|
exit;
|
|
end;
|
|
def := TDDDRestClientSettings.Create;
|
|
try
|
|
JSONToObject(def, pointer(VariantSaveJSON(aDDDRestClientSettings)), valid);
|
|
if not valid then begin
|
|
CqrsSetResultMsg(cqrsBadRequest, '%.StartProxy(%): invalid def', [self,
|
|
aDDDRestClientSettings],result);
|
|
exit;
|
|
end;
|
|
try
|
|
fProxyClient := AdministratedDaemonClient(def);
|
|
if not fProxyClient.Services.Resolve(IAdministratedDaemon, fProxy) then
|
|
raise EDDDRestClient.CreateUTF8('%.StartProxy(%): IAdministratedDaemon not supported',
|
|
[self, aDDDRestClientSettings]);
|
|
CqrsSetResult(cqrsSuccess,result);
|
|
except
|
|
on E: Exception do begin
|
|
fProxy := nil;
|
|
FreeAndNil(fProxyClient);
|
|
CqrsSetResult(E,result);
|
|
end;
|
|
end;
|
|
finally
|
|
def.Free;
|
|
end;
|
|
end;
|
|
|
|
function TDDDAdministratedDaemonAsProxy.Stop(out Information: variant): TCQRSResult;
|
|
begin
|
|
result := fProxy.Stop(Information);
|
|
end;
|
|
|
|
procedure TDDDAdministratedDaemonAsProxy.SubscribeLog(const Levels: TSynLogInfos;
|
|
const Callback: ISynLogCallback; ReceiveExistingKB: cardinal);
|
|
begin
|
|
fProxy.SubscribeLog(Levels, Callback, ReceiveExistingKB);
|
|
end;
|
|
|
|
function AdministratedDaemonClientFromProxy(Definition: TDDDRestClientSettings;
|
|
const ProxyIPPort: RawUTF8; Model: TSQLModel = nil): IAdministratedDaemon;
|
|
var
|
|
proxy: TDDDRestClientSettings;
|
|
client: TSQLHttpClientWebsockets;
|
|
temp: IAdministratedDaemonAsProxy;
|
|
res: TCQRSResult;
|
|
begin
|
|
proxy := TDDDRestClientSettings.Create;
|
|
try
|
|
CopyObject(Definition, proxy); // share same connection credentials
|
|
proxy.ORM.ServerName := ProxyIPPort;
|
|
client := proxy.NewRestClientInstance(nil, Model) as TSQLHttpClientWebsockets;
|
|
finally
|
|
proxy.Free;
|
|
end;
|
|
try
|
|
client.ServiceDefine(IAdministratedDaemonAsProxy, sicClientDriven);
|
|
client.Services.Resolve(IAdministratedDaemonAsProxy, temp);
|
|
res := temp.StartProxy(_ObjFast(Definition));
|
|
if res <> cqrsSuccess then
|
|
raise EDDDRestClient.CreateUTF8(
|
|
'AdministratedDaemonClientFromProxy(%) was not able to proxy via %: %',
|
|
[Definition.ORM.ServerName, ProxyIPPort, ToText(res)^]);
|
|
result := temp;
|
|
except
|
|
client.Free;
|
|
raise;
|
|
end;
|
|
end;
|
|
|
|
function AdministratedDaemonServer(Settings: TDDDAdministratedDaemonSettings;
|
|
DaemonClass: TDDDAdministratedDaemonClass): TDDDAdministratedDaemon;
|
|
begin
|
|
if DaemonClass = nil then
|
|
raise EDDDInfraException.Create('AdministratedDaemonServer(DaemonClass=nil)');
|
|
if Settings = nil then
|
|
raise EDDDInfraException.Create('AdministratedDaemonServer(Settings=nil)');
|
|
with Settings.RemoteAdmin do
|
|
result := DaemonClass.Create(AuthUserName, AuthHashedPassword, AuthRootURI, AuthNamedPipeName);
|
|
result.InternalSettings := Settings;
|
|
if Settings.Storage is TDDDAppSettingsStorageFile then
|
|
result.InternalSettingsFolder := ExtractFilePath(
|
|
TDDDAppSettingsStorageFile(Settings.Storage).SettingsJsonFileName);
|
|
{$ifdef WITHLOG}
|
|
result.Log.SynLog.Log(sllTrace, '%.Create(%)', [DaemonClass, Settings], result);
|
|
{$endif}
|
|
with Settings.RemoteAdmin do
|
|
if AuthHttp.BindPort <> '' then
|
|
result.AdministrationHTTPServer := TSQLHttpServer.Create(
|
|
result.AdministrationServer, AuthHttp);
|
|
end;
|
|
|
|
|
|
{ ----- Applications Securization }
|
|
|
|
function ToText(auth: TECCAuthorize): PShortString;
|
|
begin
|
|
result := GetEnumName(TypeInfo(TECCAuthorize), ord(auth));
|
|
end;
|
|
|
|
function ECCAuthorize(aContent: TObject; aSecretDays: integer; const aSecretPass,
|
|
aDPAPI, aDecryptSalt, aAppLockPublic64: RawUTF8; const aSearchFolder: TFileName;
|
|
aSecretInfo: PECCCertificateSigned; aLocalFile: PFileName): TECCAuthorize;
|
|
var
|
|
fileroot, fileunlock, filesecret, filepublic: TFileName;
|
|
priv, new: TECCCertificateSecret;
|
|
auth: TECCCertificate;
|
|
signature: TECCSignatureCertifiedContent;
|
|
unlock, secret, temp, json: RawByteString;
|
|
decrypt: TECCDecrypt;
|
|
hash: THash256;
|
|
valid: TECCValidity;
|
|
issuer: TECCCertificateIssuer;
|
|
privok, jsonok: boolean;
|
|
begin
|
|
with ExeVersion do
|
|
fileroot := SysUtils.LowerCase(FormatString('%@%', [User, Host]));
|
|
if aSearchFolder = '' then
|
|
fileroot := ExeVersion.ProgramFilePath + fileroot else
|
|
fileroot := IncludeTrailingPathDelimiter(aSearchFolder) + fileroot;
|
|
if aLocalFile <> nil then
|
|
aLocalFile^ := fileroot;
|
|
fileunlock := fileroot + '.unlock';
|
|
filepublic := fileroot + ECCCERTIFICATEPUBLIC_FILEEXT;
|
|
filesecret := fileroot + '.secret'; // DPAPI-encrypted .private file
|
|
try
|
|
unlock := StringFromFile(fileunlock);
|
|
secret := StringFromFile(filesecret);
|
|
temp := CryptDataForCurrentUser(secret, aDPAPI, false);
|
|
priv := TECCCertificateSecret.Create;
|
|
try
|
|
result := eaInvalidSecret;
|
|
{$ifdef ENHANCEDRTL} {$ifdef VER150}
|
|
if crc32cinlined($D26BE33F,@ECCAuthorize,14)<>$29743A4B then
|
|
exit; // avoid stubbing (Delphi 7 ERTL only - just to show how it works)
|
|
{$endif} {$endif}
|
|
ECCIssuer(ExeVersion.User,Issuer);
|
|
privok := priv.LoadFromSecureBinary(temp, aSecretPass, 100) and
|
|
IsEqual(priv.Content.Signed.Issuer, Issuer);
|
|
if aSecretInfo <> nil then
|
|
aSecretInfo^ := priv.Content.Signed;
|
|
if not privok or not ECCCheckDate(priv.Content) then begin
|
|
new := TECCCertificateSecret.CreateNew(nil, ExeVersion.User, aSecretDays);
|
|
try
|
|
new.ToFile(filepublic);
|
|
temp := new.SaveToSecureBinary(aSecretPass, 7, 100);
|
|
secret := CryptDataForCurrentUser(temp, aDPAPI, true);
|
|
FileFromString(secret, filesecret);
|
|
finally
|
|
new.Free;
|
|
end;
|
|
exit;
|
|
end;
|
|
result := eaMissingUnlockFile;
|
|
if unlock = '' then
|
|
exit;
|
|
result := eaInvalidUnlockFile;
|
|
decrypt := priv.Decrypt(unlock, json, @signature, nil, nil, aDecryptSalt, 10000);
|
|
if decrypt <> ecdDecryptedWithSignature then
|
|
exit;
|
|
auth := TECCCertificate.CreateFromBase64(aAppLockPublic64);
|
|
try
|
|
hash := SHA256Digest(pointer(json), length(json));
|
|
valid := ECCVerify(signature, hash, auth.Content);
|
|
if not (valid in ECC_VALIDSIGN) then
|
|
exit;
|
|
finally
|
|
auth.Free;
|
|
end;
|
|
finally
|
|
priv.Free;
|
|
end;
|
|
RemoveCommentsFromJSON(pointer(json));
|
|
JSONToObject(aContent, pointer(json), jsonok, nil, JSONTOOBJECT_TOLERANTOPTIONS);
|
|
if jsonok then
|
|
result := eaSuccess
|
|
else
|
|
result := eaInvalidJson;
|
|
finally
|
|
FillZero(hash);
|
|
FillZero(json);
|
|
FillZero(unlock);
|
|
FillZero(temp);
|
|
FillZero(secret);
|
|
end;
|
|
end;
|
|
|
|
|
|
{ TDDDRestClientWebSockets }
|
|
|
|
constructor TDDDRestClientWebSockets.Create(aSettings: TDDDRestClientSettings;
|
|
aOnConnect, aOnDisconnect: TOnRestClientNotify);
|
|
var
|
|
u: TURI;
|
|
t: integer;
|
|
log: ISynLog;
|
|
begin
|
|
DefineApplication; // should fill fApplicationName
|
|
fOnFailed := ClientFailed;
|
|
fOnSetUser := ClientSetUser;
|
|
fOnConnect := aOnConnect;
|
|
fOnDisconnect := aOnDisconnect;
|
|
fOnWebSocketsClosed := WebSocketsClosed;
|
|
if aSettings = nil then
|
|
raise EDDDRestClient.CreateUTF8('%.Create(%) aSettings=nil', [fApplicationName, self]);
|
|
if not u.From(aSettings.ORM.ServerName) then
|
|
raise EDDDRestClient.CreateUTF8('%.Create(%): invalid ORM.ServerName=%',
|
|
[self, fApplicationName, aSettings.ORM.ServerName]);
|
|
log := SQLite3Log.Enter('Create(%): connect to %', [fApplicationName, aSettings.ORM.ServerName], self);
|
|
t := aSettings.Timeout;
|
|
fConnectRetrySeconds := aSettings.Client.ConnectRetrySeconds;
|
|
inherited Create(u.Server, u.Port, CreateModel(aSettings), u.Https, '', '', t, t, t);
|
|
Model.Owner := self; // just allocated by CreateModel()
|
|
if aSettings.Client.WebSocketsPassword <> '' then begin
|
|
fWebSocketLoopDelay := aSettings.WebSocketsLoopDelay;
|
|
WebSocketsConnect(aSettings.Client.PasswordPlain);
|
|
end;
|
|
OnAuthentificationFailed := aSettings.OnAuthentificationFailed;
|
|
if aSettings.ORM.Password = '' then
|
|
RegisterServices // plain REST connection without authentication
|
|
else
|
|
if not SetUser(aSettings.ORM.User, aSettings.ORM.PasswordPlain, true) then
|
|
raise EDDDRestClient.CreateUTF8('%.Create(%): invalid User=%',
|
|
[self, fApplicationName, aSettings.ORM.User]);
|
|
end;
|
|
|
|
destructor TDDDRestClientWebSockets.Destroy;
|
|
begin
|
|
with fLogClass.Enter(self, 'Destroy') do
|
|
try
|
|
ClientDisconnect;
|
|
finally
|
|
inherited Destroy;
|
|
fOwnedSettings.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDRestClientWebSockets.AfterConnection;
|
|
begin // do nothing by default
|
|
end;
|
|
|
|
procedure TDDDRestClientWebSockets.AfterDisconnection;
|
|
begin // do nothing by default
|
|
end;
|
|
|
|
procedure TDDDRestClientWebSockets.ClientDisconnect;
|
|
var
|
|
log: ISynLog;
|
|
begin
|
|
if not fConnected then
|
|
exit; // notify once
|
|
log := fLogClass.Enter('ClientDisconnect(%)', [fApplicationName], self);
|
|
fConnected := false;
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ClientDisconnect -> AfterDisconnection', self);
|
|
try
|
|
AfterDisconnection;
|
|
except
|
|
if log<>nil then
|
|
log.Log(sllWarning, 'Ignored AfterDisconnection exception', self);
|
|
end;
|
|
if Assigned(fOnDisconnect) then
|
|
try
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ClientDisconnect -> OnDisconnect = %',
|
|
[ToText(TMethod(fOnDisconnect))], self);
|
|
fOnDisconnect(self);
|
|
except
|
|
if log<>nil then
|
|
log.Log(sllWarning, 'Ignored OnDisconnect exception', self);
|
|
end;
|
|
end;
|
|
|
|
procedure TDDDRestClientWebSockets.ClientFailed(Sender: TSQLRestClientURI;
|
|
E: Exception; Call: PSQLRestURIParams);
|
|
begin
|
|
if Assigned(Call) and (Call^.OutStatus = HTTP_NOTIMPLEMENTED) then
|
|
ClientDisconnect;
|
|
end;
|
|
|
|
procedure TDDDRestClientWebSockets.ClientSetUser(Sender: TSQLRestClientURI);
|
|
var
|
|
log, log2: ISynLog;
|
|
begin
|
|
if Assigned(Sender) and Assigned(Sender.SessionUser) then begin
|
|
log := fLogClass.Enter('ClientSetUser(%) %',
|
|
[fApplicationName, Sender.SessionUser], self);
|
|
ClientDisconnect;
|
|
fConnected := true;
|
|
fSessionVersion := '';
|
|
if not fServicesRegistered then begin
|
|
log2 := fLogClass.Enter('RegisterServices', [], self);
|
|
RegisterServices;
|
|
log2 := nil;
|
|
fServicesRegistered := true;
|
|
end;
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ClientSetUser -> AfterConnection', self);
|
|
try
|
|
AfterConnection;
|
|
except
|
|
if log<>nil then
|
|
log.Log(sllWarning, 'Ignored AfterConnection exception', self);
|
|
end;
|
|
if Assigned(fOnConnect) then
|
|
try
|
|
if log<>nil then
|
|
log.Log(sllTrace, 'ClientSetUser -> OnConnect = %',
|
|
[ToText(TMethod(fOnConnect))], self);
|
|
fOnConnect(self);
|
|
except
|
|
if log<>nil then
|
|
log.Log(sllWarning, 'Ignored OnConnect exception', self);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function TDDDRestClientWebSockets.CreateModel(aSettings: TDDDRestClientSettings): TSQLModel;
|
|
begin // create a void data model by default
|
|
result := TSQLModel.Create([], aSettings.Client.Root);
|
|
end;
|
|
|
|
procedure TDDDRestClientWebSockets.WebSocketsClosed(Sender: TObject);
|
|
begin
|
|
ClientDisconnect;
|
|
end;
|
|
|
|
|
|
initialization
|
|
TJSONSerializer.RegisterObjArrayForJSON(
|
|
[TypeInfo(TECCCertificateObjArray),TECCCertificate]);
|
|
{$ifdef DEBUG}
|
|
{$ifdef EnableMemoryLeakReporting}
|
|
{$ifdef HASFASTMM4} // FastMM4 integrated in Delphi 2006 (and up)
|
|
ReportMemoryLeaksOnShutdown := True;
|
|
{$endif}
|
|
{$endif}
|
|
{$endif}
|
|
end.
|
|
|