📄 httpsrv.pas
字号:
{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
Author: Fran鏾is PIETTE
Description: THttpServer implement the HTTP server protocol, that is a
web server kernel.
Creation: Oct 10, 1999
Version: 1.00 BETA
EMail: http://users.swing.be/francois.piette francois.piette@swing.be
http://www.rtfm.be/fpiette francois.piette@rtfm.be
francois.piette@pophost.eunet.be
Support: Use the mailing list twsocket@rtfm.be See website for details.
Legal issues: Copyright (C) 1996-2000 by Fran鏾is PIETTE
Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
<francois.piette@pophost.eunet.be><francois.piette@swing.be>
This software is provided 'as-is', without any express or
implied warranty. In no event will the author be held liable
for any damages arising from the use of this software.
Permission is granted to anyone to use this software for any
purpose, including commercial applications, and to alter it
and redistribute it freely, subject to the following
restrictions:
1. The origin of this software must not be misrepresented,
you must not claim that you wrote the original software.
If you use this software in a product, an acknowledgment
in the product documentation would be appreciated but is
not required.
2. Altered source versions must be plainly marked as such, and
must not be misrepresented as being the original software.
3. This notice may not be removed or altered from any source
distribution.
4. You must register this software by sending a picture postcard
to the author. Use a nice stamp and mention your name, street
address, EMail address and any comment you like to say.
History:
Nov 12, 1999 Beta 3 Added Linger properties
Apr 23, 2000 Beta 4 Added Delphi 1 compatibility
Made everything public in THttpConnection because BCB has problems
when deriving a component from Delphi and protected functions.
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit HttpSrv;
interface
uses
WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, WSocket, WSocketS;
const
THttpServerVersion = 100;
CopyRight : String = ' THttpServer (c) 1999-2000 F. Piette V1.00 BETA 4 ';
WM_HTTP_DONE = WM_USER + 40;
type
THttpConnection = class;
THttpConnectionClass = class of THttpConnection;
THttpGetFlag = (hgSendDoc, hgSendStream, hgWillSendMySelf, hg404, hgAcceptData);
THttpSendType = (httpSendHead, httpSendDoc);
THttpGetEvent = procedure (Sender : TObject;
Client : TObject;
var Flags : THttpGetFlag) of object;
THttpGetConnEvent = procedure (Sender : TObject;
var Flags : THttpGetFlag) of object;
THttpConnectEvent = procedure (Sender : TObject;
Client : TObject;
Error : Word) of object;
THttpPostedDataEvent = procedure (Sender : TObject;
Client : TObject;
Error : Word) of object;
THttpConnectionState = (hcRequest, hcHeader, hcPostedData);
{ THttpConnection is used to handle client connections }
THttpConnection = class(TWSocketClient)
public
FRcvdLine : String;
FMethod : String;
FVersion : String;
FPath : String;
FParams : String;
FRequestHeader : TStringList;
FState : THttpConnectionState;
FDocDir : String;
FDefaultDoc : String;
FDocument : String;
FDocStream : TStream;
FDocBuf : PChar;
FAnswerContentType : String;
FRequestContentLength : Integer;
FRequestContentType : String;
FRequestAccept : String;
FRequestReferer : String;
FRequestAcceptLanguage : String;
FRequestAcceptEncoding : String;
FRequestUserAgent : String;
FRequestHost : String;
FRequestConnection : String;
FAcceptPostedData : Boolean;
FOnGetDocument : THttpGetConnEvent;
FOnHeadDocument : THttpGetConnEvent;
FOnPostDocument : THttpGetConnEvent;
FOnPostedData : TDataAvailable;
procedure ConnectionDataAvailable(Sender: TObject; Error : Word);
procedure ConnectionDataSent(Sender : TObject; Error : WORD);
procedure ParseRequest;
procedure ProcessRequest;
procedure ProcessGet;
procedure ProcessHead;
procedure ProcessPost;
procedure SendDocument(SendType : THttpSendType);
procedure SendStream;
procedure Answer404;
procedure WndProc(var MsgRec: TMessage); override;
procedure WMHttpDone(var msg: TMessage); message WM_HTTP_DONE;
procedure TriggerGetDocument(var Flags : THttpGetFlag); virtual;
procedure TriggerHeadDocument(var Flags : THttpGetFlag); virtual;
procedure TriggerPostDocument(var Flags : THttpGetFlag); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
{ Method contains GET/POST/HEAD as requested by client }
property Method : String read FMethod;
{ Version contains HTTP version from client request }
property Version : String read FVersion;
{ The whole header as received from client }
property RequestHeader : TStringList
read FRequestHeader;
{ Stream used to send reply to client }
property DocStream : TStream
read FDocStream
write FDocStream;
{ All RequestXXX are header fields from request header }
property RequestContentLength : Integer
read FRequestContentLength;
property RequestContentType : String read FRequestContentType;
property RequestAccept : String read FRequestAccept;
property RequestReferer : String read FRequestReferer;
property RequestAcceptLanguage : String read FRequestAcceptLanguage;
property RequestAcceptEncoding : String read FRequestAcceptEncoding;
property RequestUserAgent : String read FRequestUserAgent;
property RequestHost : String read FRequestHost;
property RequestConnection : String read FRequestConnection;
published
{ Where all documents are stored. Default to c:\wwwroot }
property DocDir : String read FDocDir
write FDocDir;
{ Default document name. Default to index.html }
property DefaultDoc : String read FDefaultDoc
write FDefaultDoc;
{ Complete document path and file name on local file system }
property Document : String read FDocument
write FDocument;
{ Document path as requested by client }
property Path : String read FPath
write FPath;
{ Parameters in request (Question mark is separator) }
property Params : String read FParams
write FParams;
{ Triggered when client sent GET request }
property OnGetDocument : THttpGetConnEvent read FOnGetDocument
write FOnGetDocument;
{ Triggered when client sent HEAD request }
property OnHeadDocument : THttpGetConnEvent read FOnHeadDocument
write FOnHeadDocument;
{ Triggered when client sent POST request }
property OnPostDocument : THttpGetConnEvent read FOnPostDocument
write FOnPostDocument;
{ Triggered when client sent POST request and data is available }
property OnPostedData : TDataAvailable read FOnPostedData
write FOnPostedData;
end;
{ This is the HTTP server component handling all HTTP connection }
{ service. Most of the work is delegated to a TWSocketServer }
THttpServer = class(TComponent)
protected
{ FWSocketServer will handle all client management work }
FWSocketServer : TWSocketServer;
FPort : String;
FAddr : String;
FClientClass : THttpConnectionClass;
FDocDir : String;
FDefaultDoc : String;
FLingerOnOff : TSocketLingerOnOff;
FLingerTimeout : Integer; { In seconds, 0 = disabled }
FOnServerStarted : TNotifyEvent;
FOnServerStopped : TNotifyEvent;
FOnClientConnect : THttpConnectEvent;
FOnClientDisconnect : THttpConnectEvent;
FOnGetDocument : THttpGetEvent;
FOnHeadDocument : THttpGetEvent;
FOnPostDocument : THttpGetEvent;
FOnPostedData : THttpPostedDataEvent;
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure WSocketServerClientConnect(Sender : TObject;
Client : TWSocketClient;
Error : Word);
procedure WSocketServerClientCreate(Sender : TObject;
Client : TWSocketClient);
procedure WSocketServerClientDisconnect(Sender : TObject;
Client : TWSocketClient;
Error : Word);
procedure WSocketServerSessionClosed(Sender : TObject;
Error : Word);
procedure WSocketServerChangeState(Sender : TObject;
OldState, NewState : TSocketState);
procedure TriggerServerStarted; virtual;
procedure TriggerServerStopped; virtual;
procedure TriggerClientConnect(Client : TObject; Error : Word);
procedure TriggerClientDisconnect(Client : TObject; Error : Word);
procedure TriggerGetDocument(Sender : TObject;
var Flags : THttpGetFlag);
procedure TriggerHeadDocument(Sender : TObject;
var Flags : THttpGetFlag);
procedure TriggerPostDocument(Sender : TObject;
var Flags : THttpGetFlag); virtual;
procedure TriggerPostedData(Sender : TObject;
Error : WORD); virtual;
procedure SetPort(newValue : String);
procedure SetAddr(newValue : String);
function GetClientCount : Integer;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Start; virtual;
procedure Stop; virtual;
{ Runtime readonly property which gives number of connected clients }
property ClientCount : Integer read GetClientCount;
{ Runtim property which tell the component class which has to be }
{ instanciated to handle client connection }
property ClientClass : THttpConnectionClass
read FClientClass
write FClientClass;
published
{ We will listen to that port. Default to 80 for http service }
property Port : String read FPort
write SetPort;
{ We will use that interface to listen. 0.0.0.0 means all }
{ available interfaces }
property Addr : String read FAddr
write SetAddr;
{ Where all documents are stored. Default to c:\wwwroot }
property DocDir : String read FDocDir
write FDocDir;
{ Default document name. Default to index.html }
property DefaultDoc : String read FDefaultDoc
write FDefaultDoc;
property LingerOnOff : TSocketLingerOnOff
read FLingerOnOff
write FLingerOnOff;
property LingerTimeout : Integer read FLingerTimeout
write FLingerTimeout;
{ OnServerStrated is triggered when server has started listening }
property OnServerStarted : TNotifyEvent
read FOnServerStarted
write FOnServerStarted;
{ OnServerStopped is triggered when server has stopped listening }
property OnServerStopped : TNotifyEvent
read FOnServerStopped
write FOnServerStopped;
{ OnClientConnect is triggered when a client has connected }
property OnClientConnect : THttpConnectEvent
read FOnClientConnect
write FOnClientConnect;
{ OnClientDisconnect is triggered when a client is about to }
{ disconnect. }
property OnClientDisconnect : THttpConnectEvent
read FOnClientDisconnect
write FOnClientDisconnect;
{ OnGetDocument is triggered when a client sent GET request }
{ You can either do nothing and let server handle all work, or }
{ you can build a document on the fly or refuse access. }
property OnGetDocument : THttpGetEvent
read FOnGetDocument
write FOnGetDocument;
{ OnGetDocument is triggered when a client sent HEAD request }
{ You can either do nothing and let server handle all work, or }
{ you can build a document header on the fly or refuse access. }
property OnHeadDocument : THttpGetEvent
read FOnHeadDocument
write FOnHeadDocument;
{ OnGetDocument is triggered when a client sent POST request }
{ You have to tell if you accept data or not. If you accept, }
{ you'll get OnPostedData event with incomming data. }
property OnPostDocument : THttpGetEvent
read FOnPostDocument
write FOnPostDocument;
{ On PostedData is triggered when client post data and you }
{ accepted it from OnPostDocument event. }
{ When you've got all data, you have to build a reply to be }
{ sent to client. }
property OnPostedData : THttpPostedDataEvent
read FOnPostedData
write FOnPostedData;
end;
{ Retrieve a single value by name out of an URL encoded data stream. }
function ExtractURLEncodedValue(
Msg : PChar; { URL Encoded stream }
Name : String; { Variable name to look for }
var Value : String): Boolean; { Where to put variable value }
procedure Register;
implementation
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure Register;
begin
RegisterComponents('FPiette', [THttpServer]);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
procedure SetLength(var S: string; NewLength: Integer);
begin
S[0] := chr(NewLength);
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
{$IFDEF VER80}
function TrimRight(Str : String) : String;
var
i : Integer;
begin
i := Length(Str);
while (i > 0) and (Str[i] = ' ') do
i := i - 1;
Result := Copy(Str, 1, i);
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function TrimLeft(Str : String) : String;
var
i : Integer;
begin
if Str[1] <> ' ' then
Result := Str
else begin
i := 1;
while (i <= Length(Str)) and (Str[i] = ' ') do
i := i + 1;
Result := Copy(Str, i, Length(Str) - i + 1);
end;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
function Trim(Str : String) : String;
begin
Result := TrimLeft(TrimRight(Str));
end;
{$ENDIF}
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
constructor THttpServer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FWSocketServer := TWSocketServer.Create(Self);
FClientClass := THttpConnection;
FAddr := '0.0.0.0';
FPort := '80';
FDefaultDoc := 'index.html';
FDocDir := 'c:\wwwroot';
FLingerOnOff := wsLingerNoSet;
FLingerTimeout := 0;
end;
{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
destructor THttpServer.Destroy;
begin
if Assigned(FWSocketServer) then begin
FWSocketServer.Destroy;
FWSocketServer := nil;
end;
inherited Destroy;
end;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -