ServerSocket/TcpServer als Webserver -> Schwierigkeiten

[sirius]

Zitat von Darkface:

Und wie sieht so ein Http Header in Delphi aus? Send ich das einfach als Text vorne weg ...

Genau.

Delphi-Quellcode:

//mit meinen bescheidenen http-Kentnissen:
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, scktcomp, StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
  private
    { Private-Deklarationen }
    FServer:TServersocket;
    FIndex:Integer;
  public
    { Public-Deklarationen }
    procedure ClientConnect(Sender:TObject; Socket: TCustomWinSocket);
    procedure ClientDisconnect(Sender:TObject; Socket: TCustomWinSocket);
    procedure ClientRead(Sender:TObject; Socket: TCustomWinSocket);
    procedure ClientWrite(Sender:TObject; Socket: TCustomWinSocket);
    procedure ClientError(Sender:TObject; Socket: TCustomWinSocket;
                 ErrorEvent: TErrorEvent; var ErrorCode: Integer);
  end;

  TClientData=class
    Constructor Create;
    Destructor Destroy; override;
   private
    FCanWrite: boolean; //ist socket bereit zum senden
    FIndex: Integer; //laufender Index
    FSocket: TCustomWinSocket; //Parent Socket merken, für die Antwort
    FReceivedText:TStringList; //Stringlist wegen zu erwartenden http-Header
    procedure SetCanWrite(const Value: boolean);
    procedure SetIndex(const Value: Integer);
    procedure SetSocket(const Value: TCustomWinSocket);
   protected
    procedure SendNotImpl;
    procedure SendOK(const content:String);
   public
    property CanWrite:boolean read FCanWrite write SetCanWrite;
    property Index:Integer read FIndex write SetIndex;
    property Socket:TCustomWinSocket read FSocket write SetSocket;
    procedure Receive(const Text:string);

  end;


var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.ClientConnect(Sender: TObject; Socket: TCustomWinSocket);
var ClientData:TClientData;
begin
  ClientData:=TClientData.Create;
  ClientData.CanWrite:=false;
  inc(FIndex);
  ClientData.Index:=FIndex;
  ClientData.Socket:=Socket;
  Socket.Data:=ClientData;
  memo1.lines.add(format('%d connected',[ClientData.Index]));
end;

procedure TForm1.ClientDisconnect(Sender: TObject;
  Socket: TCustomWinSocket);
begin
  assert(TObject(Socket.Data) is TClientData);
  memo1.lines.add(format('%d disconnected',[TClientData(Socket.Data).Index]));
  TObject(Socket.Data).Free;
end;

procedure TForm1.ClientError(Sender: TObject; Socket: TCustomWinSocket;
  ErrorEvent: TErrorEvent; var ErrorCode: Integer);
var s:String;
begin
  assert(TObject(Socket.Data) is TClientData);
  case ErrorEvent of
    eeGeneral: s:='General';
    eeSend: s:='Send';
    eeReceive: s:='Receive';
    eeConnect: s:='Connect';
    eeDisconnect: s:='Disconnect';
    eeAccept: s:='Accept';
    eeLookup: s:='Lookup';
    else s:='Empty';
  end;
  memo1.Lines.Add(format('%d: Error on %s',[TClientData(Socket.Data).index,s]));
  ErrorCode:=0;
end;

procedure TForm1.ClientRead(Sender: TObject; Socket: TCustomWinSocket);
var s:string;
begin
  assert(TObject(Socket.Data) is TClientData);
  s:=Socket.ReceiveText;
  memo1.lines.add(format('%d Read: %s',[TClientData(Socket.Data).index,s]));
  TClientData(Socket.Data).Receive(s);
end;

procedure TForm1.ClientWrite(Sender: TObject; Socket: TCustomWinSocket);
begin
  assert(TObject(Socket.Data) is TClientData);
  memo1.lines.add(format('%d: CanWrite',[TClientData(Socket.Data).index]));
  TClientData(Socket.Data).CanWrite:=true;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  FServer:=TServersocket.Create(self);
  FServer.Port:=80;
  FServer.Service:='';
  FServer.ServerType:=stNonBlocking;
  FServer.OnClientConnect:=ClientConnect;
  FServer.OnClientDisconnect:=ClientDisconnect;
  FServer.OnClientWrite:=ClientWrite;
  FServer.OnClientRead:=ClientRead;
  FServer.OnClientError:=ClientError;
  FServer.Open;
  FIndex:=0;
end;


{ TClientData }

constructor TClientData.Create;
begin
  FReceivedText:=TstringList.Create;
end;

destructor TClientData.Destroy;
begin
  FReceivedText.Free;
end;

//neu erhaltenen TExt speichern und überprüfen ob breits eine Leerzeile vorhanden ist
//Leerzeile == Ende HTTP-Anfrage
procedure TClientData.Receive(const Text: string);
var i:Integer;
    Endpos:Integer;
    s:String;
    Req:String;
begin
  FReceivedTExt.Text:=FReceivedTExt.Text+Text;
  while FReceivedTExt.count>0 do
  begin
    EndPos:=-1;
    for i:=0 to FReceivedTExt.count-1 do
    begin
      if FReceivedText.Strings[i]='' then //auf http-Header Ende warten/suchen
      begin
        EndPos:=i; //Leerzeile gefunden
        break;
      end;
    end;

    if Endpos>0 then //wenn leerzeile und noch etwas mehr gefunden
    begin
      //eigentlich hier noch auf CanWrite überprüfen, ansonsten iust unser socket noch nicht fertig
      s:=FReceivedText.Strings[0];
      if Copy(s,1,4)='GET ' then //erste Zeile auseinanderbauen
      begin
        Delete(s,1,4);
        i:=pos(' ',s);

        Req:=copy(s,1,i-1);
        Delete(s,1,i);

        if copy(s,1,5)='HTTP/' then
        begin
          //antworten (eigentlich müsste man noch den Rest des Headers analysieren)
          SendOK(req);
        end else
          SendNotImpl;
      end else
        SendNotImpl;
    end;

    for i:=0 to Endpos do FReceivedText.Delete(0); //alles Bearbeitete löschen
  end;
end;

//"Fehler" senden
procedure TClientData.SendNotImpl;
begin
  FSocket.SendText('HTTP/1.1 501 Not Implemented'#13#10#13#10);
end;

//Antwort senden
procedure TClientData.SendOK(const Content:String);
var Ans:TStringList;
    HTML:String;
begin
  ans:=TStringList.Create;
  try
    HTML:='<html><head><meta http-equiv="refresh" content="1; URL=/"></head><body>It Works? Or? '
        +inttostr(FIndex) +'
'+Content+'</body></html>'#13#10;

    ans.Add('HTTP/1.1 200 OK');
    ans.add('Server: myDelphi');
    ans.add('Content-Length: '+inttostr(length(HTML)));
    ans.add('Content-Language: de');
    ans.add('Content-Type: text/html');
    ans.add('Connection: close');
    FSocket.SendText(Ans.Text+#13#10+HTML);

  finally
    ans.free;
  end;
end;

procedure TClientData.SetCanWrite(const Value: boolean);
begin
  FCanWrite := Value;
end;

procedure TClientData.SetIndex(const Value: Integer);
begin
  FIndex := Value;
end;

procedure TClientData.SetSocket(const Value: TCustomWinSocket);
begin
  FSocket := Value;
end;

end.

Edit: @Datacool: Ich vermute der TE möchte das Prinzip hinter einem http-Server verstehen. Da hilft keine fertige Komponente.