Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Пример простейшего HTTP-сервера

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

Взято с Delphi Knowledge Base: https://www.baltsoft.com/