Многопоточный лаунчер с обновлением на WinAPI

unit uUpdater;
 
interface
 
uses SysUtils, Windows, WinSock, ShellApi;
 
type
  TUpdater = class
  private
  type
  RCommand = record
    A: Integer;
    B: Integer;
    C: Integer;
    D: Integer;
    end;
  RFile = record
    Name: String[255];
    Size: Integer;
    FTime: Cardinal;
    CTime: Cardinal;
    Handle: Cardinal;
    Loaded: Integer;
    Num: Integer;
    n: Boolean;
    end;
  AFiles = array[0..65535] of RFile;
  PFiles = ^AFiles;
 
  var
    xThId: Cardinal;
    xThHandle: Cardinal;
    xTerminated: Boolean;
    xEnded: Boolean;
    { Socket }
    xSocket: Integer;
    xPort: WORD;
    xSocketAddr: TSockAddr;
    xOpened: Boolean;
    {---}
    TEMP: String;
    TEMPFILE: String;
    xSessionFile: Cardinal;
    xPath: String;
 
  protected
    procedure ClearFreeSessions;
    function TryToBind: Boolean;
    procedure CreateSocket;
    function GetFileForUpdate: Boolean;
    function LoadFile( R: RFile ): Boolean;
    procedure Execute;
 
  public
    constructor Create;
    destructor Destroy; override;
    procedure Free;
    property Terminated: Boolean read xTerminated write xTerminated;
    property Ended: Boolean read xEnded;
  end;
 
const cLoadBlockSize = 16384;
 
implementation
 
uses uFunctions;
 
var vWSAData: TWSAData;
 
function CheckPath( const Path: String; Cancreate: boolean ): Boolean;
var nn, cnt, pos: Integer;
    aPath: String;
begin
 
Result := false;
{ выделим путь }
pos := 1;
cnt := Length(Path);
for nn := 0 to cnt - 1 do
  if Path[nn] = '\' then pos := nn;
if pos < 2 then Exit;
aPath := Copy( Path, 1, pos - 1 );
{ проверим существование папки }
Result := DirectoryExists( aPath );
{ проверим можем ли создать папку }
if not Result and Cancreate then begin
  Result := CreateDirectory( @aPath[1], nil );
  { проверим возможность создания по уровню вверх }
  if not Result then
    { попытка создать каталог еще раз }
    if CheckPath( aPath, Cancreate) then Result := CreateDirectory( @aPath[1], nil );
  { все попробовал }
  end;
end;
 
function ThreadProc( Param: Pointer ): DWORD; stdcall;
begin
TUpdater( Param ).Execute;
Result := 0;
end;
 
{ TUpdater }
 
constructor TUpdater.Create;
var ThId: Cardinal;
    cnt: Integer;
    TP, TP1: String;
begin
inherited Create;
xEnded := false;
TEMP := StringOfChar( ' ', 400 );
cnt := GetEnvironmentVariable( 'TEMP', @TEMP[1], Length(TEMP) );
TEMP := Copy( TEMP, 1, cnt );
if TEMP[cnt] <> '\' then TEMP := TEMP + '\';
TEMP := TEMP + 'sds_temp';
if not DirectoryExists( TEMP ) then CreateDirectory( @TEMP[1], nil );
ClearFreeSessions;
xThHandle := CreateThread( nil, 0, @ThreadProc, Pointer(Self), 0, ThId );
xThId := ThId;
TP := IntToStr( xThId );
TP1 := IntToStr( xThHandle );
TEMPFILE := TEMP + '\sds_manager_' + TP + '_' + TP1 + '.session';
xSessionFile := CreateFile( @TEMPFILE[1], GENERIC_READ or GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 );
end;
 
destructor TUpdater.Destroy;
begin
try
  Terminated := true;
  while not xEnded do Sleep( 50 );
  if xSessionFile <> INVALID_HANDLE_VALUE then begin
    CloseHandle( xSessionFile );
    DeleteFileW( @TEMPFILE[1] );
    end;
  ClearFreeSessions;
  except end;
inherited Destroy;
end;
 
procedure TUpdater.Free;
begin
Self.Destroy;
end;
{ ---------------------------------------------------------------------------- }
procedure TUpdater.ClearFreeSessions;
var tmpS: String;
    cnt: Integer;
    FFD: _WIN32_FIND_DATAW;
    Filename: String;
    FH: Cardinal;
    S: array [0..128] of String;
