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

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.
Source: Взято с Delphi Knowledge Base: http://www.baltsoft.com/
ID: 03368
Category:Связь