365 lines
9.5 KiB
ObjectPascal
365 lines
9.5 KiB
ObjectPascal
unit uDataModuleServer;
|
|
|
|
interface
|
|
|
|
uses
|
|
SysUtils, Classes, uDAEngine, uDAIBXDriver, uDAClasses, uDADriverManager,
|
|
uROClient, uROBinMessage, uROServer, uROIndyTCPServer, uROIndyHTTPServer,
|
|
uROSessions, uDADataTable, uDABINAdapter, IBSQLMonitor, JvComponent,
|
|
JvAppStorage, JvAppRegistryStorage, uDAInterfaces,
|
|
JvComponentBase, uDAADODriver, uROEventRepository, uDAServerLog, ExceptionLog,
|
|
JvLogFile, SyncObjs;
|
|
|
|
const
|
|
SERVER_PORT = '8099';
|
|
|
|
type
|
|
TdmServer = class(TDataModule)
|
|
HTTPServer: TROIndyHTTPServer;
|
|
BINMessage: TROBinMessage;
|
|
DriverManager: TDADriverManager;
|
|
DADiagrams: TDADiagrams;
|
|
JvAppRegistryStorage: TJvAppRegistryStorage;
|
|
DAADODriver: TDAADODriver;
|
|
SessionManager: TROInMemorySessionManager;
|
|
ConnectionManager: TDAConnectionManager;
|
|
DAServerLog1: TDAServerLog;
|
|
JvLogFile1: TJvLogFile;
|
|
DataDictionary: TDADataDictionary;
|
|
procedure DataModuleCreate(Sender: TObject);
|
|
procedure DataModuleDestroy(Sender: TObject);
|
|
procedure HTTPServerBeforeServerActivate(Sender: TObject);
|
|
procedure DAServerLog1AddSQLCommandLog(Sender: TDAServerLog;
|
|
SQLCommandLog: TDASQLCommandLog);
|
|
procedure DAServerLog1AddSQLErrorLog(Sender: TDAServerLog;
|
|
SQLErrorLog: TDASQLErrorLog);
|
|
procedure DriverManagerTraceEvent(Sender: TObject; const Text: string;
|
|
Tag: Integer);
|
|
private
|
|
FConnectionName : string;
|
|
FEscribirLog : TCriticalSection;
|
|
function GetConnectionString: string;
|
|
procedure FindFiles(StartDir: string; var FilesList: TStringList);
|
|
procedure IniciarLog;
|
|
procedure DetenerLog;
|
|
|
|
public
|
|
FDBServer : string;
|
|
FDBName : string;
|
|
FDBUser : string;
|
|
FDBPass : string;
|
|
FInicioWindows : Boolean;
|
|
FServerPort : string;
|
|
FDirEntrada : String;
|
|
FDirAlmacen : String;
|
|
FDias : Integer;
|
|
procedure LeerConfiguracion;
|
|
procedure SalvarConfiguracion;
|
|
procedure RefrescarConexion;
|
|
procedure BorrarFicherosDeCargaAntiguos;
|
|
procedure EscribirLog(const AMensaje : String);
|
|
property ConnectionName : string read FConnectionName write FConnectionName;
|
|
end;
|
|
|
|
|
|
function DarRutaInformes : String;
|
|
function Encrypt (const Source : string) : String;
|
|
function Decrypt (const Source : string) : String;
|
|
function GetNextAutoinc(AConnection : IDAConnection; const GeneratorName: string): integer;
|
|
function GetTempDirectory(ABasePath : string) : string ;
|
|
|
|
|
|
var
|
|
dmServer: TdmServer;
|
|
|
|
implementation
|
|
|
|
{$R *.dfm}
|
|
|
|
uses
|
|
DateUtils, JclFileUtils, ActiveX, Forms, fServerForm, Registry, Windows, Dialogs,
|
|
ADODB;
|
|
|
|
|
|
function GetTempDirectory(ABasePath : string) : string ;
|
|
var
|
|
fTime : TDateTime;
|
|
sFile : String;
|
|
Begin
|
|
Result := '' ;
|
|
|
|
fTime := Frac(Now) ;
|
|
sFile := 'TMP' + Copy(FormatFloat('#.########', fTime), 5, 5);
|
|
|
|
while FileExists(ABasePath + PathDelim + sFile) do
|
|
begin
|
|
fTime := Frac(Now);
|
|
sFile := 'TMP'+Copy(FormatFloat('#.########', fTime), 5, 5);
|
|
end;
|
|
Result := sFile ;
|
|
end;
|
|
|
|
Function AddBS(s:String): String;
|
|
Begin
|
|
If Copy(s,Length(s),1)<>'\' Then
|
|
s := s + '\' ;
|
|
Result := s ;
|
|
End;
|
|
|
|
function DarRutaInformes : String;
|
|
begin
|
|
Result := ExtractFilePath(Application.ExeName) + 'Informes' + PathDelim;
|
|
end;
|
|
|
|
function GetNextAutoinc(AConnection : IDAConnection; const GeneratorName: string): integer;
|
|
var
|
|
ds: IDADataset;
|
|
begin
|
|
ds := AConnection.NewDataset(Format('SELECT Gen_id(%s,1) FROM RDB$Database', [GeneratorName]));
|
|
ds.Open;
|
|
result := ds.Fields[0].Value;
|
|
ds.Close;
|
|
end;
|
|
|
|
procedure WriteAutoRun(Name, Value : String);
|
|
var
|
|
reg: TRegistry;
|
|
begin
|
|
reg := TRegistry.Create;
|
|
try
|
|
reg.RootKey := HKEY_LOCAL_MACHINE;
|
|
reg.LazyWrite := False;
|
|
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', False);
|
|
reg.WriteString(Name, Value);
|
|
reg.CloseKey;
|
|
finally
|
|
reg.free;
|
|
end;
|
|
end;
|
|
|
|
procedure DeleteAutoRun(Name : String);
|
|
var
|
|
reg: TRegistry;
|
|
begin
|
|
reg := TRegistry.Create;
|
|
try
|
|
reg.RootKey := HKEY_LOCAL_MACHINE;
|
|
reg.LazyWrite := False;
|
|
reg.OpenKey('Software\Microsoft\Windows\CurrentVersion\Run', False);
|
|
if reg.ValueExists(Name) then
|
|
reg.DeleteValue(Name);
|
|
reg.CloseKey;
|
|
finally
|
|
reg.free;
|
|
end;
|
|
end;
|
|
|
|
|
|
function Encrypt (const Source : string) : String;
|
|
var
|
|
i:integer;
|
|
begin
|
|
Randseed := 28;
|
|
Result := '';
|
|
for i:=1 to length(Source) do
|
|
Result := Result + chr(ord(Source[i]) + Random(10) + 1);
|
|
end;
|
|
|
|
function Decrypt (const Source : string) : String;
|
|
var
|
|
i : integer;
|
|
begin
|
|
Randseed:= 28;
|
|
Result := '';
|
|
for i := 1 to length(Source) do
|
|
Result := Result + chr(ord(Source[i]) - Random(10) - 1);
|
|
end;
|
|
|
|
procedure TdmServer.DAServerLog1AddSQLCommandLog(Sender: TDAServerLog;
|
|
SQLCommandLog: TDASQLCommandLog);
|
|
begin
|
|
EscribirLog(SQLCommandLog.OriginalSQLText);
|
|
EscribirLog(SQLCommandLog.OriginalSQLText);
|
|
EscribirLog('-----------------------------------------------------');
|
|
end;
|
|
|
|
procedure TdmServer.DAServerLog1AddSQLErrorLog(Sender: TDAServerLog;
|
|
SQLErrorLog: TDASQLErrorLog);
|
|
begin
|
|
EscribirLog(SQLErrorLog.ErrorMessage);
|
|
EscribirLog(SQLErrorLog.OriginalSQLText);
|
|
EscribirLog(SQLErrorLog.OriginalSQLText);
|
|
EscribirLog('-----------------------------------------------------');
|
|
end;
|
|
|
|
procedure TdmServer.DataModuleCreate(Sender: TObject);
|
|
begin
|
|
LeerConfiguracion;
|
|
RefrescarConexion;
|
|
IniciarLog;
|
|
end;
|
|
|
|
function TdmServer.GetConnectionString: string;
|
|
begin
|
|
{ Result := 'SDAC?Server=' + FDBServer
|
|
+ ';Database=' + FDBName
|
|
+ ';UserID=' + FDBUser
|
|
+ ';Password=' + Decrypt(FDBPass);}
|
|
|
|
Result := 'ADO?AuxDriver=SQLOLEDB.1;Server=' + FDBServer
|
|
+ ';Database=' + FDBName
|
|
+ ';UserID=' + FDBUser
|
|
+ ';Password=' + Decrypt(FDBPass);
|
|
end;
|
|
|
|
procedure TdmServer.LeerConfiguracion;
|
|
begin
|
|
with JvAppRegistryStorage do
|
|
begin
|
|
FDBServer := ReadString('ServerDB');
|
|
FDBName := ReadString('DBName');
|
|
FDBUser := ReadString('UserDB');
|
|
FDBPass := ReadString('PassDB');
|
|
|
|
FServerPort := ReadString('ServerPort', SERVER_PORT);
|
|
FInicioWindows := ReadBoolean('InicioWindows');
|
|
|
|
FDirEntrada := ReadString('DirEntradaEDI');
|
|
FDirAlmacen := ReadString('DirAlmacenEDI');
|
|
FDias := ReadInteger('DiasAlmacenEDI', 1);
|
|
end;
|
|
end;
|
|
|
|
procedure TdmServer.SalvarConfiguracion;
|
|
begin
|
|
with JvAppRegistryStorage do
|
|
begin
|
|
BeginUpdate;
|
|
try
|
|
WriteString('ServerDB', FDBServer);
|
|
WriteString('DBName', FDBName);
|
|
WriteString('UserDB', FDBUser);
|
|
WriteString('PassDB', FDBPass);
|
|
WriteString('ServerPort', FServerPort);
|
|
|
|
WriteString('DirEntradaEDI', FDirEntrada);
|
|
WriteString('DirAlmacenEDI', FDirAlmacen);
|
|
WriteInteger('DiasAlmacenEDI', FDias);
|
|
|
|
WriteBoolean('InicioWindows', FInicioWindows);
|
|
if FInicioWindows then
|
|
WriteAutoRun('AdminPV_Server', Application.ExeName)
|
|
else
|
|
DeleteAutoRun('AdminPV_Server');
|
|
finally
|
|
EndUpdate
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TdmServer.DataModuleDestroy(Sender: TObject);
|
|
begin
|
|
SessionManager.ClearSessions(False);
|
|
HTTPServer.Active := False;
|
|
DetenerLog;
|
|
end;
|
|
|
|
procedure TdmServer.DetenerLog;
|
|
begin
|
|
FEscribirLog.Free;
|
|
end;
|
|
|
|
procedure TdmServer.DriverManagerTraceEvent(Sender: TObject; const Text: string;
|
|
Tag: Integer);
|
|
begin
|
|
EscribirLog(Text + #10#13 + #10#13);
|
|
end;
|
|
|
|
procedure TdmServer.EscribirLog(const AMensaje: String);
|
|
begin
|
|
FEscribirLog.Acquire;
|
|
try
|
|
JvLogFile1.Add(AMensaje);
|
|
finally
|
|
FEscribirLog.Release;
|
|
end;
|
|
end;
|
|
|
|
procedure TdmServer.RefrescarConexion;
|
|
begin
|
|
HTTPServer.Active := False;
|
|
ConnectionManager.Connections.GetDefaultConnection.ConnectionString := '';
|
|
|
|
ConnectionName := ConnectionManager.GetDefaultConnectionName;
|
|
ConnectionManager.Connections.GetDefaultConnection.ConnectionString := GetConnectionString;
|
|
CoInitialize(nil);
|
|
HTTPServer.Active := TRUE;
|
|
end;
|
|
|
|
procedure TdmServer.HTTPServerBeforeServerActivate(Sender: TObject);
|
|
begin
|
|
HTTPServer.Port := StrToInt(FServerPort);
|
|
end;
|
|
|
|
procedure TdmServer.IniciarLog;
|
|
begin
|
|
FEscribirLog := TCriticalSection.Create;
|
|
|
|
JvLogFile1.Active := False;
|
|
JvLogFile1.FileName := ExtractFilePath(Application.ExeName) + 'ServerLog.txt';
|
|
JvLogFile1.AutoSave := True;
|
|
JvLogFile1.Active := True;
|
|
JvLogFile1.Clear;
|
|
end;
|
|
|
|
procedure TdmServer.BorrarFicherosDeCargaAntiguos;
|
|
var
|
|
AAlmacen : String;
|
|
ADate : TDateTime;
|
|
FilesList: TStringList;
|
|
i: integer;
|
|
begin
|
|
ADate := Now;
|
|
IncDay(ADate,((-1)*FDias)); //Establecemos fecha desde la que eliminaremos
|
|
|
|
AAlmacen := PathAddSeparator(FDirAlmacen);
|
|
FilesList := TStringList.Create;
|
|
try
|
|
FindFiles(AAlmacen, FilesList);
|
|
for i:=0 to FilesList.Count-1 do
|
|
begin
|
|
// showmessage(FilesList.Strings[i]);
|
|
DeleteDirectory(FilesList.Strings[i], false)
|
|
end;
|
|
finally
|
|
FreeAndNil(FilesList);
|
|
end
|
|
end;
|
|
|
|
procedure TdmServer.FindFiles(StartDir: string; var FilesList: TStringList);
|
|
const
|
|
MASK_ALL_FILES = '*.*';
|
|
CHAR_POINT = '.';
|
|
var
|
|
SR: TSearchRec;
|
|
IsFound: Boolean;
|
|
ADateTime: TDateTime;
|
|
begin
|
|
StartDir := PathAddSeparator(StartDir);
|
|
|
|
IsFound := (FindFirst(StartDir + MASK_ALL_FILES, faAnyFile, SR) = 0);
|
|
while IsFound do
|
|
begin
|
|
if (SR.Name[1] <> CHAR_POINT) then
|
|
begin
|
|
ADateTime := FileDateToDateTime(SR.Time);
|
|
if (DaysBetween(ADateTime, Now) > FDias) then
|
|
FilesList.Add(StartDir + SR.Name);
|
|
end;
|
|
IsFound := (FindNext(SR) = 0);
|
|
end;
|
|
SysUtils.FindClose(SR);
|
|
end;
|
|
|
|
end.
|