begin
cnt := 0;
Filename := TEMP + '\*.session' + #0;
FH := FindFirstFile( @Filename[1], FFD );
while not(FH = INVALID_HANDLE_VALUE)and(cnt < 128) do begin
  if (FFD.dwFileAttributes and (faHidden or faSysFile or faDirectory)) = 0 then begin
    SetLength( tmpS, Length(PAnsiChar(@FFD.cFileName)) );
    CopyMemory( @tmpS[1], PAnsiChar(@FFD.cFileName), Length(tmpS) );
    S[cnt] := tmpS;
    if Length(tmpS) > 0 then Inc( cnt );
    end;
  if not FindNextFile( FH, FFD ) then begin
    Windows.FindClose( FH );
    FH := INVALID_HANDLE_VALUE;
    end;
  end;
if not (FH = INVALID_HANDLE_VALUE) then Windows.FindClose( FH );
 
while cnt > 0 do begin
  Dec( cnt );
  tmpS := TEMP + '\' + S[cnt];
  DeleteFileW( @tmpS[1] );
  end;
end;
 
function TUpdater.TryToBind: Boolean;
var fT: String;
    C, N: Cardinal;
    tmpS: String;
    I: Integer;
begin
  fT := xPath + 'updater';
  fT[Length(fT)+1] := #0;
  C := CreateFile( @fT[1], GENERIC_READ, 7, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0 );
  if C <> INVALID_HANDLE_VALUE then begin
    tmpS := StringOfChar( ' ', GetFileSize( C, nil ) );
    ReadFile( C, tmpS[1], Length(tmpS), N, nil );
    CloseHandle( C );
    end;
  Result := false;
  FillChar( xSocketAddr, SizeOf( TSockAddr ), 0 );
  xSocketAddr.sin_family := AF_INET;
  xSocketAddr.sin_port := htons( xPort );
  xSocketAddr.sin_addr.S_addr := inet_addr( @tmpS[1] );
  if connect( xSocket, xSocketAddr, SizeOf( TSockAddr ) ) = 0 then begin
    I := 10000;
    setsockopt( xSocket, SOL_SOCKET, SO_RCVTIMEO, @I, SizeOf(Integer) );
    setsockopt( xSocket, SOL_SOCKET, SO_SNDTIMEO, @I, SizeOf(Integer) );
    Result := true;
    end;
  xOpened := Result;
end;
 
procedure TUpdater.CreateSocket;
begin
  xOpened := false;
  xPort := 9000;
  xSocket := socket( AF_INET, SOCK_STREAM, IPPROTO_IP );
  if not(xSocket = INVALID_SOCKET) then try
    TryToBind;
    finally
      if not xOpened then begin
        closesocket( xSocket );
        xSocket := INVALID_SOCKET;
        end;
      end;
end;
 
function TUpdater.GetFileForUpdate: Boolean;
var Cmd: RCommand;
    Rcv: RCommand;
    cnt, len, nn, fcnt, strCnt: Integer;
    P: PFiles;
    Filename: String;
    tmpAS: AnsiString;
    brk: Boolean;
    FFD: _WIN32_FIND_DATAW;
    FH, CTime: Cardinal;
    FTime: _FILETIME;
begin
 
brk := false;
Result := false;
Cmd.A := 1;
Cmd.B := 0;
Cmd.C := 0;
Cmd.D := 0;
if not(send( xSocket, Cmd, SizeOf(RCommand), 0 ) = SizeOf(RCommand)) then Exit;
if not(recv( xSocket, Rcv, SizeOf(RCommand), 0 ) = SizeOf(RCommand)) then Exit;
if not(Rcv.C = 1) then Exit;
cnt := Rcv.A;
len := Rcv.B;
P := AllocMem( SizeOf(RFile) * cnt );
try
  nn := 0;
  fcnt := 0;
  while not Terminated and (nn < cnt)and not brk do begin
    Sleep( 50 );
    // получение имени файла
    SetLength( tmpAS, len );
    brk := Terminated or ( recv( xSocket, tmpAS[1], len, 0 ) <> len );
    if not brk then begin
      strCnt := Length(tmpAS);
      while (strCnt > 0)and(tmpAS[strCnt] = ' ') do strCnt := strCnt - 1;
      SetLength(tmpAS, strCnt);
      CheckPath( (tmpAS), true );
      P^[fcnt].Name := tmpAS;
      Sleep( 10 );
      end;
    if not Terminated then Sleep( 50 );
    // получение остальных значений
    brk := Terminated or brk or ( recv( xSocket, Rcv, SizeOf(RCommand), 0 ) <> SizeOf(RCommand) );
    if not brk then begin
      P^[fcnt].Num := Rcv.D;
      P^[fcnt].Size := Rcv.B;
      P^[fcnt].FTime := Rcv.A;
      P^[fcnt].CTime := Rcv.C;
      P^[fcnt].Handle := 0;
      P^[fcnt].Loaded := 0;
      // найдем этот файл у себя на компе
      Filename := xPath + tmpAS;
      FH := FindFirstFile( @Filename[1], FFD );
      if FH <> INVALID_HANDLE_VALUE then begin
        FileTimeToLocalFileTime(FFD.ftLastWriteTime, FTime);
        FileTimeToDosDateTime(FTime, LongRec(CTime).Hi, LongRec(CTime).Lo);
        P^[fcnt].n := (CTime = P^[fcnt].FTime);
        end else P^[fcnt].n := false;
      if FH <> INVALID_HANDLE_VALUE then Windows.FindClose( FH );
      // если не нашли или время отличается, запомним
      if not P^[fcnt].n then fcnt := fcnt + 1;
      end;
    // следующий
    Inc( nn );
    end;
  { ------------------ теперь пробуем начать обновление ------------------- }
  nn := 0;
  while not Terminated and (nn < fcnt) do begin
    LoadFile( P^[nn] );
    Inc( nn );
    end;
  finally
    // если были проблемы - то переподключение требуется
    if brk then begin
      closesocket( xSocket );
      xSocket := INVALID_SOCKET;
      end;
    // очистим мусор
    FreeMem( P, SizeOf(RFile) * cnt );
    Result := not brk;
    end;
 
end;
function TUpdater.LoadFile( R: RFile ): Boolean;
var tmpF, MyFile: String;
    F: RFile;
    NF, vReaded, vWrited: Cardinal;
    Cmd, Rcv: RCommand;
    brk: Boolean;
    iRecv, iAll: Integer;
    B: array [0..cLoadBlockSize] of Byte;
    OldFile, NewFile: String;
    CT, AT, WT: TFileTime;
begin
Result := false;
NF := INVALID_HANDLE_VALUE;
R.Handle := INVALID_HANDLE_VALUE;
OldFile := xPath + R.Name;
NewFile := OldFile + '.tmp';
DeleteFileW(@NewFile[1]);
tmpF := xPath + R.Name + '.load';
MyFile := tmpF;
if not Terminated then R.Handle := CreateFile( @tmpF[1], GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 );
// это может произойти, если файл уже открыт, тогда пущщай работают другие
if R.Handle = INVALID_HANDLE_VALUE then Exit;
try
  // проверка файла - продолжение загрузки
  if GetFileSize( R.Handle, nil ) > SizeOf( RFile ) then begin
    ReadFile( R.Handle, F, SizeOf(RFile), vReaded, nil );
    // если все совпадает - продолжим качать с последнего места
    if (vReaded = SizeOf(RFile))and
       (F.Size = R.Size)and
       (F.FTime = R.FTime)and
       (F.CTime = R.CTime)and
       (GetFileSize( R.Handle, nil ) > F.Loaded) then
       R.Loaded := F.Loaded;
    end;
  Sleep( 50 );
  // подготовка - запись заголовка
  SetFilePointer( R.Handle, 0, nil, FILE_BEGIN );
  WriteFile( R.Handle, R, SizeOf(RFile), vWrited, nil );
  brk := Terminated;
  // выход из цикла только по ошибке или окончанию закачки
  while (R.Loaded < R.Size)and not brk do try
    if not Terminated then Sleep( 50 );
    // создаем запрос
    Cmd.A := 2;
    Cmd.B := R.Num;
    Cmd.C := R.Loaded;
    if (R.Size - R.Loaded) > cLoadBlockSize then
      Cmd.D := cLoadBlockSize
      else
      Cmd.D := R.Size - R.Loaded;
    // устанавливаемся на конец файла
    SetFilePointer( R.Handle, SizeOf(RFile) + R.Loaded, nil, FILE_BEGIN );
    // запрос
    brk := Terminated or (send( xSocket, Cmd, SizeOf(Rcommand), 0 ) <> SizeOf(RCommand));
    brk := Terminated or brk or (recv( xSocket, Rcv, SizeOf(RCommand), 0 ) <> SizeOf(RCommand));
    // качаем кусок
    iAll := 0;
    if not brk and (Rcv.D > 0) then begin
      iRecv := recv( xSocket, B[0], Rcv.D, 0 );
      iAll := iRecv;
      while not Terminated and(iRecv > 0)and(iAll < Rcv.D) do begin
        Sleep( 50 );
        iRecv := recv( xSocket, B[iAll], Rcv.D - iAll, 0 );
        iAll := iAll + iRecv;
        end;
      brk := Terminated or not(iAll = Rcv.D);
      end;
    // звапишем кусок в файл
    if not brk then WriteFile( R.Handle, B[0], iAll, vWrited, nil );
    brk := Terminated or brk or (vWrited <> iAll);
    // и сообщим голове
    if not brk then begin
      R.Loaded := R.Loaded + vWrited;
      SetFilePointer( R.Handle, 0, nil, FILE_BEGIN );
      brk := Terminated or brk or not WriteFile( R.Handle, R, SizeOf(RFile), vWrited, nil );
      brk := Terminated or brk or (vWrited <> SizeOf(RFile));
      end;
    except
      brk := true;
      end;
  if not Terminated then Sleep( 50 );
  Result := not Terminated and not brk and (R.Loaded = R.Size);
 
  if Result then begin
    if not Terminated then begin
      MoveFile( @OldFile[1], @NewFile[1] );
      NF := CreateFile( @OldFile[1], GENERIC_WRITE, FILE_SHARE_READ, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0 );
      if not(NF = INVALID_HANDLE_VALUE) then begin
        SetFilePointer( R.Handle, SizeOf(RFile), nil, FILE_BEGIN );
        tmpF := StringOfChar( ' ', R.Size );
        ReadFile( R.Handle, tmpF[1], R.Size, vReaded, nil );
        if vReaded = R.Size then begin
          WriteFile( NF, tmpF[1], R.Size, vWrited, nil );
          Result := vReaded = vWrited;
          end else Result := false;
        end else Result := false;
      if not Result then begin
        DeleteFileW( @OldFile[1] );
        MoveFile( @NewFile[1], @OldFile[1] );
        end else begin
        DeleteFileW( @NewFile[1] );
        GetFileTime( NF, @CT, @AT, @WT );
        DosDateTimeToFileTime( LongRec(R.FTime).Hi, LongRec(R.FTime).Lo, WT );
        LocalFileTimeToFileTime( WT, WT );
        DosDateTimeToFileTime( LongRec(R.CTime).Hi, LongRec(R.CTime).Lo, CT );
        LocalFileTimeToFileTime( CT, CT );
        SetFileTime( NF, @CT, @AT, @WT );
        end;
      end else Result := false;
    end;
  finally
    CloseHandle( R.Handle );
    if not(NF = INVALID_HANDLE_VALUE) then CloseHandle( NF );
    if Result then DeleteFileW( @MyFile[1] );
    R.Handle := 0;
    Sleep( 50 );
    end;
end;
 
procedure TUpdater.Execute;
var cnt, nn, i: integer;
begin
WSAStartup( $101, vWSAData );
xPath := ParamStr( 0 );
cnt := Length( xPath );
nn := 0;
for i := 1 to cnt do
  if xPath[i] = '\' then nn := i;
if nn > 0 then begin
  xPath := Copy( xPath, 1, nn );
  end;
xSocket := INVALID_SOCKET;
while not Terminated do begin
  if xSocket = INVALID_SOCKET then CreateSocket;
  // если с подключением все норм
  if not(xSocket = INVALID_SOCKET) and not Terminated then begin
    if not GetFileForUpdate and not Terminated then begin
      // че? если не вышло - стопорим на минуту
      i := 600;
      while (i > 0)and not Terminated do begin
        Sleep( 100 );
        Dec( i );
        end;
      end;
    end;
  // не надо часто проверять
  i := 100;
  while (i > 0)and not Terminated do begin
    Sleep( 10 );
    Dec( i );
    end;
  end;
WSACleanup;
xEnded := true;
end;
end.