Creating a simple HTTP Server

Problem/Question/Abstract:

This article shows hot to create a simple HTTP server using TIdHTTPServer component from the Indy Library and the TPageProducer component from Borland for simple scripting capabilities.

Answer:

INTRODUCTION

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.

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.
&middot; 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>
&middot; 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.

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.