1 | unit UUpdateChecker;
|
---|
2 |
|
---|
3 | {$mode delphi}{$H+}
|
---|
4 |
|
---|
5 | interface
|
---|
6 |
|
---|
7 | uses
|
---|
8 | {$IFDEF Windows}Windows, ShellApi, {$ENDIF}Forms, Classes, SysUtils,
|
---|
9 | httpsend, DOM, XMLWrite, XMLRead, UXMLUtils,
|
---|
10 | FileUtil, Dialogs, Process, Blcksock, UFormDownloadProgress, Controls;
|
---|
11 |
|
---|
12 | type
|
---|
13 | TVersionInfo = record
|
---|
14 | Id: Integer;
|
---|
15 | Version: string;
|
---|
16 | SourceURL: string;
|
---|
17 | ReleaseTime: TDateTime;
|
---|
18 | ReleaseNotes: string;
|
---|
19 | end;
|
---|
20 |
|
---|
21 | TVersionInfoItem = (viiId, viiVersion, viiSourceURL, viiReleaseTime,
|
---|
22 | viiReleaseNotes);
|
---|
23 | TVersionInfoItems = set of TVersionInfoItem;
|
---|
24 |
|
---|
25 | { TUpdateChecker }
|
---|
26 |
|
---|
27 | TUpdateChecker = class(TComponent)
|
---|
28 | private
|
---|
29 | FBranchId: Integer;
|
---|
30 | FShowReleaseNotes: Boolean;
|
---|
31 | FVersionInfo: TVersionInfo;
|
---|
32 | HTTPSender: THTTPSend;
|
---|
33 | FOnTerminate: TNotifyEvent;
|
---|
34 | FVersionInfoURL: string;
|
---|
35 | InstallerFileName: string;
|
---|
36 | function DownloadHTTP(URL, TargetFile: string): Boolean;
|
---|
37 | function IsSystemAdmin: Boolean;
|
---|
38 | procedure SockStatus(Sender: TObject; Reason: THookSocketReason;
|
---|
39 | const Value: String);
|
---|
40 | function StripTags(XMLText: string): string;
|
---|
41 | function GetFile(URI: string; Content: TMemoryStream): Boolean;
|
---|
42 | public
|
---|
43 | FormDownloadProgress: TFormDownloadProgress;
|
---|
44 | constructor Create(AOwner: TComponent); override;
|
---|
45 | destructor Destroy; override;
|
---|
46 | function LoadVersionInfo(Items: TVersionInfoItems = []): Boolean;
|
---|
47 | { Download source file using HTTP protocol and save it to temp folder }
|
---|
48 | procedure Download;
|
---|
49 | procedure Install;
|
---|
50 | procedure Check(CurrentReleaseDate: TDateTime);
|
---|
51 | property VersionInfo: TVersionInfo read FVersionInfo write FVersionInfo;
|
---|
52 | published
|
---|
53 | property VersionInfoURL: string read FVersionInfoURL write FVersionInfoURL;
|
---|
54 | property BranchId: Integer read FBranchId write FBranchId;
|
---|
55 | property ShowReleaseNotes: Boolean read FShowReleaseNotes write FShowReleaseNotes;
|
---|
56 | property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
|
---|
57 | end;
|
---|
58 |
|
---|
59 | procedure Register;
|
---|
60 |
|
---|
61 | resourcestring
|
---|
62 | SWrongFileFormat = 'Wrong file format';
|
---|
63 | SCantExecuteFile = 'Can''t execute installer "%s"';
|
---|
64 | SDownloadProgress = 'Download progress';
|
---|
65 | SFile = 'File:';
|
---|
66 | SProgress = 'Progress:';
|
---|
67 | SYouHaveLatestVersion = 'You have latest version';
|
---|
68 | SNewVersionAvailable = 'New version available: %s. Do you want to download and install it now?';
|
---|
69 | SErrorCheckingNewVersion = 'New version check failed.';
|
---|
70 | SCheckUpdates = 'Check updates';
|
---|
71 | SChangesInNewVersion = 'Changes in new version:';
|
---|
72 | SWhatsNew = 'What''s new?';
|
---|
73 | SYes = 'Update';
|
---|
74 | SNo = 'Later';
|
---|
75 |
|
---|
76 | implementation
|
---|
77 |
|
---|
78 | uses
|
---|
79 | UFormNewVersionOffer;
|
---|
80 |
|
---|
81 | {$IFDEF Windows}
|
---|
82 | const
|
---|
83 | SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)) ;
|
---|
84 |
|
---|
85 | const
|
---|
86 | SECURITY_BUILTIN_DOMAIN_RID = $00000020;
|
---|
87 | DOMAIN_ALIAS_RID_ADMINS = $00000220;
|
---|
88 | {$ENDIF}
|
---|
89 |
|
---|
90 | procedure Register;
|
---|
91 | begin
|
---|
92 | RegisterComponents('Samples', [TUpdateChecker]);
|
---|
93 | end;
|
---|
94 |
|
---|
95 | function RunAsAdmin(const Handle: Hwnd; const Path, Params: string): Boolean;
|
---|
96 | var
|
---|
97 | sei: TShellExecuteInfoA;
|
---|
98 | begin
|
---|
99 | FillChar(sei, SizeOf(sei), 0);
|
---|
100 | sei.cbSize := SizeOf(sei);
|
---|
101 | sei.Wnd := Handle;
|
---|
102 | sei.fMask := SEE_MASK_FLAG_DDEWAIT or SEE_MASK_FLAG_NO_UI;
|
---|
103 | sei.lpVerb := 'runas';
|
---|
104 | sei.lpFile := PAnsiChar(Path);
|
---|
105 | sei.lpParameters := PAnsiChar(Params);
|
---|
106 | sei.nShow := SW_SHOWNORMAL;
|
---|
107 | Result := ShellExecuteExA(@sei);
|
---|
108 | end;
|
---|
109 |
|
---|
110 | { TUpdateChecker }
|
---|
111 |
|
---|
112 | function TUpdateChecker.LoadVersionInfo(Items: TVersionInfoItems = []): Boolean;
|
---|
113 | var
|
---|
114 | URL: string;
|
---|
115 | XmlDocument: TXMLDocument;
|
---|
116 | Node1: TDOMNode;
|
---|
117 | Node2: TDOMNode;
|
---|
118 | Node3: TDOMNode;
|
---|
119 | Content: TMemoryStream;
|
---|
120 | begin
|
---|
121 | Result := False;
|
---|
122 | FVersionInfo.Version := '';
|
---|
123 | FVersionInfo.Id := 0;
|
---|
124 | FVersionInfo.SourceURL := '';
|
---|
125 | URL := VersionInfoURL;
|
---|
126 | if Pos('://', VersionInfoURL) > 0 then begin
|
---|
127 | URL := URL + '?BranchId=' + IntToStr(BranchId) +
|
---|
128 | '&Limit=1';
|
---|
129 | if viiVersion in Items then URL := URL + '&Version';
|
---|
130 | if viiReleaseNotes in Items then URL := URL + '&ReleaseNotes';
|
---|
131 | if viiReleaseTime in Items then URL := URL + '&ReleaseTime';
|
---|
132 | if viiSourceURL in Items then URL := URL + '&SourceURL';
|
---|
133 | if viiId in Items then URL := URL + '&Id';
|
---|
134 | end;
|
---|
135 | try
|
---|
136 | Content := TMemoryStream.Create;
|
---|
137 | if GetFile(URL, Content) then begin
|
---|
138 | try
|
---|
139 | ReadXMLFile(XmlDocument, Content);
|
---|
140 | if XmlDocument.DocumentElement.NodeName <> 'SourceList' then
|
---|
141 | raise Exception.Create(SWrongFileFormat);
|
---|
142 | Node1 := XmlDocument.DocumentElement.FindNode('Items');
|
---|
143 | if Assigned(Node1) then begin
|
---|
144 | Node2 := Node1.FirstChild;
|
---|
145 | while Assigned(Node2) and (Node2.NodeName = 'Source') do begin
|
---|
146 | Node3 := Node2.FindNode('Version');
|
---|
147 | if Assigned(Node3) then
|
---|
148 | FVersionInfo.Version := UTF8Encode(string(Node3.TextContent));
|
---|
149 | Node3 := Node2.FindNode('Id');
|
---|
150 | if Assigned(Node3) then
|
---|
151 | FVersionInfo.Id := StrToInt(Node3.TextContent);
|
---|
152 | Node3 := Node2.FindNode('SourceURL');
|
---|
153 | if Assigned(Node3) then
|
---|
154 | FVersionInfo.SourceURL := UTF8Encode(string(Node3.TextContent));
|
---|
155 | Node3 := Node2.FindNode('ReleaseTime');
|
---|
156 | if Assigned(Node3) then
|
---|
157 | FVersionInfo.ReleaseTime := XMLTimeToDateTime(Node3.TextContent);
|
---|
158 | Node3 := Node2.FindNode('ReleaseNotes');
|
---|
159 | if Assigned(Node3) then
|
---|
160 | FVersionInfo.ReleaseNotes := UTF8Encode(string(Node3.TextContent));
|
---|
161 | Node2 := Node2.NextSibling;
|
---|
162 | end;
|
---|
163 | end;
|
---|
164 | Result := True;
|
---|
165 | finally
|
---|
166 | XmlDocument.Free;
|
---|
167 | end;
|
---|
168 | end;
|
---|
169 | finally
|
---|
170 | Content.Free;
|
---|
171 | end;
|
---|
172 | end;
|
---|
173 |
|
---|
174 | procedure TUpdateChecker.Download;
|
---|
175 | begin
|
---|
176 | if FVersionInfo.SourceURL <> '' then begin
|
---|
177 | if FileExistsUTF8(FVersionInfo.SourceURL) then
|
---|
178 | InstallerFileName := FVersionInfo.SourceURL
|
---|
179 | else begin
|
---|
180 | InstallerFileName := UTF8Encode(GetTempDir) + DirectorySeparator +
|
---|
181 | ExtractFileName(FVersionInfo.SourceURL);
|
---|
182 | HTTPSender.Clear;
|
---|
183 | try
|
---|
184 | FormDownloadProgress.Show;
|
---|
185 | FormDownloadProgress.ProgressBar1.Max := 0;
|
---|
186 | FormDownloadProgress.LabelFileName.Caption := VersionInfo.SourceURL;
|
---|
187 | HTTPSender.Sock.OnStatus := SockStatus;
|
---|
188 | if HTTPSender.HTTPMethod('GET', FVersionInfo.SourceURL) then
|
---|
189 | HTTPSender.Document.SaveToFile(InstallerFileName);
|
---|
190 | finally
|
---|
191 | FormDownloadProgress.Hide;
|
---|
192 | HTTPSender.Sock.OnStatus := nil;
|
---|
193 | end;
|
---|
194 | end;
|
---|
195 | end;
|
---|
196 | end;
|
---|
197 |
|
---|
198 | procedure TUpdateChecker.Install;
|
---|
199 | var
|
---|
200 | Process: TProcess;
|
---|
201 | begin
|
---|
202 | if FileExistsUTF8(InstallerFileName) then begin
|
---|
203 | if not IsSystemAdmin then begin
|
---|
204 | RunAsAdmin(FormNewVersionOffer.Handle, InstallerFileName, '');
|
---|
205 | (*try
|
---|
206 | Process := TProcess.Create(nil);
|
---|
207 | Process.CommandLine := 'runas ' + InstallerFileName;
|
---|
208 | Process.Options := Process.Options + [];
|
---|
209 | //Process.Execute;
|
---|
210 | finally
|
---|
211 | Process.Free;
|
---|
212 | end*)
|
---|
213 | end else
|
---|
214 | try
|
---|
215 | Process := TProcess.Create(nil);
|
---|
216 | Process.CommandLine := InstallerFileName;
|
---|
217 | Process.Options := Process.Options + [];
|
---|
218 | Process.Execute;
|
---|
219 | finally
|
---|
220 | Process.Free;
|
---|
221 | end;
|
---|
222 | if Assigned(FOnTerminate) then FOnTerminate(Self);
|
---|
223 | end else ShowMessage(Format(SCantExecuteFile, [InstallerFileName]));
|
---|
224 | end;
|
---|
225 |
|
---|
226 | procedure TUpdateChecker.Check(CurrentReleaseDate: TDateTime);
|
---|
227 | begin
|
---|
228 | if LoadVersionInfo([viiReleaseTime]) then begin
|
---|
229 | if VersionInfo.ReleaseTime > CurrentReleaseDate then begin
|
---|
230 | LoadVersionInfo([viiVersion, viiReleaseTime, viiReleaseNotes, viiSourceURL]);
|
---|
231 | try
|
---|
232 | FormNewVersionOffer := TFormNewVersionOffer.Create(nil);
|
---|
233 | FormNewVersionOffer.LabelQuestion.Caption := Format(SNewVersionAvailable, [VersionInfo.Version]);
|
---|
234 | FormNewVersionOffer.MemoReleaseNotes.Lines.Text := Trim(StripTags(VersionInfo.ReleaseNotes));
|
---|
235 | if ShowReleaseNotes then FormNewVersionOffer.BitBtnWhatsNew.Click;
|
---|
236 | if FormNewVersionOffer.ShowModal = mrYes then begin
|
---|
237 | Download;
|
---|
238 | Install;
|
---|
239 | end;
|
---|
240 | finally
|
---|
241 | FormNewVersionOffer.Free;
|
---|
242 | end;
|
---|
243 | end else ShowMessage(SYouHaveLatestVersion);
|
---|
244 | end else ShowMessage(SErrorCheckingNewVersion);
|
---|
245 | end;
|
---|
246 |
|
---|
247 | function TUpdateChecker.DownloadHTTP(URL, TargetFile: string): Boolean;
|
---|
248 | // Download file; retry if necessary.
|
---|
249 | // Deals with SourceForge download links
|
---|
250 | // Could use Synapse HttpGetBinary, but that doesn't deal
|
---|
251 | // with result codes (i.e. it happily downloads a 404 error document)
|
---|
252 | const
|
---|
253 | MaxRetries = 3;
|
---|
254 | var
|
---|
255 | HTTPGetResult: Boolean;
|
---|
256 | RetryAttempt: Integer;
|
---|
257 | begin
|
---|
258 | Result := False;
|
---|
259 | RetryAttempt := 1;
|
---|
260 | //Optional: mangling of Sourceforge file download URLs; see below.
|
---|
261 | //URL:=SourceForgeURL(URL); //Deal with sourceforge URLs
|
---|
262 | try
|
---|
263 | // Try to get the file
|
---|
264 | HTTPGetResult := HTTPSender.HTTPMethod('GET', URL);
|
---|
265 | while (not HTTPGetResult) and (RetryAttempt < MaxRetries) do
|
---|
266 | begin
|
---|
267 | Sleep(500 * RetryAttempt);
|
---|
268 | HTTPGetResult := HTTPSender.HTTPMethod('GET', URL);
|
---|
269 | Inc(RetryAttempt);
|
---|
270 | end;
|
---|
271 | // If we have an answer from the server, LoadVersionInfo if the file
|
---|
272 | // was sent to us.
|
---|
273 | case HTTPSender.Resultcode of
|
---|
274 | 100..299:
|
---|
275 | begin
|
---|
276 | with TFileStream.Create(TargetFile,fmCreate or fmOpenWrite) do
|
---|
277 | try
|
---|
278 | Seek(0, soFromBeginning);
|
---|
279 | CopyFrom(HTTPSender.Document, 0);
|
---|
280 | finally
|
---|
281 | Free;
|
---|
282 | end;
|
---|
283 | Result := True;
|
---|
284 | end; //informational, success
|
---|
285 | 300..399: Result := False; //redirection. Not implemented, but could be.
|
---|
286 | 400..499: Result := False; //client error; 404 not found etc
|
---|
287 | 500..599: Result := False; //internal server error
|
---|
288 | else Result := False; //unknown code
|
---|
289 | end;
|
---|
290 | except
|
---|
291 | // We don't care for the reason for this error; the download failed.
|
---|
292 | Result := False;
|
---|
293 | end;
|
---|
294 | end;
|
---|
295 |
|
---|
296 | constructor TUpdateChecker.Create(AOwner: TComponent);
|
---|
297 | begin
|
---|
298 | inherited;
|
---|
299 | FVersionInfoURL := 'http://localhost/VersionInfo.xml';
|
---|
300 | HTTPSender := THTTPSend.Create;
|
---|
301 | FormDownloadProgress := TFormDownloadProgress.Create(nil);
|
---|
302 | end;
|
---|
303 |
|
---|
304 | destructor TUpdateChecker.Destroy;
|
---|
305 | begin
|
---|
306 | FormDownloadProgress.Free;
|
---|
307 | HTTPSender.Free;
|
---|
308 | inherited;
|
---|
309 | end;
|
---|
310 |
|
---|
311 | {$IFDEF Windows}
|
---|
312 | function TUpdateChecker.IsSystemAdmin: Boolean;
|
---|
313 | var
|
---|
314 | hAccessToken: THandle;
|
---|
315 | ptgGroups: PTokenGroups;
|
---|
316 | dwInfoBufferSize: DWORD;
|
---|
317 | psidAdministrators: PSID;
|
---|
318 | g: Integer;
|
---|
319 | bSuccess: BOOL;
|
---|
320 | begin
|
---|
321 | Result := False;
|
---|
322 | bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True, hAccessToken) ;
|
---|
323 | if not bSuccess then
|
---|
324 | begin
|
---|
325 | if GetLastError = ERROR_NO_TOKEN then
|
---|
326 | bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY, hAccessToken) ;
|
---|
327 | end;
|
---|
328 |
|
---|
329 | if bSuccess then
|
---|
330 | begin
|
---|
331 | GetMem(ptgGroups, 1024) ;
|
---|
332 |
|
---|
333 | bSuccess := GetTokenInformation(hAccessToken, TokenGroups, ptgGroups, 1024, dwInfoBufferSize) ;
|
---|
334 |
|
---|
335 | CloseHandle(hAccessToken) ;
|
---|
336 |
|
---|
337 | if bSuccess then
|
---|
338 | begin
|
---|
339 | AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdministrators) ;
|
---|
340 |
|
---|
341 | for g := 0 to ptgGroups^.GroupCount - 1 do
|
---|
342 | if EqualSid(psidAdministrators, ptgGroups^.Groups[g].Sid) then
|
---|
343 | begin
|
---|
344 | Result := True;
|
---|
345 | Break;
|
---|
346 | end;
|
---|
347 |
|
---|
348 | FreeSid(psidAdministrators) ;
|
---|
349 | end;
|
---|
350 |
|
---|
351 | FreeMem(ptgGroups) ;
|
---|
352 | end;
|
---|
353 | end;
|
---|
354 | {$ELSE}
|
---|
355 | function TUpdateChecker.IsSystemAdmin: Boolean;
|
---|
356 | begin
|
---|
357 | Result := False;
|
---|
358 | end;
|
---|
359 |
|
---|
360 | {$ENDIF}
|
---|
361 |
|
---|
362 | procedure TUpdateChecker.SockStatus(Sender: TObject; Reason: THookSocketReason;
|
---|
363 | const Value: String);
|
---|
364 | var
|
---|
365 | Num: Integer;
|
---|
366 | begin
|
---|
367 | if (Reason = HR_SocketCreate) and TryStrToInt(Value, Num) then begin
|
---|
368 | FormDownloadProgress.ProgressBar1.Position := Num;
|
---|
369 | Application.ProcessMessages;
|
---|
370 | end;
|
---|
371 | if (Reason = HR_ReadCount) and TryStrToInt(Value, Num) then begin
|
---|
372 | if HTTPSender.DownloadSize <> 0 then
|
---|
373 | FormDownloadProgress.ProgressBar1.Max := HTTPSender.DownloadSize;
|
---|
374 | with FormDownloadProgress.ProgressBar1 do begin
|
---|
375 | Position := Position + Num;
|
---|
376 | FormDownloadProgress.LabelProgress.Caption :=
|
---|
377 | IntToStr(Position) + ' / ' + IntToStr(Max);
|
---|
378 | end;
|
---|
379 | Application.ProcessMessages;
|
---|
380 | end;
|
---|
381 | end;
|
---|
382 |
|
---|
383 | function TUpdateChecker.StripTags(XMLText: string): string;
|
---|
384 | begin
|
---|
385 | Result := '';
|
---|
386 | while Pos('<', XMLText) > 0 do begin
|
---|
387 | Result := Result + Copy(XMLText, 1, Pos('<', XMLText) - 1);
|
---|
388 | Delete(XMLText, 1, Pos('<', XMLText));
|
---|
389 | Delete(XMLText, 1, Pos('>', XMLText));
|
---|
390 | end;
|
---|
391 | Result := Result + XMLText;
|
---|
392 | end;
|
---|
393 |
|
---|
394 | function TUpdateChecker.GetFile(URI: string; Content: TMemoryStream): Boolean;
|
---|
395 | var
|
---|
396 | Buffer: array of Byte;
|
---|
397 | FileStream: TFileStream;
|
---|
398 | begin
|
---|
399 | Result := False;
|
---|
400 | Content.Size := 0;
|
---|
401 | if FileExistsUTF8(URI) then
|
---|
402 | try
|
---|
403 | FileStream := TFileStream.Create(URI, fmOpenRead);
|
---|
404 | Content.CopyFrom(FileStream, FileStream.Size);
|
---|
405 | Content.Position := 0;
|
---|
406 | Result := True;
|
---|
407 | finally
|
---|
408 | FileStream.Free;
|
---|
409 | end else
|
---|
410 | if (Copy(URI, 1, 7) = 'http://') or (Copy(URI, 1, 8) = 'https://') then
|
---|
411 | with THTTPSend.Create do
|
---|
412 | try
|
---|
413 | Clear;
|
---|
414 | if HTTPMethod('GET', URI) then begin
|
---|
415 | Document.Position := 0;
|
---|
416 | Content.CopyFrom(Document, Document.Size);
|
---|
417 | Content.Position := 0;
|
---|
418 | Result := True;
|
---|
419 | end;
|
---|
420 | finally
|
---|
421 | Free;
|
---|
422 | end;
|
---|
423 | end;
|
---|
424 |
|
---|
425 | end.
|
---|
426 |
|
---|