Creating a simple HTTP Server (Views: 2145)
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. · 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. 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. |