TCP-Server als Web-Server (Datein senden)

[mb1996]

Ich habe es nach der Indy-Demo gemacht (ein bisschen verändert):

Delphi-Quellcode:

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.

Fehler bei Delphi:
[Warnung] Unit1.pas(10): Unit 'FileCtrl' ist plattformspezifisch
[Warnung] Unit1.pas(220): Variable 'ResponseInfo' ist möglicherweise nicht initialisiert worden
[Warnung] Unit1.pas(229): Variable 'ResponseInfo' ist möglicherweise nicht initialisiert worden
[Hinweis] Unit1.pas(226): Variable 'RequestInfo' wurde deklariert, aber in 'AccessDenied' nicht verwendet
[Warnung] Unit1.pas(245): Variable 'RequestInfo' ist möglicherweise nicht initialisiert worden
[Warnung] Unit1.pas(254): Variable 'ResponseInfo' ist möglicherweise nicht initialisiert worden