📄 httpsrv.pas
字号:
property PartStreams[NIndex : Integer] : THttpPartStream
read GetPartStreams;
end;
{ THttpConnection is used to handle client connections }
{$IFDEF USE_SSL}
THttpConnection = class(TSslWSocketClient)
{$ELSE}
THttpConnection = class(TWSocketClient)
{$ENDIF}
protected
FRcvdLine : String;
FMethod : String;
FVersion : String;
FPath : String;
FParams : String;
FRequestHeader : TStringList;
FState : THttpConnectionState;
FDocDir : String;
FTemplateDir : String;
FDefaultDoc : String;
FDocument : String;
FDocStream : TStream;
FDocBuf : PChar;
FLastModified : TDateTime;
FAnswerContentType : String;
FRequestContentLength : Integer;
FRequestContentType : String;
FRequestAccept : String;
FRequestReferer : String;
FRequestAcceptLanguage : String;
FRequestAcceptEncoding : String;
FRequestUserAgent : String;
FRequestAuth : String; {DAVID}
FRequestCookies : String;
FRequestHost : String;
FRequestHostName : String; {DAVID}
FRequestHostPort : String; {DAVID}
FRequestConnection : String;
FAcceptPostedData : Boolean;
FServer : THttpServer;
FBasicRealm : String;
FOptions : THttpOptions;
FOutsideFlag : Boolean;
FRequestRangeValues : THttpRangeList; {ANDREAS}
FDataSent : THttpRangeInt; {TURCAN}
FDocSize : THttpRangeInt; {TURCAN}
FOnGetDocument : THttpGetConnEvent;
FOnHeadDocument : THttpGetConnEvent;
FOnPostDocument : THttpGetConnEvent;
FOnPostedData : TDataAvailable;
FOnHTTPRequestDone : TNotifyEvent;
FOnBeforeProcessRequest: TNotifyEvent; {DAVID}
FOnFilterDirEntry : THttpFilterDirEntry;
FOnGetRowData : THttpGetRowDataEvent;
procedure ConnectionDataAvailable(Sender: TObject; Error : Word); virtual;
procedure ConnectionDataSent(Sender : TObject; Error : WORD); virtual;
procedure ParseRequest; virtual;
procedure ProcessRequest; virtual;
procedure ProcessGet; virtual;
procedure ProcessHead; virtual;
procedure ProcessPost; virtual;
procedure Answer404; virtual;
procedure Answer403; virtual;
procedure Answer401; virtual;
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;
procedure TriggerHttpRequestDone; virtual;
procedure TriggerBeforeProcessRequest; virtual; {DAVID}
procedure TriggerFilterDirEntry(DirEntry: THttpDirEntry); virtual;
procedure SendDirList(SendType : THttpSendType); virtual;
function BuildDirList: String; virtual;
function FormatDirEntry(F: THttpDirEntry): String; virtual;
procedure TriggerGetRowData(const TableName : String;
Row : Integer;
TagData : TStringIndex;
var More : Boolean;
UserData : TObject); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure SendStream; virtual;
procedure SendDocument(SendType : THttpSendType); virtual;
procedure SendHeader(Header : String); virtual;
procedure PostedDataReceived; virtual;
{ AnswerPage will take a HTML template and replace all tags in this
template with data provided in the Tags argument.
The tags in the template must have the form <#TagName>.
The Tags argument must be an array of const having the form
['TAG1', 'VALUE1', 'TAG2', VALUE2', ....]
Of course TAG1, TAG2,... and VALUE1, VALUE2,... can be replaced by
appropriate variables.
There is a pair of special tags in the template:
<#TABLE_ROWS TABLENAME> and <#/TABLE_ROWS>
When finding the first tag, AnswerPage search for the second one
and repeatedly trigger the event OnGetRowData to get data for the
other tags. The loop is controlled by the event handler "More"
argument. This permit easy table insertion with a single table row
defined in the template and repeated for each row.
It is permiited to have <#TABLE_ROWS TABLENAME> and <#/TABLE_ROWS>
pairs embedded to make tables inside tables.
UserData argument is passed to the OnGetRowData as is. It is
intended to pass any object to the event handler, for example the
dataset which was used to query the data to populate the table.
The Status argument is the HTTP answer status.
Default value "200 OK" is used when Status is an empty string.
The Header argument is used to build the HTTP header for the answer.
You _must_ not add Content-Length nor Content-Type in the header
because those two values are generated automatically by AnswerPage.
You can use Header argument for cache control, cookies or anything
else your application require.
}
procedure AnswerPage(var Flags : THttpGetFlag;
const Status : String;
const Header : String;
const HtmlFile : String;
UserData : TObject;
Tags : array of const);
procedure AnswerStream(var Flags : THttpGetFlag;
const Status : String;
const ContType : String;
const Header : String);
procedure AnswerString(var Flags : THttpGetFlag;
const Status : String;
const ContType : String;
const Header : String;
const Body : String); virtual;
{ 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 RequestAuth : String read FRequestAuth; {DAVID}
property RequestCookies : String read FRequestCookies;
property RequestHost : String read FRequestHost;
property RequestHostName : String read FRequestHostName; {DAVID}
property RequestHostPort : String read FRequestHostPort; {DAVID}
property RequestConnection : String read FRequestConnection;
property RequestRangeValues : THttpRangeList read FRequestRangeValues; {ANDREAS}
published
{ Where all documents are stored. Default to c:\wwwroot }
property DocDir : String read FDocDir
write FDocDir;
{ Where all template documents are stored. Default to c:\wwwroot\templates }
property TemplateDir : String read FTemplateDir
write FTemplateDir;
{ 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;
{ Selected HTTP server optional behaviour }
property Options : THttpOptions read FOptions
write FOptions;
{ 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;
{ Triggered when a HTTP-request is done; since a connection can
be established as keep-alive, there could possibly be several request
done }
property OnHttpRequestDone : TNotifyEvent read FOnHttpRequestDone
write FOnHttpRequestDone;
{ Triggered before we process the HTTP-request }
property OnBeforeProcessRequest : TNotifyEvent {DAVID}
read FOnBeforeProcessRequest
write FOnBeforeProcessRequest;
{ Triggered when doing a directory listing, for each entry. You
can set Visible to FALSE to hide the entry, or even change anything
in the data to fake the entry }
property OnFilterDirEntry : THttpFilterDirEntry
read FOnFilterDirEntry
write FOnFilterDirEntry;
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;
FMaxClients : Integer; {DAVID}
FClientClass : THttpConnectionClass;
FDocDir : String;
FTemplateDir : String;
FDefaultDoc : String;
FLingerOnOff : TSocketLingerOnOff;
FLingerTimeout : Integer; { In seconds, 0 = disabled }
FOptions : THttpOptions;
FOnServerStarted : TNotifyEvent;
FOnServerStopped : TNotifyEvent;
FOnClientConnect : THttpConnectEvent;
FOnClientDisconnect : THttpConnectEvent;
FOnGetDocument : THttpGetEvent;
FOnHeadDocument : THttpGetEvent;
FOnPostDocument : THttpGetEvent;
FOnPostedData : THttpPostedDataEvent;
FOnHttpRequestDone : THttpRequestDoneEvent;
FOnBeforeProcessRequest: THttpBeforeProcessEvent; {DAVID}
FOnFilterDirEntry : THttpFilterDirEntry;
FListenBacklog : Integer; {Bj鴕nar}
procedure Notification(AComponent: TComponent; operation: TOperation); override;
procedure CreateSocket; virtual;
procedure WSocketServerClientConnect(Sender : TObject;
Client : TWSocketClient;
Error : Word); virtual;
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); virtual;
procedure TriggerClientDisconnect(Client : TObject; Error : Word); virtual;
procedure TriggerGetDocument(Sender : TObject;
var Flags : THttpGetFlag); virtual;
procedure TriggerHeadDocument(Sender : TObject;
var Flags : THttpGetFlag); virtual;
procedure TriggerPostDocument(Sender : TObject;
var Flags : THttpGetFlag); virtual;
procedure TriggerPostedData(Sender : TObject;
Error : WORD); virtual;
procedure TriggerHttpRequestDone(Client : TObject); virtual;
procedure TriggerBeforeProcessRequest(Client : TObject); virtual; {DAVID}
procedure TriggerFilterDirEntry(Sender : TObject;
Client : TObject;
DirEntry : THttpDirEntry); virtual;
procedure SetPortValue(newValue : String);
procedure SetAddr(newValue : String);
procedure SetDocDir(const Value: String);
function GetClientCount : Integer;
function GetClient(nIndex : Integer) : THttpConnection;
function GetSrcVersion: String;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
procedure Start; virtual;
procedure Stop; virtual;
{ Check if a given object is one of our clients }
function IsClient(SomeThing : TObject) : Boolean;
{ Runtime readonly property which gives number of connected clients }
property ClientCount : Integer read GetClientCount;
{ Client[] give direct access to anyone of our clients }
property Client[nIndex : Integer] : THttpConnection
read GetClient;
{ Runtime property which tell the component class which has to be }
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -