unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ActnList, StdCtrls, IdComponent, IdTCPServer, IdHTTPServer, Buttons,
ComCtrls, IdGlobal, IdBaseComponent, IdThreadMgr, IdThreadMgrDefault, syncobjs,
IdThreadMgrPool, ExtCtrls, IdIntercept, IdIOHandlerSocket,
IdCustomHTTPServer, idSocketHandle, XPMan, FileCtrl, IdStack;
type
TForm1 =
class(TForm)
GroupBox1: TGroupBox;
XPManifest1: TXPManifest;
Label1: TLabel;
edPort: TEdit;
cbManageSessions: TCheckBox;
cbEnableLog: TCheckBox;
GroupBox2: TGroupBox;
Label2: TLabel;
Label3: TLabel;
name: TEdit;
passwort: TEdit;
GroupBox3: TGroupBox;
cbAuthentication: TCheckBox;
GroupBox4: TGroupBox;
lbSessionList: TListBox;
Button1: TButton;
Button2: TButton;
Button3: TButton;
Button4: TButton;
HTTPServer: TIdHTTPServer;
alGeneral: TActionList;
idLog: TListBox;
Label4: TLabel;
edroot: TEdit;
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure Button4Click(Sender: TObject);
procedure ManageUserSession(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
procedure ServeVirtualFolder(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
procedure HTTPServerCommandGet(AThread: TIdPeerThread;
ARequestInfo: TIdHTTPRequestInfo;
AResponseInfo: TIdHTTPResponseInfo);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure HTTPServerSessionEnd(Sender: TIdHTTPSession);
procedure HTTPServerSessionStart(Sender: TIdHTTPSession);
procedure FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
procedure lbSessionListDblClick(Sender: TObject);
procedure HTTPServerConnect(AThread: TIdPeerThread);
procedure HTTPServerExecute(AThread: TIdPeerThread);
procedure HTTPServerCommandOther(Thread: TIdPeerThread;
const asCommand, asData, asVersion:
String);
procedure HTTPServerStatus(ASender: TObject;
const AStatus: TIdStatus;
const AStatusText:
String);
private
function GetMIMEType(sFile: TFileName):
String;
public
EnableLog: boolean;
MIMEMap: TIdMIMETable;
procedure MyInfoCallback(Msg:
String);
procedure GetKeyPassword(
var Password:
String);
end;
var
Form1: TForm1;
Enablelog:Boolean;
MIMEMap: TIdMIMETable;
UILock: TCriticalSection;
an:boolean;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
Binding : TIdSocketHandle;
begin
If not httpserver.Active
then
begin
Httpserver.Bindings.Clear;
Binding:=HTTPServer.Bindings.Add;
Binding.Port:=StrToIntDef(edPort.Text,80);
Binding.IP:='
127.0.0.1';
end;
if not DirectoryExists(edRoot.text)
then
begin
idlog.Items.Add (Format('
Ordner (%s) nicht gefunden.',[edRoot.text]));
httpserver.Active:=false;
end
else
begin
try
EnableLog:=cbEnableLog.Checked;
HTTPServer.SessionState:=cbManageSessions.Checked;
HTTPServer.Active:=True;
idlog.Items.Add(format('
Hört auf HTTP-Clients auf %s:%d.',[HTTPServer.Bindings[0].IP, HTTPServer.Bindings[0].Port]));
except
on e:
exception do
begin
HTTPServer.Active:=False;
idlog.Items.Add(format('
Fehler: %s in der Aktivität. Fehler ist:"%s".', [e.ClassName, e.
Message]));
end;
end;
end;
An:=HTTPServer.Active;
edPort.Enabled:=not An;
cbAuthentication.Enabled :=
not An;
cbEnableLog.Enabled :=
not an;
cbManageSessions.Enabled :=
not an;
name.Enabled:=not an;
passwort.Enabled:=not an;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
HTTPServer.Active:=False;
An:=HTTPServer.Active;
edPort.Enabled:=not An;
cbAuthentication.Enabled :=
not An;
cbEnableLog.Enabled :=
not an;
cbManageSessions.Enabled :=
not an;
name.Enabled:=not an;
passwort.Enabled:=not an;
end;
procedure TForm1.Button4Click(Sender: TObject);
begin
Button2.Click;
Application.Terminate;
end;
procedure TForm1.ManageUserSession(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
NumberOfView: Integer;
begin
// Manage session informations
if assigned(RequestInfo.Session)
or (HTTPServer.CreateSession(AThread, ResponseInfo, RequestInfo) <>
nil)
then
begin
RequestInfo.Session.Lock;
try
NumberOfView := StrToIntDef(RequestInfo.Session.Content.Values['
NumViews'], 0);
inc(NumberOfView);
RequestInfo.Session.Content.Values['
NumViews'] := IntToStr(NumberOfView);
RequestInfo.Session.Content.Values['
UserName'] := RequestInfo.AuthUsername;
RequestInfo.Session.Content.Values['
Password'] := RequestInfo.AuthPassword;
finally
RequestInfo.Session.Unlock;
end;
end;
end;
procedure TForm1.ServeVirtualFolder(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
begin
ResponseInfo.ContentType := '
text/HTML';
ResponseInfo.ContentText := '
<html><head><title>Mappe</title></head><body>';
if AnsiSameText(RequestInfo.Params.Values['
action'], '
close')
then
begin
// Closing user session
RequestInfo.Session.Free;
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<h1>Session cleared</h1><p><a href="/sessions">Back</a></p>';
end
else
begin
if assigned(RequestInfo.Session)
then
begin
if Length(RequestInfo.Params.Values['
ParamName'])>0
then
begin
// Add a new parameter to the session
ResponseInfo.Session.Content.Values[RequestInfo.Params.Values['
ParamName']] := RequestInfo.Params.Values['
Param'];
end;
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<h1>Informationen</h1>';
RequestInfo.Session.Lock;
try
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<table border=1>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<tr><td>SessionID</td><td>' + RequestInfo.Session.SessionID + '
</td></tr>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<tr><td>Number of page requested during this session</td><td>'+RequestInfo.Session.Content.Values['
NumViews']+'
</td></tr>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<tr><td>Session data (raw)</td><td><pre>' + RequestInfo.Session.Content.Text + '
</pre></td></tr>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
</table>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<h1>Tools:</h1>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<h2>Add new parameter</h2>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<form method="POST">';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<p>Name: <input type="text" Name="ParamName"></p>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<p>value: <input type="text" Name="Param"></p>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<p><input type="Submit"><input type="reset"></p>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
</form>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<h2>Other:</h2>';
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<p><a href="' + RequestInfo.Document + '
?action=close">Close current session</a></p>';
finally
RequestInfo.Session.Unlock;
end;
end
else
begin
ResponseInfo.ContentText := ResponseInfo.ContentText + '
<p color=#FF000>No session</p>';
end;
end;
ResponseInfo.ContentText := ResponseInfo.ContentText + '
</body></html>';
end;
procedure TForm1.HTTPServerCommandGet(AThread: TIdPeerThread;
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
procedure AuthFailed;
var
ResponseInfo: TIdHTTPResponseInfo;
begin
ResponseInfo.ContentText := '
<html><head><title>Fehler</title></head><body><h1>Fehler</h1>Sie haben keine Befugnis dieses Dokument zu sehen-</body></html>';
ResponseInfo.ResponseNo := 403;
end;
procedure AccessDenied;
var RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo;
begin
ResponseInfo.ContentText := '
<html><head><title>Error</title></head><body><h1>Access denied</h1>'#13 +
'
Sie sind nicht befugt, die Seite zu öffnen.</body></html>';
ResponseInfo.ResponseNo := 403;
end;
var
LocalDoc:
string;
ByteSent: Cardinal;
ResultFile: TFileStream;
RequestInfo: TIdHTTPRequestInfo;
ResponseInfo: TIdHTTPResponseInfo;
begin
idlog.Items.Add(Format( '
Befehl %s %s empfangen von %s:%d',
[RequestInfo.Command, RequestInfo.Document,
TIdIOHandlerSocket(AThread.Connection.IOHandler).Binding.PeerIP,
TIdIOHandlerSocket(AThread.Connection.IOHandler).Binding.PeerPort]));
if cbAuthentication.Checked
and ((RequestInfo.AuthUsername <>
Name.text)
or (RequestInfo.AuthPassword <> Passwort.text))
then
begin
Authfailed;
exit;
end;
if cbManageSessions.checked
then
ManageUserSession(AThread, RequestInfo, ResponseInfo);
if (Pos('
/session', LowerCase(RequestInfo.Document)) = 1)
then
begin
ServeVirtualFolder(AThread, RequestInfo, ResponseInfo);
end
else
begin
LocalDoc := ExpandFilename(edRoot.text + RequestInfo.Document);
LocalDoc := ExpandFilename(edRoot.text + RequestInfo.Document);
if not FileExists(LocalDoc)
and DirectoryExists(LocalDoc)
and FileExists(ExpandFileName(LocalDoc + '
/index.html'))
then
begin
LocalDoc := ExpandFileName(LocalDoc + '
/index.txt');
if FileExists(LocalDoc)
then
begin
if AnsiSameText(Copy(LocalDoc, 1, Length(edRoot.text)), edRoot.Text)
then // File down in dir structure
begin
if AnsiSameText(RequestInfo.Command, '
HEAD')
then
begin
ResultFile := TFileStream.create(LocalDoc, fmOpenRead
or fmShareDenyWrite);
try
ResponseInfo.ResponseNo := 200;
ResponseInfo.ContentType := GetMIMEType(LocalDoc);
ResponseInfo.ContentLength := ResultFile.Size;
finally
ResultFile.Free;
end;
end
else
begin
ByteSent := HTTPServer.ServeFile(AThread, ResponseInfo, LocalDoc);
Idlog.Items.Add(Format('
Speicher Datei %s (%d bytes / %d bytes sent) in %s:%d',
[LocalDoc, ByteSent, FileSizeByName(LocalDoc),
TIdIOHandlerSocket(AThread.Connection.IOHandler).Binding.PeerIP,
TIdIOHandlerSocket(AThread.Connection.IOHandler).Binding.PeerPort]));
end;
end
else
AccessDenied;
end
else
begin
ResponseInfo.ResponseNo := 404;
// Not found
ResponseInfo.ContentText := '
<html><head><title>Fehler</title></head><body><h1>' + ResponseInfo.ResponseText + '
</h1></body></html>';
end;
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
UILock := TCriticalSection.Create;
MIMEMap := TIdMIMETable.Create(true);
edRoot.text := ExtractFilePath(Application.exename) + '
Web';
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
MIMEMap.Free;
UILock.Free;
end;
function Tform1.GetMIMEType(sFile: TFileName):
String;
begin
result := MIMEMap.GetFileMIMEType(sFile);
end;
procedure TForm1.HTTPServerSessionEnd(Sender: TIdHTTPSession);
var
dt: TDateTime;
i: Integer;
hour, min, s, ms: word;
begin
idlog.Items.Add('
Beendent Sitzung %s bei %s');
dt := (StrToDateTime(sender.Content.Values['
StartTime'])-now);
DecodeTime(dt, hour, min, s, ms);
i := ((Trunc(dt)*24 + hour)*60 + min)*60 + s;
idlog.items.add(Format('
Die Sitzung dauerte: %d Sekunden', [i]));
end;
procedure TForm1.HTTPServerSessionStart(Sender: TIdHTTPSession);
begin
sender.Content.Values['
StartTime'] := DateTimeToStr(Now);
idlog.Items.Add(Format('
Startet eine SItzung %s bei %s',[Sender.SessionID, FormatDateTime(LongTimeFormat, now)]));
end;
procedure TForm1.FormCloseQuery(Sender: TObject;
var CanClose: Boolean);
begin
HTTPServer.Active:=False;
end;
procedure TForm1.lbSessionListDblClick(Sender: TObject);
begin
if lbSessionList.ItemIndex > -1
then
begin
HTTPServer.EndSession(lbSessionList.Items[lbSessionList.ItemIndex]);
end;
end;
procedure TFOrm1.MyInfoCallback(Msg:
STring);
begin
idLog.Items.Add(msg);
end;
procedure TForm1.GetKeyPassword(
var Password:
STring);
begin
Password := '
aaaa';
end;
procedure TForm1.HTTPServerConnect(AThread: TIdPeerThread);
begin
idlog.Items.Add('
Benutzer loggte ein');
end;
procedure TForm1.HTTPServerExecute(AThread: TIdPeerThread);
begin
idlog.Items.Add('
Gestartet');
end;
procedure TForm1.HTTPServerCommandOther(Thread: TIdPeerThread;
const asCommand, asData, asVersion:
String);
begin
idlog.Items.Add('
Gebietet: ' + asCommand);
end;
procedure TForm1.HTTPServerStatus(ASender: TObject;
const AStatus: TIdStatus;
const AStatusText:
String);
begin
idlog.Items.Add('
Status: ' + astatustext);
end;
end.