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

Previous  Top  Next

    
 

 

 

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.

 

 

©Drkb::03368

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