source: UpdateChecker/UUpdateChecker.pas

Last change on this file was 433, checked in by chronos, 13 years ago
  • Added: Custom new version info form with option to show release notes.
  • Fixed: Run setup with elevated privileges.
  • Added: Can read version info file from local filesystem.
  • Added: Demo application.
File size: 13.2 KB
Line 
1unit UUpdateChecker;
2
3{$mode delphi}{$H+}
4
5interface
6
7uses
8 {$IFDEF Windows}Windows, ShellApi, {$ENDIF}Forms, Classes, SysUtils,
9 httpsend, DOM, XMLWrite, XMLRead, UXMLUtils,
10 FileUtil, Dialogs, Process, Blcksock, UFormDownloadProgress, Controls;
11
12type
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
59procedure Register;
60
61resourcestring
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
76implementation
77
78uses
79 UFormNewVersionOffer;
80
81{$IFDEF Windows}
82const
83 SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority = (Value: (0, 0, 0, 0, 0, 5)) ;
84
85const
86 SECURITY_BUILTIN_DOMAIN_RID = $00000020;
87 DOMAIN_ALIAS_RID_ADMINS = $00000220;
88{$ENDIF}
89
90procedure Register;
91begin
92 RegisterComponents('Samples', [TUpdateChecker]);
93end;
94
95function RunAsAdmin(const Handle: Hwnd; const Path, Params: string): Boolean;
96var
97 sei: TShellExecuteInfoA;
98begin
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);
108end;
109
110{ TUpdateChecker }
111
112function TUpdateChecker.LoadVersionInfo(Items: TVersionInfoItems = []): Boolean;
113var
114 URL: string;
115 XmlDocument: TXMLDocument;
116 Node1: TDOMNode;
117 Node2: TDOMNode;
118 Node3: TDOMNode;
119 Content: TMemoryStream;
120begin
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;
172end;
173
174procedure TUpdateChecker.Download;
175begin
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;
196end;
197
198procedure TUpdateChecker.Install;
199var
200 Process: TProcess;
201begin
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]));
224end;
225
226procedure TUpdateChecker.Check(CurrentReleaseDate: TDateTime);
227begin
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);
245end;
246
247function 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)
252const
253 MaxRetries = 3;
254var
255 HTTPGetResult: Boolean;
256 RetryAttempt: Integer;
257begin
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;
294end;
295
296constructor TUpdateChecker.Create(AOwner: TComponent);
297begin
298 inherited;
299 FVersionInfoURL := 'http://localhost/VersionInfo.xml';
300 HTTPSender := THTTPSend.Create;
301 FormDownloadProgress := TFormDownloadProgress.Create(nil);
302end;
303
304destructor TUpdateChecker.Destroy;
305begin
306 FormDownloadProgress.Free;
307 HTTPSender.Free;
308 inherited;
309end;
310
311{$IFDEF Windows}
312function TUpdateChecker.IsSystemAdmin: Boolean;
313var
314 hAccessToken: THandle;
315 ptgGroups: PTokenGroups;
316 dwInfoBufferSize: DWORD;
317 psidAdministrators: PSID;
318 g: Integer;
319 bSuccess: BOOL;
320begin
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;
353end;
354{$ELSE}
355function TUpdateChecker.IsSystemAdmin: Boolean;
356begin
357 Result := False;
358end;
359
360{$ENDIF}
361
362procedure TUpdateChecker.SockStatus(Sender: TObject; Reason: THookSocketReason;
363 const Value: String);
364var
365 Num: Integer;
366begin
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;
381end;
382
383function TUpdateChecker.StripTags(XMLText: string): string;
384begin
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;
392end;
393
394function TUpdateChecker.GetFile(URI: string; Content: TMemoryStream): Boolean;
395var
396 Buffer: array of Byte;
397 FileStream: TFileStream;
398begin
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;
423end;
424
425end.
426
Note: See TracBrowser for help on using the repository browser.