📄 webserv1.pas
字号:
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is triggered when a client is disconnecting, just }
{ before client component is closed. }
procedure TAppBaseForm.ServerClientDisconnect(
Sender: TObject; { HTTP server component }
Client: TObject; { Client connecting }
Error: Word); { Error in disconnection }
begin
ClientCountLabel.Caption := IntToStr(Server.ClientCount - 1);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is triggered when HTTP server component receive a HEAD }
{ command from any client. }
{ We just count the request, display a message and let HTTP server }
{ component handle everything. }
{ We should trap every URI we handle internally... }
procedure TAppBaseForm.ServerHeadDocument(
Sender: TObject; { HTTP server component }
Client: TObject; { Client connection issuing command }
var Flags: THttpGetFlag); { Tells what HTTP server has to do next }
begin
Inc(FCountRequests);
Display(IntToStr(FCountRequests) +
': HEAD ' + TMyHttpConnection(Client).Path);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is triggered when HTTP server component receive a GET }
{ command from any client. }
{ We count the request, display a message and trap '/time.htm' path for }
{ special handling. }
{ There is no document time.htm on disk, we will create it on the fly. With }
{ a classic webserver we would have used a CGI or ISAPI/NSAPI to achieve }
{ the same goal. It is much easier here since we can use Delphi code }
{ directly to generate whatever we wants. Here for the demo we generate a }
{ page with server data and time displayed. }
procedure TAppBaseForm.ServerGetDocument(
Sender: TObject; { HTTP server component }
Client: TObject; { Client connection issuing command }
var Flags: THttpGetFlag); { Tells what HTTP server has to do next }
begin
{ Count request and display a message }
OutputDebugString('Get request received');
Inc(FCountRequests);
Display(IntToStr(FCountRequests) +
': GET ' + TMyHttpConnection(Client).Path);
DisplayHeader(TMyHttpConnection(Client));
{ Trap '/time.htm' path to dynamically generate an answer. }
if CompareText(THttpConnection(Client).Path, '/time.htm') = 0 then
CreateVirtualDocument_time_htm(Sender, Client, Flags);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This procedure is use to generate /time.htm document }
procedure TAppBaseForm.CreateVirtualDocument_time_htm(
Sender: TObject; { HTTP server component }
Client: TObject; { Client connection issuing command }
var Flags: THttpGetFlag); { Tells what HTTP server has to do next }
var
Body: string;
Header: string;
Stream: TMemoryStream;
begin
{ Let HTTP server component know we will send data to client }
Flags := hgWillSendMySelf;
{ Create a stream to hold data sent to client that is the answer }
{ made of a HTTP header and a body made of HTML code. }
Stream := TMemoryStream.Create;
Body := '<HTML>' +
'<HEAD>' +
'<TITLE>ICS WebServer Demo</TITLE>' +
'</HEAD>' + #13#10 +
'<BODY>' +
'<H2>Time at server side:</H2>' + #13#10 +
'<P>' + DateTimeToStr(Now) + '</P>' + #13#10 +
'</BODY>' +
'</HTML>' + #13#10;
Header := TMyHttpConnection(Client).Version + ' 200 OK' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' +
IntToStr(Length(Body)) + #13#10 +
#13#10;
Stream.Write(Header[1], Length(Header));
Stream.Write(Body[1], Length(Body));
{ We need to seek to start of stream ! }
Stream.Seek(0, 0);
{ We ask server component to send the stream for us. }
TMyHttpConnection(Client).DocStream := Stream;
TMyHttpConnection(Client).SendStream;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is triggered when HTTP server component receive a POST }
{ command from any client. }
{ We count the request, display a message and trap posted data. }
{ To check for posted data, you may construct the following HTML document: }
{ <HTML> }
{ <HEAD> }
{ <TITLE>Test Form 1</TITLE> }
{ </HEAD> }
{ <BODY> }
{ <H2>Enter your first and last name</H2> }
{ <FORM METHOD="POST" ACTION="/cgi-bin/cgifrm1.exe"> }
{ <TABLE BORDER="0" ALIGN="DEFAULT" WIDTH="100%"> }
{ <TR> }
{ <TD>First name</TD> }
{ <TD><INPUT TYPE="TEXT" NAME="FirstName" }
{ MAXLENGTH="25" VALUE="YourFirstName"></TD> }
{ </TR> }
{ <TR> }
{ <TD>Last name</TD> }
{ <TD><INPUT TYPE="TEXT" NAME="LastName" }
{ MAXLENGTH="25" VALUE="YourLastName"></TD> }
{ </TR> }
{ </TABLE> }
{ <P><INPUT TYPE="SUBMIT" NAME="Submit" VALUE="Button"></P> }
{ </FORM> }
{ </BODY> }
{ </HTML> }
procedure TAppBaseForm.ServerPostDocument(
Sender: TObject; { HTTP server component }
Client: TObject; { Client connection issuing command }
var Flags: THttpGetFlag); { Tells what HTTP server has to do next }
var
Remote: TMyHttpConnection;
begin
{ It's easyer to do the cast one time. Could use with clause... }
Remote := TMyHttpConnection(Client);
{ Count request and display a message }
Inc(FCountRequests);
Display(IntToStr(FCountRequests) + ': POST ' + Remote.Path);
DisplayHeader(Remote);
{ Check for request past. We only accept data for '/cgi-bin/cgifrm1.exe' }
if CompareText(Remote.Path, '/cgi-bin/cgifrm1.exe') = 0 then
begin
{ Tell HTTP server that we will accept posted data }
{ OnPostedData event will be triggered when data comes in }
Flags := hgAcceptData;
{ We wants to receive any data type. So we turn line mode off on }
{ client connection. }
Remote.LineMode := FALSE;
{ We need a buffer to hold posted data. We allocate as much as the }
{ size of posted data plus one byte for terminating nul char. }
{ We should check for ContentLength = 0 and handle that case... }
ReallocMem(Remote.FPostedDataBuffer, Remote.RequestContentLength + 1);
{ Clear received length }
Remote.FDataLen := 0;
end
else
Flags := hg404;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This event handler is triggered for each data packet posted by client }
{ when we told HTTP server component that we will accept posted data. }
{ We have to receive ALL data which is sent by remote client, even if there }
{ is more than what ContentLength tells us ! }
{ If ContentLength = 0, then we should receive data until connection is }
{ closed... }
procedure TAppBaseForm.ServerPostedData(
Sender: TObject; { HTTP server component }
Client: TObject; { Client posting data }
Error: Word); { Error in data receiving }
var
Len: Integer;
Remains: Integer;
Junk: array[0..255] of char;
Remote: TMyHttpConnection;
begin
{ It's easyer to do the cast one time. Could use with clause... }
Remote := TMyHttpConnection(Client);
{ How much data do we have to receive ? }
Remains := Remote.RequestContentLength - Remote.FDataLen;
if Remains <= 0 then
begin
{ We got all our data. Junk anything else ! }
Len := Remote.Receive(@Junk, SizeOf(Junk) - 1);
if Len >= 0 then
Junk[Len] := #0;
Exit;
end;
{ Receive as much data as we need to receive. But warning: we may }
{ receive much less data. Data will be split into several packets we }
{ have to assemble in our buffer. }
Len := Remote.Receive(Remote.FPostedDataBuffer + Remote.FDataLen, Remains);
{ Sometimes, winsock doesn't wants to givve any data... }
if Len <= 0 then
Exit;
{ Add received length to our count }
Inc(Remote.FDataLen, Len);
{ Add a nul terminating byte (handy to handle data as a string) }
Remote.FPostedDataBuffer[Remote.FDataLen] := #0;
{ Display receive data so far }
Display('Data: ''' + Remote.FPostedDataBuffer + '''');
{ When we received the whole thing, we can process it }
if Remote.FDataLen = Remote.RequestContentLength then
begin
if CompareText(Remote.Path, '/cgi-bin/cgifrm1.exe') = 0 then
ProcessPostedData_CgiFrm1(Remote)
else
Remote.Answer404;
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ This will process posted data for CgiFrm1.exe }
procedure TAppBaseForm.ProcessPostedData_CgiFrm1(Client: TMyHttpConnection);
var
Stream: TStream;
FileName: string;
Body: string;
Header: string;
FirstName: string;
LastName: string;
HostName: string;
Buf: string;
begin
{ Extract fields from posted data. }
ExtractURLEncodedValue(Client.FPostedDataBuffer, 'FirstName', FirstName);
ExtractURLEncodedValue(Client.FPostedDataBuffer, 'LastName', LastName);
{ Get client IP address. We could to ReverseDnsLookup to get hostname }
HostName := Client.PeerAddr;
{ Build the record to write to data file }
Buf := FormatDateTime('YYYYMMDD HHNNSS ', Now) +
FirstName + '.' + LastName + '@' + HostName + #13#10;
{ Save data to a text file }
FileName := ExtractFilePath(Application.ExeName) + 'CgiFrm1.txt';
if FileExists(FileName) then
Stream := TFileStream.Create(FileName, fmOpenWrite)
else
Stream := TFileStream.Create(FileName, fmCreate);
Stream.Seek(0, soFromEnd);
Stream.Write(Buf[1], Length(Buf));
Stream.Destroy;
{ Now create output stream to send back to remote client }
Stream := TMemoryStream.Create;
Body := '<HTML>' +
'<HEAD>' +
'<TITLE>ICS WebServer Demo</TITLE>' +
'</HEAD>' + #13#10 +
'<BODY>' +
'<H2>Your data has been recorded:</H2>' + #13#10 +
'<P>' + FirstName + '.' + LastName + '@' + HostName + '</P>' +
'</BODY>' +
'</HTML>' + #13#10;
Header := Client.Version + ' 200 OK' + #13#10 +
'Content-Type: text/html' + #13#10 +
'Content-Length: ' +
IntToStr(Length(Body)) + #13#10 +
#13#10;
Stream.Write(Header[1], Length(Header));
Stream.Write(Body[1], Length(Body));
Stream.Seek(0, 0);
{ Ask HTTP server component to send data stream for us }
Client.DocStream := Stream;
Client.SendStream;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TAppBaseForm.DisplayHeader(Client: TMyHttpConnection);
var
I: Integer;
begin
if not DisplayHeaderCheckBox.Checked then
Exit;
for I := 0 to Client.RequestHeader.Count - 1 do
Display('HDR' + IntToStr(I + 1) + ') ' +
Client.RequestHeader.Strings[I]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{ We need to override parent class destructor because we have allocated }
{ memory for our data buffer. }
destructor TMyHttpConnection.Destroy;
begin
if Assigned(FPostedDataBuffer) then
begin
FreeMem(FPostedDataBuffer);
FPostedDataBuffer := nil;
end;
inherited Destroy;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
initialization
SetLicenseKey('ADDCD14AD06709806817E0B3D7BFD0A2222D536FE156466C5D5FE65DB5DEAE76' +
'FFDEBC07E915A5751C12C01C783958872A38E4A5EDA140E7247E0F2E56442A3C' +
'F3E9347AD8FDE52083A0DFC86BC00ECB0FD0CF1B51159A2BCB84F6EA6349EF47' +
'5C15A59AFCC55F7C3AAD26C279628B5D91B1DC94BD2385354A70CCA3B76101D9' +
'F41C84A639FC3CCE4BA8F0CC4A66DCD150114A3F58C1AD46B7B94643741BC20A' +
'8DCA83AB921480951B423CAA19EF1863A47CA2C3422E7E5634BED98939A5AE43' +
'DE1E4BAD79E66D8A5C973B3455656C8C9B6FF024FADD6CDA02D0F506D98493C8' +
'BD1ED7B237DB75FA31F2C82654490CDDDEE24E19939137B9E1DB05508733B22F');
end.
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -