Varela_PuntosVenta/Source/Modulos/FicherosEDI/Cliente/uSubirFicheros.pas

unit uSubirFicheros;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  uROClient, uROClientIntf, uRORemoteService, uROBinMessage,
  uROServiceComponent, uROWinInetHttpChannel,
  VARELA_Intf, uROTypes;

type

  { TROThread }
  TSubirFicheroThread = class(TThread)
  private
    fROMessage: TROBinMessage;
    fROChannel: TROWinInetHTTPChannel;
    fRORemoteService: TRORemoteService;
    fOnAbort: TNotifyEvent;
    fOnFinished: TNotifyEvent;
    fOnProgress: TNotifyEvent;
    fOnStartUpload: TNotifyEvent;
    fOnError: TNotifyEvent;
    fFileName: string;
    fUploadOK: Boolean;
    fFileSize: Int64;
    fCurrentBytePos: Int64;
    fTimeStarted: TDateTime;
    fFileService: IsrvTransfereciaFicheros;
    fErrorText: string;
    fInfoStr: string;
    fMaxConnectionErrors, fChannelErrorscount: Integer;
    procedure RunUpload;
    function GetUploadChunk(FileMemStream: TMemoryStream; aSize: Int64;
      const Sequence: Integer): Binary;
    procedure OnChannelFailure(Sender: TROTransportChannel;
      anException: Exception; var Retry: Boolean);
    procedure Run;
  protected
  public
    property UploadOK: Boolean read fUploadOK;
    property FileSize: Int64 read fFileSize;
    property CurrentBytePos: Int64 read fCurrentBytePos;
    property TimeStarted: TDateTime read fTimeStarted;
    property ErrorText: string read fErrortext;
    property Filename: string read fFilename;
    property InfoStr: string read fInfoStr;
    constructor Create(aFileName: string; aOnStartUpload, aOnProgress,
      aOnFinished, aOnAbort, aOnError: TNotifyEvent);
    destructor Destroy; override;

    procedure Execute; override;
  end;

implementation

uses
  uDataModuleBase;
  
{ TROThread }

constructor TSubirFicheroThread.Create(aFileName: string; aOnStartUpload, aOnProgress,
  aOnFinished, aOnAbort, aOnError: TNotifyEvent);
begin
  inherited Create(TRUE);
  fFilename := aFilename;
  fmaxconnectionerrors := 5; //try 5 times on channel-error

  fROMessage := TROBinMessage.Create(nil);
  fROChannel := TROWinInetHTTPChannel.Create(NIL);
  fROChannel.OnFailure := OnChannelFailure;
  fROChannel.TargetURL := dmBase.Channel.TargetURL;

  fRORemoteService := TRORemoteService.Create(nil);
  fRORemoteService.Channel := fROChannel;
  fRORemoteService.Message := fROMessage;
  fRORemoteService.ServiceName := 'srvTransfereciaFicheros';
  fFileService := fRORemoteService as IsrvTransfereciaFicheros;

  if assigned(aOnAbort) then
    fOnAbort := aOnAbort;
  if assigned(aOnFinished) then
    fOnFinished := aOnFinished;
  if assigned(aOnProgress) then
    fOnProgress := aOnProgress;
  if assigned(aOnStartUpload) then
    fOnStartUpload := aOnStartUpload;
  if assigned(aOnError) then
    fOnError := aOnError;
  Resume;
end;

destructor TSubirFicheroThread.Destroy;
begin
  fFileService := nil;
  fROChannel.OnFailure := NIL;

  FreeAndNil(fRORemoteService);
  FreeAndNil(fROChannel);
  FreeAndNil(fROMessage);
  inherited;
end;

procedure TSubirFicheroThread.Run;
begin
  try
    RunUpload;
  finally
    if assigned(fOnFinished) then
      fOnFinished(Self);
  end;
end;

procedure TSubirFicheroThread.Execute;
begin
  try
    Run;
  finally
    Self.Destroy;
  end;
end;

function TSubirFicheroThread.GetUploadChunk(FileMemStream: TMemoryStream; aSize:
  Int64; const Sequence: Integer): Binary;
const
  Block: Integer = 65536;
var
  Position: Int64;
begin
  Result := Binary.Create;
  Position := Block * (Sequence - 1);
  if Position <= aSize then
  begin
    FileMemStream.Position := Position;
    if Position + Block > aSize then
      Result.CopyFrom(FileMemStream, aSize - Position)
    else
      Result.CopyFrom(FileMemStream, Block);
  end;
end;

procedure TSubirFicheroThread.RunUpload;
var
  FileMemStream: TMemoryStream;
  Chunk: Binary;
  Sequence: Int64;
  isfirst: Boolean;
begin
  fErrorText := '';
  fUploadOK := false;
  fChannelErrorscount := 0;
  fCurrentBytePos := 0;
  Sequence := 1;
  fTimeStarted := Now;
  FileMemStream := nil;
  isfirst := true;
  try
    if FileExists(fFilename) then
    begin
      try
        FileMemStream := TMemoryStream.Create;
        FileMemStream.LoadFromFile(fFileName);
        fFileName := ExtractFileName(fFileName);
        fFileSize := FileMemStream.Size;

        fInfoStr := DateTimetoStr(fTimeStarted) + ' ' +
          fFileName + ' ' +
          FloatToStrF(Filesize / 1024, fffixed, 15, 1) + ' KB';

        if assigned(fOnStartUpload) then
          fOnStartUpload(Self);
        Chunk := GetUploadChunk(FileMemStream, fFileSize, Sequence);
        try
          while Chunk.Size > 0 do
          begin
            if Terminated then
            begin
              if assigned(fOnAbort) then
                fOnAbort(Self);
              exit;
            end;
            fFileService.uploadChunk(isfirst, fFileName, Chunk);
            isfirst := false;

            Inc(fCurrentBytePos, Chunk.Size);
            FreeAndNil(Chunk);

            Inc(Sequence);
            if assigned(fOnProgress) then
              fOnProgress(Self);
            Chunk := GetUploadChunk(FileMemStream, fFileSize, Sequence);
          end;
          fUploadOK := (FileSize > 0) and (FileSize = CurrentBytePos);
        finally
          FreeAndNil(Chunk);
        end;
      finally
        FileMemStream.Free;
      end;
    end
    else begin
      fErrorText := 'No existe el fichero ' + fFileName;
      if assigned(fOnError) then
        fOnError(Self);
    end;
  except
    on e: Exception do
    begin
      fErrorText := e.Message;
      if assigned(fOnError) then
        fOnError(Self);
    end;
  end;
end;

procedure TSubirFicheroThread.OnChannelFailure(Sender: TROTransportChannel;
  anException: Exception; var Retry: Boolean);
begin
  if FChannelErrorsCount > FMaxConnectionErrors then
  begin
    FErrorText := anException.Message;
    Self.Terminate;
  end
  else
  begin
    Inc(FChannelErrorsCount);
    Sleep(1000);
    Retry := true;
  end;
end;

end.