//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.