Varela_PuntosVenta/Source/Servidor/uDataModuleServer.pas

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,
  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.