Open a Text Editor of your choice, copy/paste the code below and save it as “MyHttpServer.dpr”.
program MyHttpServer;
{$APPTYPE CONSOLE}
uses
SysUtils,
rtcTypes,
rtcSystem,
rtcConn,
rtcDataSrv,
rtcHttpSrv,
rtcInfo;
type
// This is our self-contained HTTP Server class ...
TMyServer=class(TObject)
protected
HttpSrv:TRtcHttpServer;
DataProv:TRtcDataProvider;
public
constructor Create(PortNumber:String='80';
IPVer:RtcIPV=rtc_IPVDefault);
destructor Destroy; override;
procedure DataProv_CheckRequest(Sender: TRtcConnection);
procedure DataProv_DataReceived(Sender: TRtcConnection);
procedure HttpSrv_ListenStart(Sender: TRtcConnection);
procedure HttpSrv_ListenError(Sender: TRtcConnection; E:Exception);
procedure HttpSrv_ListenStop(Sender: TRtcConnection);
procedure HttpSrv_RequestNotAccepted(Sender: TRtcConnection);
end;
constructor TMyServer.Create(PortNumber:String='80'; IPVer:RtcIPV=rtc_IPVDefault);
begin
// Create HttpServer and DataProvider components ...
HttpSrv:=TRtcHttpServer.Create(nil);
DataProv:=TRtcDataProvider.Create(nil);
// Assign Server for our Data Provider ...
DataProv.Server:=HttpSrv;
// Assign Data Provider Events (handles Valid Requests) ...
DataProv.OnCheckRequest:=DataProv_CheckRequest;
DataProv.OnDataReceived:=DataProv_DataReceived;
// Assign Server Events (handles the rest) ...
HttpSrv.OnRequestNotAccepted:=HttpSrv_RequestNotAccepted;
HttpSrv.OnListenStart:=HttpSrv_ListenStart;
HttpSrv.OnListenStop:=HttpSrv_ListenStop;
HttpSrv.OnListenError:=HttpSrv_ListenError;
// Configure the Server ...
HttpSrv.ServerPort:=PortNumber;
HttpSrv.ServerIPV:=IPVer;
HttpSrv.MultiThreaded:=True;
// Start the Server listener ...
HttpSrv.Listen();
end;
destructor TMyServer.Destroy;
begin
// Stop the Server listener ...
HttpSrv.StopListenNow();
// Destroy the components ...
HttpSrv.Free;
DataProv.Free;
end;
procedure TMyServer.DataProv_CheckRequest(Sender: TRtcConnection);
begin
// Check Request headers and "Accept" all Requests
// we want to handle with our Data Provider ...
with TRtcDataServer(Sender) do
if (Request.Method='GET') and // we only want "GET" requests
(Request.ContentLength=0) then // ... with no content body
if (Request.URI='/html') or
(Request.URI='/json') or
(Request.URI='/xml') or
(Request.URI='/code') then
Accept; // Accept the Request
end;
procedure TMyServer.DataProv_DataReceived(Sender: TRtcConnection);
var
t:TRtcRecord;
begin
with TRtcDataServer(Sender) do
// We will start processing the request only if
// we have received the complee request content body ...
if Request.Complete then
if Request.URI='/html' then
begin
// We can use multiple "Write" calls
// to prepare our HTML response ...
Response.ContentType:='text/html';
Write('<html><body>');
Write('Your IP: '+PeerAddr+'<br>');
Write('Your Port: '+PeerPort+'<br>');
Write('Date & Time: <b>'+DateTimeToStr(Now)+'</b><br>');
Write('Agent: <i>'+Request['User-Agent']+'</i><br>');
Write('</body></html>');
// All "Write" calls will be buffered,
// RTC will calculate the "Content-Length" for us
// and send the whole content body out as a single
// Response - when we are finished with our event.
end
else
begin
// Using TRtcRecord to prepare our response Object ...
t:=TRtcRecord.Create;
try
t.asText['agent']:=Request['User-Agent'];
t.asText['ip']:=PeerAddr;
t.asText['port']:=PeerPort;
t.asDateTime['now']:=Now;
if Request.URI='/json' then
begin
// Serialize to "JSON" ...
Response.ContentType:='application/json';
Write(t.toJSON);
end
else if Request.URI='/xml' then
begin
// Serialize to "XML-RPC" ...
Response.ContentType:='text/xml';
Write(t.toXMLrpc);
end
else if Request.URI='/code' then
begin
// Serialize to "Code" (RTC format) ...
Response.ContentType:='text/plain';
Write(t.toCode);
end;
finally
t.Free;
end;
end
end;
procedure TMyServer.HttpSrv_RequestNotAccepted(Sender: TRtcConnection);
begin
// Request wasn't accepted ...
with TRtcDataServer(Sender) do
begin
// Send "404" status code back ...
Response.Status(404,'Not Found');
Response.ContentType:='text/plain';
// Something to show in the Web Browser ...
Write('Bad command.');
// And ... Disconnect the Client.
Disconnect;
end;
end;
procedure TMyServer.HttpSrv_ListenError(Sender: TRtcConnection; E: Exception);
begin
Writeln('Server Error: '+E.Message);
end;
procedure TMyServer.HttpSrv_ListenStart(Sender: TRtcConnection);
begin
Writeln('Server started.');
end;
procedure TMyServer.HttpSrv_ListenStop(Sender: TRtcConnection);
begin
Writeln('Server stopped.');
end;
var
MyServer:TMyServer;
begin
try
// Create and start our Server ...
MyServer:=TMyServer.Create('80');
try
// Since this is a console application and our
// Server is Multi-Threaded, we can do whatever
// we want here. For simplicity reasons, we will
// just use "ReadLn" to allow the Server to run
// while we wait for the user to press <Enter>.
Writeln('Press <Enter> to Quit ...');
ReadLn;
// User has pressed <Enter> - time to kill our Server.
finally
MyServer.Free;
end;
except
on E: Exception do
Writeln(E.ClassName, ': ', E.Message);
end;
end.
Continue reading →
