📄 httpsrv.pas
字号:
EndPos : THttpRangeInt;
Offset : THttpRangeInt;
Size : THttpRangeInt;
end;
{ANDREAS virtual Stream for the byte-range content }
THttpRangeStream = class(TStream)
private
FSourceStream : TStream;
FPosition : THttpRangeInt;
FSize : THttpRangeInt;
FPartStreams : TList;
procedure ClearPartStreams;
procedure CalculateOffsets;
function GetPartStreams(NIndex: Integer): THttpPartStream;
public
constructor Create;
destructor Destroy; override;
procedure AddPartStream(Value : TStream;
AStartPos : Integer;
AEndPos : Integer);
function InitRangeStream(SourceStream : TStream;
RangeList : THttpRangeList;
ContentString : String): Boolean;
function Read(var Buffer; Count: Longint): Longint; override;
function Write(const Buffer; Count: Longint): Longint; override;
{$IFDEF STREAM64}
function Seek(const Offset: Int64; Origin: TSeekOrigin): Int64; override;
{$ELSE}
function Seek(Offset: Longint; Origin: Word): Longint; override;
{$ENDIF}
function PartStreamsCount: Integer;
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;
{$IFDEF USE_ZLIB}
FReplyDeflate : Boolean;
FCompressStream : TCompressionStream;
FDecompressStream : TDecompressionStream;
FZDocStream : TMemoryStream;
FZBuffer : array [0..8191] of Char;
{$ENDIF}
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 Answer501; 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;
{ Mostly like AnswerPage but the result is given into a string.
Designed to be used within a call to AnswerPage as one of the
replacable tag value. This permit to build a page based on several
templates. A main template given to AnswerPage and one or more
templates given to HtmlPageProducerToString, resulting string begin
used as tag value for the main template. Of course you can
recursively use HtmlPageProducerToString to build complex pages. }
function HtmlPageProducerToString(const HtmlFile: String;
UserData: TObject;
Tags: array of const): String;
{ Mostly like AnswerPage but the result is given into a stream }
procedure HtmlPageProducerToStream(const HtmlFile: String;
UserData: TObject;
Tags: array of const;
DestStream: TStream);
{ 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;
{ Triggered from AnswerPage when building a table, for each row }
property OnGetRowData : THttpGetRowDataEvent
read FOnGetRowData
write FOnGetRowData;
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;
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -