mirror of
https://gitlab.com/freepascal.org/lazarus/lazarus.git
synced 2025-05-22 11:42:32 +02:00
596 lines
16 KiB
ObjectPascal
596 lines
16 KiB
ObjectPascal
{
|
|
***************************************************************************
|
|
* *
|
|
* This source is free software; you can redistribute it and/or modify *
|
|
* it under the terms of the GNU General Public License as published by *
|
|
* the Free Software Foundation; either version 2 of the License, or *
|
|
* (at your option) any later version. *
|
|
* *
|
|
* This code is distributed in the hope that it will be useful, but *
|
|
* WITHOUT ANY WARRANTY; without even the implied warranty of *
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
|
|
* General Public License for more details. *
|
|
* *
|
|
* A copy of the GNU General Public License is available on the World *
|
|
* Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also *
|
|
* obtain it by writing to the Free Software Foundation, *
|
|
* Inc., 51 Franklin Street - Fifth Floor, Boston, MA 02110-1335, USA. *
|
|
* *
|
|
***************************************************************************
|
|
|
|
Author: Balázs Székely
|
|
}
|
|
|
|
unit opkman_updates;
|
|
|
|
{$mode objfpc}{$H+}
|
|
|
|
{$INCLUDE opkman_fpcdef.inc}
|
|
|
|
interface
|
|
|
|
uses
|
|
{$IFDEF MSWINDOWS}windows, opkman_const,{$ENDIF}
|
|
Classes, SysUtils, Controls, fpjson, fpjsonrtti, jsonparser, dateutils,
|
|
// LazUtils
|
|
LazIDEIntf, LazFileUtils,
|
|
// OpkMan
|
|
opkman_serializablepackages, opkman_options, opkman_common, opkman_visualtree,
|
|
opkman_OpenSSLfrm,
|
|
{$IFDEF FPC311}zipper,{$ELSE}opkman_zip,{$ENDIF}
|
|
{$IFDEF FPC311}fphttpclient{$ELSE}opkman_httpclient{$ENDIF};
|
|
|
|
const
|
|
OpkVersion = 1;
|
|
|
|
type
|
|
|
|
{ TUpdateLazPackages }
|
|
|
|
TUpdateLazPackages = class(TCollectionItem)
|
|
private
|
|
FName: String;
|
|
FVersion: String;
|
|
FForceNotify: Boolean;
|
|
FInternalVersion: Integer;
|
|
published
|
|
property Name: String read FName write FName;
|
|
property Version: String read FVersion write FVersion;
|
|
property ForceNotify: Boolean read FForceNotify write FForceNotify;
|
|
property InternalVersion: Integer read FInternalVersion write FInternalVersion;
|
|
end;
|
|
|
|
{ TUpdatePackageData }
|
|
|
|
TUpdatePackageData = class(TPersistent)
|
|
private
|
|
FDownloadZipURL: String;
|
|
FDisableInOPM: Boolean;
|
|
FName: String;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Clear;
|
|
published
|
|
property Name: String read FName write FName;
|
|
property DownloadZipURL: String read FDownloadZipURL write FDownloadZipURL;
|
|
property DisableInOPM: Boolean read FDisableInOPM write FDisableInOPM;
|
|
end;
|
|
|
|
{TUpdatePackage}
|
|
|
|
TUpdatePackage = class(TPersistent)
|
|
private
|
|
FUpdatePackageData: TUpdatePackageData;
|
|
FUpdateLazPackages: TCollection;
|
|
FLastError: String;
|
|
procedure Clear;
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
function LoadFromJSON(const AJSON: TJSONStringType): Boolean;
|
|
function SaveToJSON(var AJSON: TJSONStringType): Boolean;
|
|
property LastError: String read FLastError;
|
|
published
|
|
property UpdatePackageData: TUpdatePackageData read FUpdatePackageData write FUpdatePackageData;
|
|
property UpdateLazPackages: TCollection read FUpdateLazPackages write FUpdateLazPackages;
|
|
end;
|
|
|
|
{ TUpdates }
|
|
TUpdates = class(TThread)
|
|
private
|
|
FSP_Temp: TSerializablePackages;
|
|
FHTTPClient: TFPHTTPClient;
|
|
FUpdatePackage: TUpdatePackage;
|
|
FNeedToBreak: Boolean;
|
|
FBusyUpdating: Boolean;
|
|
FOpenSSLAvailable: Boolean;
|
|
FTime: QWORD;
|
|
FInterval: Cardinal;
|
|
FStarted: Boolean;
|
|
procedure DoTerminated(Sender: TObject);
|
|
function GetUpdateInfo(const AURL: String; var AJSON: TJSONStringType): Boolean;
|
|
procedure AssignPackageData(AMetaPackage: TMetaPackage);
|
|
procedure ResetPackageData(AMetaPackage: TMetaPackage);
|
|
procedure CheckForOpenSSL;
|
|
procedure CheckForUpdates;
|
|
procedure GetSerializablePackages;
|
|
procedure SetSerializablePackages;
|
|
function IsTimeToUpdate: Boolean;
|
|
protected
|
|
procedure Execute; override;
|
|
public
|
|
constructor Create;
|
|
procedure StartUpdate;
|
|
procedure StopUpdate;
|
|
end;
|
|
|
|
var
|
|
Updates: TUpdates = nil;
|
|
|
|
implementation
|
|
uses opkman_mainfrm;
|
|
{ TUpdatePackage }
|
|
|
|
procedure TUpdatePackage.Clear;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FUpdatePackageData.Clear;
|
|
for I := FUpdateLazPackages.Count - 1 downto 0 do
|
|
FUpdateLazPackages.Items[I].Free;
|
|
FUpdateLazPackages.Clear;
|
|
end;
|
|
|
|
constructor TUpdatePackage.Create;
|
|
begin
|
|
FUpdatePackageData := TUpdatePackageData.Create;
|
|
FUpdateLazPackages := TCollection.Create(TUpdateLazPackages);
|
|
end;
|
|
|
|
destructor TUpdatePackage.Destroy;
|
|
var
|
|
I: Integer;
|
|
begin
|
|
FUpdatePackageData.Free;
|
|
for I := FUpdateLazPackages.Count - 1 downto 0 do
|
|
FUpdateLazPackages.Items[I].Free;
|
|
FUpdateLazPackages.Free;
|
|
inherited Destroy;
|
|
end;
|
|
|
|
function IsValidJSON(const AJSON: TJSONStringType): Boolean;
|
|
var
|
|
{%H-}JSONData: TJSONData;
|
|
begin
|
|
Result := True;
|
|
try
|
|
JSONData := GetJSON(AJSON);
|
|
JSONData.Free;
|
|
except
|
|
on E: EJSONParser do
|
|
Result := False;
|
|
end;
|
|
end;
|
|
|
|
function TUpdatePackage.LoadFromJSON(const AJSON: TJSONStringType): Boolean;
|
|
var
|
|
DeStreamer: TJSONDeStreamer;
|
|
begin
|
|
DeStreamer := TJSONDeStreamer.Create(nil);
|
|
try
|
|
Clear;
|
|
try
|
|
if IsValidJSON(AJSON) then
|
|
begin
|
|
DeStreamer.JSONToObject(AJSON, Self);
|
|
Result := True;
|
|
end;
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
FLastError := E.Message;
|
|
Result := False;
|
|
end;
|
|
end;
|
|
finally
|
|
DeStreamer.Free;
|
|
end;
|
|
end;
|
|
|
|
function TUpdatePackage.SaveToJSON(var AJSON: TJSONStringType): Boolean;
|
|
var
|
|
Streamer: TJSONStreamer;
|
|
begin
|
|
Result := False;
|
|
Streamer := TJSONStreamer.Create(nil);
|
|
try
|
|
Streamer.Options := Streamer.Options + [jsoUseFormatString];
|
|
try
|
|
AJSON := Streamer.ObjectToJSONString(Self);
|
|
Result := AJSON <> '';
|
|
except
|
|
on E: Exception do
|
|
begin
|
|
FLastError := E.Message;
|
|
Result := False;
|
|
end;
|
|
end;
|
|
finally
|
|
Streamer.Free;
|
|
end;
|
|
end;
|
|
|
|
{ TUpdatePackageData }
|
|
|
|
constructor TUpdatePackageData.Create;
|
|
begin
|
|
Clear;
|
|
end;
|
|
|
|
destructor TUpdatePackageData.Destroy;
|
|
begin
|
|
//
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TUpdatePackageData.Clear;
|
|
begin
|
|
FName := '';
|
|
FDownloadZipURL := '';
|
|
FDisableInOPM := False;
|
|
end;
|
|
|
|
{ TUpdates }
|
|
|
|
constructor TUpdates.Create;
|
|
begin
|
|
inherited Create(True);
|
|
FOpenSSLAvailable := False;
|
|
FSP_Temp := TSerializablePackages.Create;
|
|
FreeOnTerminate := True;
|
|
OnTerminate := @DoTerminated;
|
|
FHTTPClient := TFPHTTPClient.Create(nil);
|
|
{$IFDEF FPC311}
|
|
FHTTPClient.IOTimeout := Options.ConTimeOut*1000;
|
|
{$ENDIF}
|
|
if Options.ProxyEnabled then
|
|
begin
|
|
FHTTPClient.Proxy.Host:= Options.ProxyServer;
|
|
FHTTPClient.Proxy.Port:= Options.ProxyPort;
|
|
FHTTPClient.Proxy.UserName:= Options.ProxyUser;
|
|
FHTTPClient.Proxy.Password:= Options.ProxyPassword;
|
|
end;
|
|
FUpdatePackage := TUpdatePackage.Create;
|
|
end;
|
|
|
|
procedure TUpdates.AssignPackageData(AMetaPackage: TMetaPackage);
|
|
var
|
|
I: Integer;
|
|
HasUpdate: Boolean;
|
|
LazarusPkg: TLazarusPackage;
|
|
UpdLazPkgs: TUpdateLazPackages;
|
|
begin
|
|
HasUpdate := False;
|
|
AMetaPackage.DownloadZipURL := FUpdatePackage.FUpdatePackageData.DownloadZipURL;
|
|
AMetaPackage.DisableInOPM := FUpdatePackage.FUpdatePackageData.DisableInOPM;
|
|
for I := 0 to FUpdatePackage.FUpdateLazPackages.Count - 1 do
|
|
begin
|
|
UpdLazPkgs := TUpdateLazPackages(FUpdatePackage.FUpdateLazPackages.Items[I]);
|
|
LazarusPkg := AMetaPackage.FindLazarusPackage(UpdLazPkgs.Name);
|
|
if LazarusPkg <> nil then
|
|
begin
|
|
LazarusPkg.UpdateVersion := UpdLazPkgs.Version;
|
|
LazarusPkg.ForceNotify := UpdLazPkgs.ForceNotify;
|
|
LazarusPkg.InternalVersion := UpdLazPkgs.InternalVersion;
|
|
LazarusPkg.RefreshHasUpdate;
|
|
if not HasUpdate then
|
|
HasUpdate := (LazarusPkg.HasUpdate) and (LazarusPkg.InstalledFileVersion < LazarusPkg.UpdateVersion);
|
|
end;
|
|
end;
|
|
AMetaPackage.HasUpdate := HasUpdate;
|
|
end;
|
|
|
|
procedure TUpdates.ResetPackageData(AMetaPackage: TMetaPackage);
|
|
var
|
|
I: Integer;
|
|
LazarusPkg: TLazarusPackage;
|
|
begin
|
|
AMetaPackage.DownloadZipURL := '';
|
|
AMetaPackage.DisableInOPM := False;
|
|
AMetaPackage.HasUpdate := False;
|
|
for I := 0 to AMetaPackage.LazarusPackages.Count - 1 do
|
|
begin
|
|
LazarusPkg := AMetaPackage.FindLazarusPackage(TLazarusPackage(AMetaPackage.LazarusPackages.Items[I]).Name);
|
|
if LazarusPkg <> nil then
|
|
begin
|
|
LazarusPkg.HasUpdate := False;
|
|
LazarusPkg.UpdateVersion := '';
|
|
LazarusPkg.ForceNotify := False;
|
|
LazarusPkg.InternalVersion := 0;
|
|
LazarusPkg.InternalVersionOld := 0;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TUpdates.CheckForOpenSSL;
|
|
{$IFDEF MSWINDOWS}
|
|
function SystemFolder: String;
|
|
var
|
|
SysPath: WideString;
|
|
begin
|
|
SetLength(SysPath, Windows.MAX_PATH);
|
|
SetLength(SysPath, Windows.GetSystemDirectoryW(PWideChar(SysPath), Windows.MAX_PATH));
|
|
Result := AppendPathDelim(String(SysPath));
|
|
end;
|
|
|
|
function IsOpenSSLAvailable: Boolean;
|
|
var
|
|
ParamPath, SysPath: String;
|
|
begin
|
|
ParamPath := ExtractFilePath(ParamStr(0));
|
|
SysPath := SystemFolder;
|
|
Result := (FileExists(ParamPath + 'libeay32.dll') and FileExists(ParamPath + 'ssleay32.dll')) or
|
|
(FileExists(SysPath + 'libeay32.dll') and FileExists(SysPath + 'ssleay32.dll'));
|
|
end;
|
|
|
|
var
|
|
ZipFile: String;
|
|
UnZipper: TUnZipper;
|
|
CanDownload: Boolean;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF MSWINDOWS}
|
|
FOpenSSLAvailable := IsOpenSSLAvailable;
|
|
if not FOpenSSLAvailable then
|
|
begin
|
|
case Options.OpenSSLDownloadType of
|
|
0: CanDownload := True; //automatically download
|
|
1: begin //ask questions
|
|
OpenSSLFrm := TOpenSSLFrm.Create(MainFrm);
|
|
try
|
|
OpenSSLFrm.ShowModal;
|
|
CanDownload := (OpenSSLFrm.ModalResult = mrYes);
|
|
if OpenSSLFrm.cbPermanent.Checked then
|
|
begin
|
|
case OpenSSLFrm.ModalResult of
|
|
mrYes: Options.OpenSSLDownloadType := 0;
|
|
mrNo: Options.OpenSSLDownloadType := 2;
|
|
end
|
|
end;
|
|
finally
|
|
OpenSSLFrm.Free;
|
|
end;
|
|
end;
|
|
2: CanDownload := False;//never download
|
|
end;
|
|
|
|
if CanDownload then
|
|
begin
|
|
ZipFile := ExtractFilePath(ParamStr(0)) + ExtractFileName(cOpenSSLURL);
|
|
try
|
|
FHTTPClient.Get(cOpenSSLURL, ZipFile);
|
|
except
|
|
end;
|
|
if FileExists(ZipFile) then
|
|
begin
|
|
UnZipper := TUnZipper.Create;
|
|
try
|
|
try
|
|
UnZipper.FileName := ZipFile;
|
|
UnZipper.Examine;
|
|
UnZipper.UnZipAllFiles;
|
|
except
|
|
end;
|
|
finally
|
|
UnZipper.Free;
|
|
end;
|
|
DeleteFile(ZipFile);
|
|
FOpenSSLAvailable := IsOpenSSLAvailable;
|
|
end;
|
|
end;
|
|
end;
|
|
{$ELSE}
|
|
FOpenSSLAvailable := True;
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function TUpdates.IsTimeToUpdate: Boolean;
|
|
begin
|
|
Result := False;
|
|
if (not FOpenSSLAvailable) or FBusyUpdating or FNeedToBreak then
|
|
Exit;
|
|
case Options.CheckForUpdates of
|
|
0: Result := MinutesBetween(Now, Options.LastUpdate) >= 5;
|
|
1: Result := HoursBetween(Now, Options.LastUpdate) >= 1;
|
|
2: Result := DaysBetween(Now, Options.LastUpdate) >= 1;
|
|
3: Result := WeeksBetween(Now, Options.LastUpdate) >= 1;
|
|
4: Result := MonthsBetween(Now, Options.LastUpdate) >= 1;
|
|
5: Result := False;
|
|
end;
|
|
end;
|
|
|
|
function TUpdates.GetUpdateInfo(const AURL: String; var AJSON: TJSONStringType): Boolean;
|
|
var
|
|
URL: String;
|
|
Ms: TMemoryStream;
|
|
begin
|
|
Result := False;
|
|
if Trim(AURL) = '' then
|
|
Exit;
|
|
if Pos('.json', AURL) = 0 then
|
|
Exit;
|
|
URL := FixProtocol(AURL);
|
|
Ms := TMemoryStream.Create;
|
|
try
|
|
try
|
|
FHTTPClient.AllowRedirect := True;
|
|
FHTTPClient.HTTPMethod('GET', URL, MS, []);
|
|
if FHTTPClient.ResponseStatusCode = 200 then
|
|
begin
|
|
if Ms.Size > 0 then
|
|
begin
|
|
MS.Position := 0;
|
|
SetLength(AJSON, MS.Size);
|
|
MS.Read(Pointer(AJSON)^, Length(AJSON));
|
|
Result := Length(AJSON) > 0;
|
|
{since the class name has changed form "UpdatePackageFiles" to "UpdateLazPackages",
|
|
we have to replace the references in the old JSONs(we don't have access to the files, they are
|
|
located at the developers update page.}
|
|
if Result then
|
|
AJSON := StringReplace(AJSON, 'UpdatePackageFiles', 'UpdateLazPackages', [rfReplaceAll, rfIgnoreCase]);
|
|
end;
|
|
end;
|
|
except
|
|
Result := False;
|
|
end;
|
|
finally
|
|
Ms.Free;
|
|
end;
|
|
end;
|
|
|
|
procedure TUpdates.DoTerminated(Sender: TObject);
|
|
begin
|
|
Updates := nil;
|
|
FHTTPClient.Free;
|
|
FUpdatePackage.Free;
|
|
FSP_Temp.Clear;
|
|
FSP_Temp.Free;
|
|
end;
|
|
|
|
procedure TUpdates.CheckForUpdates;
|
|
var
|
|
I: Integer;
|
|
JSON: TJSONStringType;
|
|
begin
|
|
if FSP_Temp.Count = 0 then
|
|
Exit;
|
|
|
|
FBusyUpdating := True;
|
|
try
|
|
Options.LastUpdate := Now;
|
|
Options.Changed := True;
|
|
for I := 0 to FSP_Temp.Count - 1 do
|
|
begin
|
|
if FNeedToBreak then
|
|
Break;
|
|
JSON := '';
|
|
if (Assigned(LazarusIDE) and LazarusIDE.IDEIsClosing) then
|
|
Break;
|
|
if GetUpdateInfo(Trim(FSP_Temp.Items[I].DownloadURL), JSON) then
|
|
begin
|
|
if FUpdatePackage.LoadFromJSON(JSON) then
|
|
AssignPackageData(FSP_Temp.Items[I])
|
|
else
|
|
ResetPackageData(FSP_Temp.Items[I]);
|
|
end
|
|
else
|
|
ResetPackageData(FSP_Temp.Items[I]);
|
|
end;
|
|
finally
|
|
FBusyUpdating := False;
|
|
end;
|
|
end;
|
|
|
|
procedure TUpdates.GetSerializablePackages;
|
|
var
|
|
JSON: TJSONStringType;
|
|
begin
|
|
if (FNeedToBreak) or (SerializablePackages.Count = 0) then
|
|
Exit;
|
|
|
|
EnterCriticalSection(CriticalSection);
|
|
try
|
|
FSP_Temp.Clear;
|
|
try
|
|
JSON := '';
|
|
SerializablePackages.PackagesToJSON(JSON);
|
|
FSP_Temp.JSONToPackages(JSON);
|
|
except
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(CriticalSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TUpdates.SetSerializablePackages;
|
|
var
|
|
I, J: Integer;
|
|
MetaPackage: TMetaPackage;
|
|
HasUpdate: Boolean;
|
|
LazarusPackage: TLazarusPackage;
|
|
begin
|
|
if (FNeedToBreak) or (SerializablePackages.Count = 0) or (FSP_Temp.Count = 0) then
|
|
Exit;
|
|
EnterCriticalSection(CriticalSection);
|
|
try
|
|
for I := 0 to FSP_Temp.Count - 1 do
|
|
begin
|
|
MetaPackage := SerializablePackages.FindMetaPackage(FSP_Temp.Items[I].Name, fpbPackageName);
|
|
if MetaPackage <> nil then
|
|
begin
|
|
MetaPackage.DownloadZipURL := FSP_Temp.Items[I].DownloadZipURL;
|
|
MetaPackage.DisableInOPM := FSP_Temp.Items[I].DisableInOPM;
|
|
HasUpdate := False;
|
|
for J := 0 to FSP_Temp.Items[I].LazarusPackages.Count - 1 do
|
|
begin
|
|
LazarusPackage := MetaPackage.FindLazarusPackage(TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).Name);
|
|
if LazarusPackage <> nil then
|
|
begin
|
|
LazarusPackage.UpdateVersion := TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).UpdateVersion;
|
|
LazarusPackage.ForceNotify := TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).ForceNotify;
|
|
LazarusPackage.InternalVersion := TLazarusPackage(FSP_Temp.Items[I].LazarusPackages.Items[J]).InternalVersion;
|
|
LazarusPackage.RefreshHasUpdate;
|
|
if not HasUpdate then
|
|
HasUpdate := (LazarusPackage.HasUpdate) and (LazarusPackage.InstalledFileVersion < LazarusPackage.UpdateVersion);
|
|
end;
|
|
end;
|
|
MetaPackage.HasUpdate := HasUpdate;
|
|
end;
|
|
end;
|
|
finally
|
|
LeaveCriticalSection(CriticalSection);
|
|
end;
|
|
end;
|
|
|
|
procedure TUpdates.Execute;
|
|
begin
|
|
while not Terminated do
|
|
begin
|
|
if FNeedToBreak then
|
|
Break;
|
|
Sleep(50);
|
|
if (GetTickCount64 - FTime > FInterval)then
|
|
begin
|
|
FTime := GetTickCount64;
|
|
if (IsTimeToUpdate) then
|
|
begin
|
|
GetSerializablePackages;
|
|
CheckForUpdates;
|
|
SetSerializablePackages;
|
|
if (not FNeedToBreak) and Assigned(VisualTree) then
|
|
Synchronize(@VisualTree.UpdatePackageUStatus);
|
|
end;
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
procedure TUpdates.StartUpdate;
|
|
begin
|
|
FStarted := True;
|
|
CheckForOpenSSL;
|
|
FTime := GetTickCount64;
|
|
FInterval := 6000;
|
|
Start;
|
|
end;
|
|
|
|
procedure TUpdates.StopUpdate;
|
|
begin
|
|
FStarted := False;
|
|
FHTTPClient.Terminate;
|
|
FNeedToBreak := True;
|
|
end;
|
|
|
|
end.
|
|
|