This time I am writing a short article showing you how to implement the INDY TIdHTTPServer component. We will create a simple HTTP Server that responses to incoming request. Additionally, the server uses Borland TPageProducer component to provide very basic scripting capabilities.
You can download the Indy components at
nevrona.com/Indy. This article and the samples are using Indy v9.3 BETA.
First we will design the server. Since this is a demo showing how to use the INDY HTTP Server, we will not design a NT Service, rather a simple application allowing us to better control the server.
[IMAGE 1]
Before starting the server, you must choose a web root directory. Additionally you can set a default document, the reader can get, if only a web folder name was requested, similar to the index.htm file on a web server.
INCOMING REQUESTS
All incoming requests must start with a forward slash '/'. If a malformed request is sent to the server we will raise an exception and abort the actions associated. (001)
Next all forward slash characters (/) will be converted to backward slash characters (\) and the file name, as it should be on the server, will be created. (002)
RETURNING THE DOCUMENT REQUESTED
If the user has requested a folder (last character will be a backward slash (\)), we will check for the default document file in the requested folder.
All files ending on '.ehtm' will be sent through our "script" parser. Therefore, we have to check the document type.
· For all .ehtm files, we will create a TPageProducer object and send the document through the parser. The following Tags can be interpreted in this simple version <#DATE>, <#TIME>, <#DATETIME>, and <#SERVER>
· All other files are returned as-is.
WRITING THE DATA TO THE CLIENT
First we check if any stream has been assigned to the response object. If so, we will return the stream and finish. Next we will check for any data and send them back if there are any.
If neither case has occurred we will send back a 404 Error response, indicating, that the requested document has not been found on the server.
As client any HTML Browser can serve.
[IMAGE 2]
THE SERVER CODE
unit uMainForm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
IdBaseComponent, IdComponent, IdTCPServer, IdHTTPServer, StdCtrls,
ExtCtrls, HTTPApp;
type
TfrmServer =
class(TForm)
httpServer: TIdHTTPServer;
chkActive: TCheckBox;
Label1: TLabel;
edtRootFolder: TEdit;
btnGetFolder: TButton;
Label2: TLabel;
edtDefaultDoc: TEdit;
lstLog: TListBox;
Bevel1: TBevel;
btnClearLog: TButton;
procedure btnGetFolderClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure chkActiveClick(Sender: TObject);
procedure btnClearLogClick(Sender: TObject);
procedure httpServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
procedure pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
const TagString:
String; TagParams: TStrings;
var ReplaceText:
String);
private
procedure Log(Data:
String);
procedure LogServerState;
public
end;
var
frmServer: TfrmServer;
implementation
uses
ShlObj, FileCtrl;
{$R *.DFM}
// copied from the last "Latium Software - Pascal Newsletter #33"
function BrowseCallbackProc(Wnd: HWND; uMsg: UINT;
lParam, lpData: LPARAM): Integer
stdcall;
var
Buffer:
array [0..MAX_PATH-1]
of char;
begin
case uMsg
of
BFFM_INITIALIZED:
if lpData <> 0
then
SendMessage(Wnd, BFFM_SETSELECTION, 1, lpData);
BFFM_SELCHANGED:
begin
SHGetPathFromIDList(PItemIDList(lParam), Buffer);
SendMessage(Wnd, BFFM_SETSTATUSTEXT, 0, Integer(@Buffer));
end;
end;
Result := 0;
end;
// copied from the last "Latium Software - Pascal Newsletter #33"
function BrowseForFolder(Title:
string; RootCSIDL: integer = 0;
InitialFolder:
string = ''):
string;
var
BrowseInfo: TBrowseInfo;
Buffer:
array [0..MAX_PATH-1]
of char;
ResultPItemIDList: PItemIDList;
begin
with BrowseInfo
do begin
hwndOwner := Application.Handle;
if RootCSIDL = 0
then
pidlRoot :=
nil
else
SHGetSpecialFolderLocation(hwndOwner, RootCSIDL,
pidlRoot);
pszDisplayName := @Buffer;
lpszTitle := PChar(Title);
ulFlags := BIF_RETURNONLYFSDIRS
or BIF_STATUSTEXT;
lpfn := BrowseCallbackProc;
lParam := Integer(Pointer(InitialFolder));
iImage := 0;
end;
Result := '';
ResultPItemIDList := SHBrowseForFolder(BrowseInfo);
if ResultPItemIDList <>
nil then begin
SHGetPathFromIDList(ResultPItemIDList, Buffer);
Result := Buffer;
GlobalFreePtr(ResultPItemIDList);
end;
with BrowseInfo
do if pidlRoot <>
nil then GlobalFreePtr(pidlRoot);
end;
// clear log file
procedure TfrmServer.btnClearLogClick(Sender: TObject);
begin
lstLog.Clear;
end;
// got http server root folder
procedure TfrmServer.btnGetFolderClick(Sender: TObject);
var
NewFolder:
String;
begin
NewFolder := BrowseForFolder('Web Root Folder', 0, edtRootFolder.Text);
if NewFolder <> ''
then
if DirectoryExists(NewFolder)
then
edtRootFolder.Text := NewFolder;
end;
// de-activate http server
procedure TfrmServer.chkActiveClick(Sender: TObject);
begin
if chkActive.Checked
then
begin
// root folder must exists
if AnsiLastChar(edtRootFolder.Text)^ = '\'
then
edtRootFolder.Text :=
Copy(edtRootFolder.Text, 1, Pred(Length(edtRootFolder.Text)));
chkActive.Checked := DirectoryExists(edtRootFolder.Text);
if not chkActive.Checked
then
ShowMessage('Root Folder does not exist.');
end;
// de-/activate server
httpServer.Active := chkActive.Checked;
// log to list box
LogServerState;
// set interactive state for user fields
edtRootFolder.Enabled :=
not chkActive.Checked;
edtDefaultDoc.Enabled :=
not chkActive.Checked;
end;
// prepare !
procedure TfrmServer.FormCreate(Sender: TObject);
begin
edtRootFolder.Text := ExtractFilePath(Application.ExeName) + 'WebSite';
ForceDirectories(edtRootFolder.Text);
end;
// incoming client request for download
procedure TfrmServer.httpServerCommandGet(AThread: TIdPeerThread;
RequestInfo: TIdHTTPRequestInfo; ResponseInfo: TIdHTTPResponseInfo);
var
I: Integer;
RequestedDocument, FileName, CheckFileName:
String;
EHTMLParser: TPageProducer;
begin
// requested document
RequestedDocument := RequestInfo.Document;
// log request
Log('Client: ' + RequestInfo.RemoteIP + ' request for: ' + RequestedDocument);
// 001
if Copy(RequestedDocument, 1, 1) <> '/'
then
// invalid request
raise Exception.Create('invalid request: ' + RequestedDocument);
// 002
// convert all '/' to '\'
FileName := RequestedDocument;
I := Pos('/', FileName);
while I > 0
do
begin
FileName[I] := '\';
I := Pos('/', FileName);
end;
// locate requested file
FileName := edtRootFolder.Text + FileName;
try
// check whether file or folder was requested
if AnsiLastChar(FileName)^ = '\'
then
// folder - reroute to default document
CheckFileName := FileName + edtDefaultDoc.Text
else
// file - use it
CheckFileName := FileName;
if FileExists(CheckFileName)
then
begin
// file exists
if LowerCase(ExtractFileExt(CheckFileName)) = '.ehtm'
then
begin
// Extended HTML - send through internal tag parser
EHTMLParser := TPageProducer.Create(Self);
try
// set source file name
EHTMLParser.HTMLFile := CheckFileName;
// set event handler
EHTMLParser.OnHTMLTag := pgpEHTMLHTMLTag;
// parse !
ResponseInfo.ContentText := EHTMLParser.Content;
finally
EHTMLParser.Free;
end;
end else begin
// return file as-is
// log
Log('Returning Document: ' + CheckFileName);
// open file stream
ResponseInfo.ContentStream :=
TFileStream.Create(CheckFileName, fmOpenRead
or fmShareCompat);
end;
end;
finally
if Assigned(ResponseInfo.ContentStream)
then
begin
// response stream does exist
// set length
ResponseInfo.ContentLength := ResponseInfo.ContentStream.Size;
// write header
ResponseInfo.WriteHeader;
// return content
ResponseInfo.WriteContent;
// free stream
ResponseInfo.ContentStream.Free;
ResponseInfo.ContentStream :=
nil;
end else if ResponseInfo.ContentText <> ''
then begin
// set length
ResponseInfo.ContentLength := Length(ResponseInfo.ContentText);
// write header
ResponseInfo.WriteHeader;
// return content
end else begin
if not ResponseInfo.HeaderHasBeenWritten
then
begin
// set error code
ResponseInfo.ResponseNo := 404;
ResponseInfo.ResponseText := 'Document not found';
// write header
ResponseInfo.WriteHeader;
end;
// return content
ResponseInfo.ContentText := 'The document requested is not availabe.';
ResponseInfo.WriteContent;
end;
end;
end;
procedure TfrmServer.Log(Data:
String);
begin
lstLog.Items.Add(DateTimeToStr(Now) + ' - ' + Data);
end;
procedure TfrmServer.LogServerState;
begin
if httpServer.Active
then
Log(httpServer.ServerSoftware + ' is active')
else
Log(httpServer.ServerSoftware + ' is not active');
end;
procedure TfrmServer.pgpEHTMLHTMLTag(Sender: TObject; Tag: TTag;
const TagString:
String; TagParams: TStrings;
var ReplaceText:
String);
var
LTag:
String;
begin
LTag := LowerCase(TagString);
if LTag = 'date'
then
ReplaceText := DateToStr(Now)
else if LTag = 'time'
then
ReplaceText := TimeToStr(Now)
else if LTag = 'datetime'
then
ReplaceText := DateTimeToStr(Now)
else if LTag = 'server'
then
ReplaceText := httpServer.ServerSoftware;
end;
end.
Content Ace
Sign Up
