unit httpThread;
interface
uses
Classes,
SysUtils,
Dialogs,
Forms,
Controls,
ShellAPI,
Windows,
IdComponent,
IdTCPConnection,
IdTCPClient,
IdHTTP,
IdURI,
IdCookieManager,
IdIOHandler,
IdIOHandlerSocket,
IdIOHandlerStack,
IdSSL,
IdSSLOpenSSL,
IdCoder,
xmldom,
XMLIntf,
msxmldom,
XMLDoc,
ActiveX;
type
tLogMessageProc =
procedure(
const aMessage:
string)
of object;
http =
class(TThread)
private
{ Private-Deklarationen }
fhttp: TIdHttp;
fUser, fPass, fHardwarekennung, fURL, fcfg, fsrc, fsalt:
string;
fLogError: tLogMessageProc;
flogMessage: tLogMessageProc;
/// <summary>
/// Returns true if there is a Problem
/// </summary>
function checkProblem(
const aXMLNodes: iXMLNodeList): boolean;
procedure doApplicationUpdate(fparams: tstringlist;
const nlist: iXMLNodeList;
const PHPXML: IXMLDOCUMENT);
procedure doDownloadFile(
const aFilename, aTimestamp:
string);
procedure doXMLDecode(
const nlist: iXMLNodeList);
procedure logError(
const aMessage:
string);
procedure logmessage(
const aMessage:
string);
procedure FillParams(
const Values: Tstrings);
procedure showMessageinMainThread(
const aMessage:
string);
function getxmlFromServer(aXML: IXMLDOCUMENT; aServer: TIdHttp;
const aUrl:
string; aParams: Tstrings): boolean;
protected
procedure Execute;
override;
public
constructor Create(
const User, Pass, Hardwarekennung,
URL, cfg, src, salt:
string; aLogerror: tLogMessageProc;
aLogMessage: tLogMessageProc);
end;
implementation
function getVersion:
string;
begin
result := '
unknown';
end;
function http.checkProblem(
const aXMLNodes: iXMLNodeList): boolean;
begin
result := true;
if (aXMLNodes.FindNode('
problem') <>
nil)
then
begin
if (((aXMLNodes.FindNode('
blocked') <>
nil))
and (aXMLNodes.FindNode('
blocked').Text > '
0000-00-00 00:00:00'))
or
(((aXMLNodes.FindNode('
removed') <>
nil))
and (aXMLNodes.FindNode('
removed').Text > '
0000-00-00 00:00:00'))
then
begin
try
DeleteFile(PChar(fcfg));
except
end;
Application.Terminate;
end;
Queue(
procedure
begin
showmessage('
Username or password not valid. Please check your input.');
end);
// 'Username or password not valid. Please check your input.'
exit;
end;
result := False;
end;
procedure http.doApplicationUpdate(fparams: tstringlist;
const nlist: iXMLNodeList;
const PHPXML: IXMLDOCUMENT);
var
sFile: TStream;
sFilename:
string;
begin
// Versionscheck und ggf. Download der aktuellen Version
if (nlist.FindNode('
version') <>
nil)
then
if (PHPXML.DocumentElement.ChildNodes.FindNode('
version').Text <> getVersion)
then
// Das geht auch in die Hose aus einem Thread heraus
// if (MessageDlg(language.Label4.Caption + PHPXML.DocumentElement.ChildNodes.FindNode('version').Text + '!' + #13#10 +
// language.label5.Caption, mtConfirmation, mbYesNo, 0) = mrYes) then
begin
// download.Show;
sFilename := extractfilepath(paramstr(0)) + '
update.exe';
try
DeleteFile(PChar(sFilename))
except
on e:
exception do
logError(e.
message);
end;
sFile := TFileStream.Create(sFilename, fmCreate);
try
fparams.Text := '
RPC=update';
fhttp.Post(TIdURI.URLEncode(fURL), fparams, sFile);
finally
sFile.Free;
end;
ShellExecute(
handle, '
open', PChar(sFilename), PChar('
'), '
', SW_SHOWNORMAL);
/// SP- /VERYSILENT
Application.Terminate;
end;
end;
procedure http.doDownloadFile(
const aFilename, aTimestamp:
string);
var
lparams: tstringlist;
sFile: TStream;
sFilename:
string;
begin
sFilename := extractfilepath(paramstr(0)) + aFilename;
sFile := TFileStream.Create(sFilename, fmCreate);
lparams := tstringlist.Create;
try
lparams.Text := '
RPC=download';
lparams.Add('
file=' + aFilename);
logmessage('
Try to get File ' + aFilename);
fhttp.Post(TIdURI.URLEncode(fURL), lparams, sFile);
// sFile fileStream
finally
lparams.Free;
fhttp.Response.Clear;
sFile.Free;
{ TODO : Auskommentiert da die Unit nicht da ist }
// SetFileDate(sFilename, UnixToDateTime(aTimestamp);
end;
end;
procedure http.doXMLDecode(
const nlist: iXMLNodeList);
var
cfgdata: tstringlist;
begin
// XML Verschlüsseln und Speichern
try
DeleteFile(PChar(fcfg))
except
on e:
exception do
logError(e.
message);
end;
try
// Wirklich asynchron?
Queue(
procedure
begin
{ TODO : Besser hier eine eigene Mime Class benutzen }
// Form1.xml.LoadFromXML(Form1.IdDecoderMIME1.DecodeString(nlist.FindNode('cfg').Text, SysUtils.TUTF8Encoding.UTF8));
cfgdata := tstringlist.Create;
try
{ TODO : Auskommentiert da die Unit nicht da ist }
// cfgdata.Text := functions.Encrypt(Form1.xml.xml.Text, fsalt + fUser + fPass + fHardwarekennung);
cfgdata.SaveToFile(fcfg);
finally
cfgdata.Free;
end;
end);
except
on e:
exception do
logError(e.
message);
end;
end;
procedure http.logError(
const aMessage:
string);
begin
if assigned(fLogError)
then
Queue(
procedure
begin
fLogError(aMessage);
{ problem connecting server } { TODO Offline Modus starten }
end);
end;
procedure http.logmessage(
const aMessage:
string);
begin
if assigned(flogMessage)
then
Queue(
procedure
begin
flogMessage(aMessage);
end);
end;
procedure http.FillParams(
const Values: Tstrings);
begin
Values.Clear;
Values.Add('
RPC=login');
Values.Add('
username=' + fUser);
Values.Add('
password=' + fPass);
Values.Add('
hardware=' + fHardwarekennung);
end;
procedure http.showMessageinMainThread(
const aMessage:
string);
begin
Queue(
procedure
begin
showmessage(aMessage);
end);
end;
function http.getxmlFromServer(aXML: IXMLDOCUMENT; aServer: TIdHttp;
const aUrl:
string; aParams: Tstrings): boolean;
var
s:
string;
begin
result := False;
s := aServer.Post(TIdURI.URLEncode(fURL), aParams);
try
aXML.LoadFromXML(s);
aXML.Active := true;
result := (
not aXML.IsEmptyDoc)
and (aXML.DocumentElement.HasChildNodes);
except
on e:
exception do
logError(e.
message);
end;
end;
procedure http.Execute;
var
currentList: tstringlist;
flist: iXMLNodeList;
fparams: tstringlist;
i: integer;
nlist: iXMLNodeList;
pfad:
string;
PHPXML: IXMLDOCUMENT;
s:
string;
s1:
string;
begin
CoInitialize(
nil);
PHPXML := NewXMLDocument;
fhttp := TIdHttp.Create(
nil);
fparams := tstringlist.Create;
try
fhttp.HandleRedirects := true;
fhttp.AllowCookies := true;
fhttp.ReadTimeout := 15000;
// Sonst Timeouts auf > Windows 8 BSystemen
fhttp.IOHandler := TIdSSLIOHandlerSocketOpenSSL.Create(fhttp);
FillParams(fparams);
if getxmlFromServer(PHPXML, fhttp, fURL, fparams)
then
begin
nlist := PHPXML.DocumentElement.ChildNodes;
if checkProblem(nlist)
then
exit;
doXMLDecode(nlist);
// APPLICATION UPDATE
doApplicationUpdate(fparams, nlist, PHPXML);
// CONTENT UPDATE
currentList := tstringlist.Create;
try
currentList.Sorted := true;
// functions.FindAllFilesUnix(currentList, fsrc, '*', true, False, true, true); // Dateiliste erstellen
pfad := extractfilepath(paramstr(0));
s1 := PHPXML.DocumentElement.ChildNodes.FindNode('
filelist').xml;
for i := currentList.Count - 1
downto 0
do
begin
s := copy(currentList[i], length(fsrc) + 1);
s := copy(s, 0, pos(#255, s) - 1);
if (pos('
\', s) < 1)
and ((extractfileext(s) = '
')
or (lowercase(extractfileext(s)) = '
.xml'))
then
continue;
// APPDATEN: Übergehen - Dateien ohne Endung, Dateien mit Endung XML
s := copy(currentList[i], length(pfad) + 1);
s := copy(s, 0, pos(#255, s) - 1);
if (pos('
>' + s + '
</file>', s1) < 1)
then
DeleteFile(PChar(s));
// löschen
end;
flist := PHPXML.DocumentElement.ChildNodes.FindNode('
filelist').ChildNodes;
logmessage('
flist.count: ' + inttostr(flist.Count));
for i := flist.Count - 1
downto 0
do
begin
if (pos(flist[i].NodeValue + #255 + flist[i].Attributes['
timestamp'], currentList.Text) > 0)
then
continue;
// Datumsvergleich
logmessage('
entry ' + inttostr(i) + '
: ' + flist[i].NodeValue + #255 + flist[i].Attributes['
timestamp']);
// Download
doDownloadFile(flist[i].NodeValue, flist[i].Attributes['
timestamp']);
end;
finally
currentList.Free;
end;
// Applikation laden
end
else
showMessageinMainThread('
problem connecting server');
finally
try
fparams.Text := '
RPC=logout';
fhttp.Post(TIdURI.URLEncode(fURL), fparams);
except
on e:
exception do
logError(e.
message);
end;
fhttp.Free;
fparams.Free;
end;
// Self.Terminate;
end;
constructor http.Create(
const User, Pass, Hardwarekennung,
URL, cfg, src, salt:
string; aLogerror: tLogMessageProc;
aLogMessage: tLogMessageProc);
begin
inherited Create(False);
FreeOnTerminate := true;
fUser := User;
fPass := Pass;
fHardwarekennung := Hardwarekennung;
fURL :=
URL;
fcfg := cfg;
fsrc := src;
fsalt := salt;
fLogError := aLogerror;
flogMessage := aLogMessage;
// Self.Execute; /// Niemals selber aufrufen
end;
end.