unit Unit1;
interface
uses
Windows, Messages, SysUtils, ShellApi, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, IdScheduler, IdSchedulerOfThread,
IdSchedulerOfThreadDefault, IdIntercept, IdServerInterceptLogBase,
IdServerInterceptLogEvent, IdServerIOHandler, IdServerIOHandlerSocket,
IdServerIOHandlerStack, IdBaseComponent, IdComponent, IdCustomTCPServer,
IdTCPServer, IdContext, IdCustomHTTPServer, IdHTTPServer, IdHTTPHeaderInfo,
Menus;
type
TForm1 =
class(TForm)
IdHTTPServer1: TIdHTTPServer;
IdServerIOHandlerStack2: TIdServerIOHandlerStack;
IdServerInterceptLogEvent2: TIdServerInterceptLogEvent;
IdSchedulerOfThreadDefault2: TIdSchedulerOfThreadDefault;
Memo1: TMemo;
MainMenu1: TMainMenu;
Server1: TMenuItem;
Aktivieren1: TMenuItem;
N1: TMenuItem;
Beenden1: TMenuItem;
procedure IdServerInterceptLogEvent2LogString(
ASender: TIdServerInterceptLogEvent; AText:
String);
procedure FormClose(Sender: TObject;
var Action: TCloseAction);
procedure IdServerIOHandlerStack2Status(ASender: TObject;
const AStatus: TIdStatus;
const AStatusText:
String);
procedure FormCreate(Sender: TObject);
procedure IdHTTPServer1CreatePostStream(AContext: TIdContext;
var VPostStream: TStream);
procedure IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure Aktivieren1Click(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
//function fib(n:Integer):Integer; begin if (n <= 2) then result:=1 else result:=fib(n-1) + fib(n-2); end;
function HTMLFormTitel:
string;
begin
Result := '
<center><font color="#C0C0C0" size="6">Server Remote Panel</font></center>';
end;
function HTMLFormMain(Inhalt:
string):
string;
begin
Result := '
<td align="left" width="85%" valign="top" style="word-spacing: 1; margin: 1" bgcolor="#C0C0C0"></font><font face="Arial" color="#000000">'+Inhalt+'
</font><font face="Arial"></td>';
end;
function HTMLFormLinks:
string;
begin
Result :=
'
<td width="15%" align="center" valign="top" bgcolor="#800000" style="color: #C0C0C0">'+
'
[url="/"]Home[/url]
'+
'
[url="/upload/"]Upload[/url]
'+
'
[url="/info/"]Info[/url]
'+
'
[url="/ausfuehren/"]Anwendung starten[/url]</td>';
end;
function HTMLFormUnten:
string;
begin
Result :=
'
</tr>'+
'
</table>'+
'
</font>'+
'
</body>'+
'
</html>';
end;
function HtmlFormOben(Title:
string):
string;
begin
Result:=
'
<html>'+
'
<head>'+
'
<meta http-equiv="Content-Language" content="de">'+
'
<meta http-equiv="Content-Type" content="text/html; charset=windows-1252">'+
'
<title>'+ Title +'
</title>'+
'
</head>'+
'
<body topmargin="0" leftmargin="0" rightmargin="0" bottommargin="0" marginwidth="0" marginheight="0" bgcolor="#000000" link="#C0C0C0" vlink="#C0C0C0" alink="#C0C0C0" text="#000000">'+
'
<font face="Arial">'+
'
<table border="0" width="1000" id="table1" style="border-collapse: collapse" height="332">'+
'
<tr>'+
'
<td height="70" colspan="2" bgcolor="#800000">'+ HTMLFormTitel +'
</td>'+
'
</tr>'+
'
<tr>';
end;
function HTMLFormKomplett(FormObenTitel:
string;FormInhalt:
string):
string;
begin
Result :=
HTMLFormOben(FormObenTitel)+HTMLFormLinks+HTMLFormMain(FormInhalt)+HTMLFormUnten;
end;
function HtmlForm:
string;
begin
Result:=
HTMLFormKomplett('
Home',
'
<p align="center">
Home
'
);
end;
function HtmlInfoForm:
string;
begin
Result:=
HTMLFormKomplett('
Info',
'
<p align="center">
Info
'
);
end;
function HtmlAusfuehrenForm:
string;
begin
Result:=
HTMLFormKomplett('
Anwendung starten',
'
<form method="POST" action="/execute/"><p align="center">
Anwendung starten
'+
'
<p align="center"><input type="text" name="filename" size="20"><input type="submit" value="Ausführen" name="execute"><input type="reset" value="Reset" name="reset"></p>'+
'
</form>'
);
end;
function HtmlUploadForm:
string;
begin
Result:=
HTMLFormKomplett('
Upload',
'
<form action="/uploading/" method=post enctype="multipart/form-data">'+
'
<p align="center">
Upload
'+
'
<input type=file name=file><input type=submit value=Upload></p>'+
'
</form>'
);
end;
function HTMLUploadMessage(msg:
String):
string;
begin
Result:=
HTMLFormKomplett(msg,
'
<center><h1>File Upload</h1>
'+msg+'
'+
'
[url="/><font"]Click here to continue</font>[/url]</center>'
);
end;
function HTMLExecuteMessage(msg:
String;Error:boolean):
string;
begin
If Error = False
then
begin
Result:=
HTMLFormKomplett('
Programm Ausführen',
'
<center><h1>Programm Ausführen</h1>
'+msg+'
gestartet!
'+
'
[url="/><font"]Click here to continue</font>[/url]</center>'
);
end
else
begin
Result:=
HTMLFormKomplett('
Programm Ausführen',
'
<center><h1>Programm Ausführen</h1>
'+msg+'
konnte nicht gestartet werden!
'+
'
[url="/><font"]Click here to continue</font>[/url]</center>'
);
end;
end;
procedure TForm1.IdServerInterceptLogEvent2LogString(
ASender: TIdServerInterceptLogEvent; AText:
String);
begin
Memo1.Lines.Add(AText);
end;
procedure TForm1.FormClose(Sender: TObject;
var Action: TCloseAction);
begin
IdHTTPServer1.Active := False;
end;
procedure TForm1.IdServerIOHandlerStack2Status(ASender: TObject;
const AStatus: TIdStatus;
const AStatusText:
String);
begin
Memo1.Lines.Add(AStatusText);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
LongTimeFormat:='
hh.mm.ss';
ShortDateFormat:='
dd.MM.yy';
end;
procedure TForm1.IdHTTPServer1CreatePostStream(AContext: TIdContext;
var VPostStream: TStream);
begin
VPostStream:=TMemoryStream.Create;
end;
procedure TForm1.IdHTTPServer1CommandGet(AContext: TIdContext;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
Var TheFile:TMemoryStream;
FN:
String;
Error:boolean;
begin
If ARequestInfo.Document='
/'
Then begin
With AResponseInfo
do begin
ContentText:=HtmlForm;
WriteContent;
end;
end;
If ARequestInfo.Document='
/ausfuehren/'
Then begin
With AResponseInfo
do begin
ContentText:=HtmlAusfuehrenForm;
WriteContent;
end;
end;
If ARequestInfo.Document='
/info/'
Then begin
With AResponseInfo
do begin
ContentText:=HtmlInfoForm;
WriteContent;
end;
end;
If ARequestInfo.Document='
/upload/'
Then begin
With AResponseInfo
do begin
ContentText:=HtmlUploadForm;
WriteContent;
end;
end;
If ARequestInfo.Document='
/execute/'
Then begin
With AResponseInfo
do begin
Error := False;
if ShellExecute(Application.Handle, '
open', PChar(ARequestInfo.Params.Values['
filename']),
Nil,
Nil, SW_NORMAL) <= 32
then
Error := True;
ContentText:= HTMLExecuteMessage(ARequestInfo.Params.Values['
filename'],Error);
WriteContent;
end;
end;
if ARequestInfo.Document='
/uploading/'
then begin
FN := ARequestInfo.Params.Values['
filename'];
TheFile:=TMemoryStream.Create;
try
try
TheFile.LoadFromStream(ARequestInfo.PostStream);
TheFile.SaveToFile('
.\'+DateToStr(now)+'
'+TimeToStr(now)+'
'+ARequestInfo.RemoteIP+'
'+'
.unbekannt'+FN);
With AResponseInfo
do begin
ContentText:=HtmlUploadMessage('
Upload Successful!');
WriteContent;
end;
except
With AResponseInfo
do begin
ContentText:=HTMLUploadMessage('
Upload Error!');
WriteContent;
end;
end;
finally
TheFile.Free;
end;
end;
end;
procedure TForm1.Aktivieren1Click(Sender: TObject);
begin
If IdHTTPServer1.Active = False
then
begin
IdHTTPServer1.Active := True;
Aktivieren1.Caption := '
Deaktivieren';
end
else
begin
IdHTTPServer1.Active := False;
Aktivieren1.Caption := '
Aktivieren';
end;
end;
end.