1783 lines
51 KiB
ObjectPascal
1783 lines
51 KiB
ObjectPascal
{******************************************************************************}
|
|
{ }
|
|
{ Library: Fundamentals 5.00 }
|
|
{ File name: flcHTTPServer.pas }
|
|
{ File version: 5.06 }
|
|
{ Description: HTTP server. }
|
|
{ }
|
|
{ Copyright: Copyright (c) 2011-2020, David J Butler }
|
|
{ All rights reserved. }
|
|
{ This file is licensed under the BSD License. }
|
|
{ See http://www.opensource.org/licenses/bsd-license.php }
|
|
{ Redistribution and use in source and binary forms, with }
|
|
{ or without modification, are permitted provided that }
|
|
{ the following conditions are met: }
|
|
{ Redistributions of source code must retain the above }
|
|
{ copyright notice, this list of conditions and the }
|
|
{ following disclaimer. }
|
|
{ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND }
|
|
{ CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED }
|
|
{ WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED }
|
|
{ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A }
|
|
{ PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL }
|
|
{ THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, }
|
|
{ INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR }
|
|
{ CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, }
|
|
{ PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF }
|
|
{ USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) }
|
|
{ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER }
|
|
{ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING }
|
|
{ NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE }
|
|
{ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE }
|
|
{ POSSIBILITY OF SUCH DAMAGE. }
|
|
{ }
|
|
{ Github: https://github.com/fundamentalslib }
|
|
{ E-mail: fundamentals.library at gmail.com }
|
|
{ }
|
|
{ Revision history: }
|
|
{ }
|
|
{ 2011/05/29 0.01 Initial development. }
|
|
{ 2011/06/13 0.02 Further development. }
|
|
{ 2011/06/21 0.03 Request and response flow. }
|
|
{ 2011/06/25 0.04 HTTPS. }
|
|
{ 2015/03/12 0.05 Improvements. }
|
|
{ 2016/01/09 5.06 Revised for Fundamentals 5. }
|
|
{ }
|
|
{******************************************************************************}
|
|
|
|
{$INCLUDE flcHTTP.inc}
|
|
|
|
unit flcHTTPServer;
|
|
|
|
interface
|
|
|
|
uses
|
|
{ System }
|
|
|
|
SysUtils,
|
|
Classes,
|
|
SyncObjs,
|
|
|
|
{ Fundamentals }
|
|
|
|
flcStdTypes,
|
|
flcStrings,
|
|
flcSocketLib,
|
|
|
|
{ TCP }
|
|
|
|
flcTCPConnection,
|
|
flcTCPServer,
|
|
|
|
{ HTTP }
|
|
|
|
flcHTTPUtils;
|
|
|
|
|
|
|
|
{ }
|
|
{ TF5HTTPServer }
|
|
{ }
|
|
const
|
|
HTTPSERVER_DefaultPort = 80;
|
|
HTTPSERVER_DefaultPortStr = '80';
|
|
HTTPSERVER_DefaultMaxBacklog = 8;
|
|
HTTPSERVER_DefaultMaxClients = -1;
|
|
|
|
type
|
|
THTTPServerLogType = (
|
|
// sltTrace
|
|
sltDebug,
|
|
// sltParameter
|
|
sltInfo,
|
|
// sltWarning,
|
|
sltError
|
|
// sltAlert
|
|
// sltCritical
|
|
);
|
|
|
|
THTTPServerAddressFamily = (
|
|
safIP4,
|
|
safIP6
|
|
);
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
THTTPSServerOption = (
|
|
ssoDontUseSSL3,
|
|
ssoDontUseTLS10,
|
|
ssoDontUseTLS11,
|
|
ssoDontUseTLS12
|
|
);
|
|
|
|
THTTPSServerOptions = set of THTTPSServerOption;
|
|
{$ENDIF}
|
|
|
|
TF5HTTPServer = class;
|
|
|
|
THTTPServerClientState = (
|
|
hscsInit,
|
|
hscsAwaitingRequest,
|
|
hscsReceivedRequestHeader,
|
|
hscsReceivingContent,
|
|
hscsRequestComplete,
|
|
hscsPreparingResponse,
|
|
hscsAwaitingPreparedResponse,
|
|
hscsSendingResponseHeader,
|
|
hscsSendingContent,
|
|
hscsResponseComplete,
|
|
hscsResponseCompleteAndClosing,
|
|
hscsResponseCompleteAndClosed,
|
|
hscsRequestInterruptedAndClosed
|
|
);
|
|
|
|
THTTPServerClient = class
|
|
private
|
|
FHTTPServer : TF5HTTPServer;
|
|
FTCPClient : TTCPServerClient;
|
|
|
|
FLock : TCriticalSection;
|
|
FState : THTTPServerClientState;
|
|
FHTTPParser : THTTPParser;
|
|
|
|
FRequest : THTTPRequest;
|
|
FRequestContentReader : THTTPContentReader;
|
|
|
|
FResponse : THTTPResponse;
|
|
FResponseContentWriter : THTTPContentWriter;
|
|
FResponseReady : Boolean;
|
|
|
|
procedure Init;
|
|
|
|
procedure Log(const LogType: THTTPServerLogType; const Msg: String; const LogLevel: Integer = 0); overload;
|
|
procedure Log(const LogType: THTTPServerLogType; const Msg: String; const Args: array of const; const LogLevel: Integer = 0); overload;
|
|
|
|
procedure Lock;
|
|
procedure Unlock;
|
|
|
|
function GetState: THTTPServerClientState;
|
|
function GetStateStr: String;
|
|
|
|
procedure SetState(const State: THTTPServerClientState);
|
|
|
|
function GetRemoteAddr: TSocketAddr;
|
|
function GetRemoteAddrStr: String;
|
|
|
|
procedure TriggerStateChanged;
|
|
procedure TriggerRequestHeader;
|
|
procedure TriggerRequestContentBuffer(const Buf; const Size: Integer);
|
|
procedure TriggerRequestContentComplete;
|
|
procedure TriggerPrepareResponse;
|
|
procedure TriggerResponseComplete;
|
|
|
|
procedure TCPClientStateChange;
|
|
procedure TCPClientRead;
|
|
procedure TCPClientWrite;
|
|
procedure TCPClientClose;
|
|
|
|
procedure ContentReaderLog(const Sender: THTTPContentReader; const LogMsg: String; const LogLevel: Integer);
|
|
function ContentReaderReadProc(const Sender: THTTPContentReader; var Buf; const Size: Integer): Integer;
|
|
procedure ContentReaderContentProc(const Sender: THTTPContentReader; const Buf; const Size: Integer);
|
|
procedure ContentReaderContentCompleteProc(const Sender: THTTPContentReader);
|
|
|
|
procedure ContentWriterLog(const Sender: THTTPContentWriter; const LogMsg: String);
|
|
function ContentWriterWriteProc(const Sender: THTTPContentWriter; const Buf; const Size: Integer): Integer;
|
|
|
|
procedure SendStr(const S: RawByteString);
|
|
|
|
procedure Start;
|
|
|
|
procedure ClearResponse;
|
|
|
|
procedure ReadRequestHeader;
|
|
procedure ProcessRequestHeader;
|
|
|
|
procedure InitRequestContent;
|
|
procedure ReadRequestContent;
|
|
procedure FinaliseRequestContent;
|
|
|
|
procedure SetRequestComplete;
|
|
|
|
procedure InitResponse;
|
|
procedure PrepareResponse;
|
|
procedure InitResponseContent;
|
|
procedure SendResponseContent;
|
|
procedure ResponsePrepared;
|
|
procedure SendResponse;
|
|
procedure SetResponseComplete;
|
|
|
|
function GetRequestMethod: RawByteString;
|
|
function GetRequestURI: RawByteString;
|
|
function GetRequestHost: RawByteString;
|
|
function GetRequestCookie: RawByteString;
|
|
function GetRequestHasContent: Boolean;
|
|
function GetRequestContentType: RawByteString;
|
|
|
|
function GetRequestRecordPtr: PHTTPRequest;
|
|
|
|
function GetResponseCode: Integer;
|
|
procedure SetResponseCode(const AResponseCode: Integer);
|
|
function GetResponseMsg: RawByteString;
|
|
procedure SetResponseMsg(const AResponseMsg: RawByteString);
|
|
function GetResponseContentType: RawByteString;
|
|
procedure SetResponseContentType(const AResponseContentType: RawByteString);
|
|
|
|
function GetResponseRecordPtr: PHTTPResponse;
|
|
|
|
function GetRequestContentStream: TStream;
|
|
procedure SetRequestContentStream(const ARequestContentStream: TStream);
|
|
function GetRequestContentFileName: String;
|
|
procedure SetRequestContentFileName(const ARequestContentFileName: String);
|
|
function GetRequestContentStr: RawByteString;
|
|
function GetRequestContentReceivedSize: Int64;
|
|
|
|
function GetResponseContentMechanism: THTTPContentWriterMechanism;
|
|
procedure SetResponseContentMechanism(const AResponseContentMechanism: THTTPContentWriterMechanism);
|
|
function GetResponseContentStr: RawByteString;
|
|
procedure SetResponseContentStr(const AResponseContentStr: RawByteString);
|
|
function GetResponseContentStream: TStream;
|
|
procedure SetResponseContentStream(const AResponseContentStream: TStream);
|
|
function GetResponseContentFileName: String;
|
|
procedure SetResponseContentFileName(const AResponseContentFileName: String);
|
|
procedure SetResponseReady(const AResponseReady: Boolean);
|
|
|
|
public
|
|
constructor Create(
|
|
const AHTTPServer: TF5HTTPServer;
|
|
const ATCPClient: TTCPServerClient);
|
|
destructor Destroy; override;
|
|
procedure Finalise;
|
|
|
|
property State: THTTPServerClientState read GetState;
|
|
property StateStr: String read GetStateStr;
|
|
|
|
property RemoteAddr: TSocketAddr read GetRemoteAddr;
|
|
property RemoteAddrStr: String read GetRemoteAddrStr;
|
|
|
|
property RequestRecord: THTTPRequest read FRequest;
|
|
property RequestRecordPtr: PHTTPRequest read GetRequestRecordPtr;
|
|
|
|
property RequestMethod: RawByteString read GetRequestMethod;
|
|
property RequestURI: RawByteString read GetRequestURI;
|
|
property RequestHost: RawByteString read GetRequestHost;
|
|
property RequestCookie: RawByteString read GetRequestCookie;
|
|
property RequestHasContent: Boolean read GetRequestHasContent;
|
|
property RequestContentType: RawByteString read GetRequestContentType;
|
|
property RequestContentStr: RawByteString read GetRequestContentStr;
|
|
property RequestContentStream: TStream read GetRequestContentStream write SetRequestContentStream;
|
|
property RequestContentFileName: String read GetRequestContentFileName write SetRequestContentFileName;
|
|
property RequestContentReceivedSize: Int64 read GetRequestContentReceivedSize;
|
|
|
|
property ResponseRecord: THTTPResponse read FResponse write FResponse;
|
|
property ResponseRecordPtr: PHTTPResponse read GetResponseRecordPtr;
|
|
|
|
property ResponseCode: Integer read GetResponseCode write SetResponseCode;
|
|
property ResponseMsg: RawByteString read GetResponseMsg write SetResponseMsg;
|
|
|
|
property ResponseContentType: RawByteString read GetResponseContentType write SetResponseContentType;
|
|
property ResponseContentMechanism: THTTPContentWriterMechanism read GetResponseContentMechanism write SetResponseContentMechanism;
|
|
property ResponseContentStr: RawByteString read GetResponseContentStr write SetResponseContentStr;
|
|
property ResponseContentStream: TStream read GetResponseContentStream write SetResponseContentStream;
|
|
property ResponseContentFileName: String read GetResponseContentFileName write SetResponseContentFileName;
|
|
property ResponseReady: Boolean read FResponseReady write SetResponseReady;
|
|
|
|
procedure SetResponseOKHtmlStr(const AHtmlStr: RawByteString);
|
|
procedure SetResponseOKFile(
|
|
const AContentType: THTTPContentTypeEnum;
|
|
const AFileName: String);
|
|
procedure SetResponseNotFound;
|
|
procedure SetResponseRedirect(const ALocation: RawByteString);
|
|
|
|
procedure Disconnect;
|
|
end;
|
|
|
|
|
|
|
|
THTTPServerEvent = procedure (const AServer: TF5HTTPServer) of object;
|
|
|
|
THTTPServerLogEvent = procedure (
|
|
const AServer: TF5HTTPServer;
|
|
const ALogType: THTTPServerLogType;
|
|
const AMsg: String;
|
|
const ALogLevel: Integer) of object;
|
|
|
|
THTTPServerClientEvent = procedure (
|
|
const AServer: TF5HTTPServer;
|
|
const AClient: THTTPServerClient) of object;
|
|
|
|
THTTPServerClientContentEvent = procedure (
|
|
const AServer: TF5HTTPServer;
|
|
const AClient: THTTPServerClient;
|
|
const Buf; const Size: Integer) of object;
|
|
|
|
TF5HTTPServer = class(TComponent)
|
|
protected
|
|
FOnLog : THTTPServerLogEvent;
|
|
FOnStart : THTTPServerEvent;
|
|
FOnStop : THTTPServerEvent;
|
|
FOnActive : THTTPServerEvent;
|
|
FOnInactive : THTTPServerEvent;
|
|
FOnRequestHeader : THTTPServerClientEvent;
|
|
FOnRequestContent : THTTPServerClientContentEvent;
|
|
FOnRequestComplete : THTTPServerClientEvent;
|
|
FOnPrepareResponse : THTTPServerClientEvent;
|
|
FOnResponseComplete : THTTPServerClientEvent;
|
|
|
|
FAddressFamily : THTTPServerAddressFamily;
|
|
FBindAddressStr : String;
|
|
FServerPort : Integer;
|
|
FMaxBacklog : Integer;
|
|
FMaxClients : Integer;
|
|
FServerName : RawByteString;
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
FHTTPSEnabled : Boolean;
|
|
FHTTPSOptions : THTTPSServerOptions;
|
|
{$ENDIF}
|
|
|
|
FRequestContentMechanism : THTTPContentReaderMechanism;
|
|
FResponseContentMechanism : THTTPContentWriterMechanism;
|
|
|
|
FUserObject : TObject;
|
|
FUserData : Pointer;
|
|
FUserTag : NativeInt;
|
|
|
|
FLock : TCriticalSection;
|
|
FActive : Boolean;
|
|
FStopping : Boolean;
|
|
FActivateOnLoaded : Boolean;
|
|
FTCPServer : TF5TCPServer;
|
|
|
|
procedure Init; virtual;
|
|
procedure InitTCPServer;
|
|
procedure InitDefaults; virtual;
|
|
|
|
procedure Loaded; override;
|
|
|
|
procedure Log(const LogType: THTTPServerLogType; const Msg: String; const LogLevel: Integer = 0); overload;
|
|
procedure Log(const LogType: THTTPServerLogType; const Msg: String; const Args: array of const; const LogLevel: Integer = 0); overload;
|
|
|
|
procedure Lock;
|
|
procedure Unlock;
|
|
|
|
procedure CheckNotActive;
|
|
|
|
procedure SetAddressFamily(const AddressFamily: THTTPServerAddressFamily);
|
|
procedure SetBindAddress(const BindAddressStr: String);
|
|
procedure SetServerPort(const ServerPort: Integer);
|
|
procedure SetMaxBacklog(const MaxBacklog: Integer);
|
|
procedure SetMaxClients(const MaxClients: Integer);
|
|
|
|
procedure SetServerName(const ServerName: RawByteString);
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
procedure SetHTTPSEnabled(const HTTPSEnabled: Boolean);
|
|
procedure SetHTTPSOptions(const HTTPSOptions: THTTPSServerOptions);
|
|
{$ENDIF}
|
|
|
|
procedure SetRequestContentMechanism(const RequestContentMechanism: THTTPContentReaderMechanism);
|
|
|
|
procedure TriggerStart;
|
|
procedure TriggerStop;
|
|
procedure TriggerActive;
|
|
procedure TriggerInactive;
|
|
procedure TriggerRequestHeader(const Client: THTTPServerClient);
|
|
procedure TriggerRequestContent(const Client: THTTPServerClient; const Buf; const Size: Integer);
|
|
procedure TriggerRequestComplete(const Client: THTTPServerClient);
|
|
procedure TriggerPrepareResponse(const Client: THTTPServerClient);
|
|
procedure TriggerResponseComplete(const Client: THTTPServerClient);
|
|
|
|
procedure TCPServerLog(Sender: TF5TCPServer; LogType: TTCPLogType; Msg: String; LogLevel: Integer);
|
|
procedure TCPServerStateChanged(Sender: TF5TCPServer; State: TTCPServerState);
|
|
procedure TCPServerClientAccept(Sender: TF5TCPServer; Address: TSocketAddr;
|
|
var AcceptClient: Boolean);
|
|
procedure TCPServerClientCreate(Sender: TTCPServerClient);
|
|
procedure TCPServerClientAdd(Sender: TTCPServerClient);
|
|
procedure TCPServerClientRemove(Sender: TTCPServerClient);
|
|
procedure TCPServerClientStateChange(Sender: TTCPServerClient);
|
|
procedure TCPServerClientRead(Sender: TTCPServerClient);
|
|
procedure TCPServerClientWrite(Sender: TTCPServerClient);
|
|
procedure TCPServerClientClose(Sender: TTCPServerClient);
|
|
|
|
procedure ClientLog(const Client: THTTPServerClient; const LogType: THTTPServerLogType; const Msg: String; const LogLevel: Integer);
|
|
procedure ClientStateChanged(const Client: THTTPServerClient);
|
|
procedure ClientRequestHeader(const Client: THTTPServerClient);
|
|
procedure ClientRequestContentBuffer(const Client: THTTPServerClient; const Buf; const Size: Integer);
|
|
procedure ClientRequestContentComplete(const Client: THTTPServerClient);
|
|
procedure ClientPrepareResponse(const Client: THTTPServerClient);
|
|
procedure ClientResponseComplete(const Client: THTTPServerClient);
|
|
|
|
procedure SetupTCPServer;
|
|
|
|
procedure DoStart;
|
|
procedure DoStop;
|
|
|
|
procedure SetActive(const AActive: Boolean);
|
|
|
|
function GetClientCount: Integer;
|
|
|
|
public
|
|
constructor Create(AOwner: TComponent); override;
|
|
destructor Destroy; override;
|
|
procedure Finalise;
|
|
|
|
property OnLog: THTTPServerLogEvent read FOnLog write FOnLog;
|
|
|
|
property OnStart: THTTPServerEvent read FOnStart write FOnStart;
|
|
property OnStop: THTTPServerEvent read FOnStop write FOnStop;
|
|
property OnActive: THTTPServerEvent read FOnActive write FOnActive;
|
|
property OnInactive: THTTPServerEvent read FOnInactive write FOnInactive;
|
|
|
|
property OnRequestHeader: THTTPServerClientEvent read FOnRequestHeader write FOnRequestHeader;
|
|
property OnRequestContent: THTTPServerClientContentEvent read FOnRequestContent write FOnRequestContent;
|
|
property OnRequestComplete: THTTPServerClientEvent read FOnRequestComplete write FOnRequestComplete;
|
|
property OnPrepareResponse: THTTPServerClientEvent read FOnPrepareResponse write FOnPrepareResponse;
|
|
property OnResponseComplete: THTTPServerClientEvent read FOnResponseComplete write FOnResponseComplete;
|
|
|
|
property AddressFamily: THTTPServerAddressFamily read FAddressFamily write SetAddressFamily default safIP4;
|
|
property BindAddress: String read FBindAddressStr write SetBindAddress;
|
|
property ServerPort: Integer read FServerPort write SetServerPort;
|
|
property MaxBacklog: Integer read FMaxBacklog write SetMaxBacklog default HTTPSERVER_DefaultMaxBacklog;
|
|
property MaxClients: Integer read FMaxClients write SetMaxClients default HTTPSERVER_DefaultMaxClients;
|
|
|
|
property ServerName: RawByteString read FServerName write SetServerName;
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
property HTTPSEnabled: Boolean read FHTTPSEnabled write SetHTTPSEnabled default False;
|
|
property HTTPSOptions: THTTPSServerOptions read FHTTPSOptions write SetHTTPSOptions default [];
|
|
{$ENDIF}
|
|
|
|
property RequestContentMechanism: THTTPContentReaderMechanism read FRequestContentMechanism write SetRequestContentMechanism default hcrmEvent;
|
|
|
|
property Active: Boolean read FActive write SetActive default False;
|
|
|
|
property TCPServer: TF5TCPServer read FTCPServer;
|
|
|
|
property ClientCount: Integer read GetClientCount;
|
|
|
|
property UserObject: TObject read FUserObject write FUserObject;
|
|
property UserTag: NativeInt read FUserTag write FUserTag;
|
|
end;
|
|
|
|
EHTTPServer = class(Exception);
|
|
|
|
|
|
|
|
{ }
|
|
{ Component }
|
|
{ }
|
|
type
|
|
TfclHTTPServer = class(TF5HTTPServer)
|
|
published
|
|
property OnLog;
|
|
|
|
property OnStart;
|
|
property OnStop;
|
|
property OnActive;
|
|
property OnInactive;
|
|
|
|
property OnRequestHeader;
|
|
property OnRequestContent;
|
|
property OnRequestComplete;
|
|
property OnPrepareResponse;
|
|
property OnResponseComplete;
|
|
|
|
property AddressFamily;
|
|
property BindAddress;
|
|
property ServerPort;
|
|
property MaxBacklog;
|
|
property MaxClients;
|
|
|
|
property ServerName;
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
property HTTPSEnabled;
|
|
property HTTPSOptions;
|
|
{$ENDIF}
|
|
|
|
property RequestContentMechanism;
|
|
|
|
property Active;
|
|
end;
|
|
|
|
|
|
|
|
implementation
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
uses
|
|
flcTLSTransportServer;
|
|
{$ENDIF}
|
|
|
|
|
|
|
|
{ }
|
|
{ HTTP Server constants }
|
|
{ }
|
|
const
|
|
HTTPSERVER_RequestHeader_MaxSize = 16384;
|
|
HTTPSERVER_RequestHeader_Delim = #13#10#13#10;
|
|
HTTPSERVER_RequestHeader_DelimLen = Length(HTTPSERVER_RequestHeader_Delim);
|
|
|
|
|
|
|
|
{ }
|
|
{ Errors and debug strings }
|
|
{ }
|
|
const
|
|
SError_NotAllowedWhileActive = 'Operation not allowed while active';
|
|
|
|
const
|
|
SClientState : array[THTTPServerClientState] of String = (
|
|
'Initialise',
|
|
'AwaitingRequest',
|
|
'ReceivedRequestHeader',
|
|
'ReceivingContent',
|
|
'RequestComplete',
|
|
'PreparingResponse',
|
|
'AwaitingPreparedResponse',
|
|
'SendingResponseHeader',
|
|
'SendingContent',
|
|
'ResponseComplete',
|
|
'ResponseCompleteAndClosing',
|
|
'ResponseCompleteAndClosed',
|
|
'RequestInterruptedAndClosed'
|
|
);
|
|
|
|
|
|
|
|
{ }
|
|
{ THTTPServerClient }
|
|
{ }
|
|
constructor THTTPServerClient.Create(
|
|
const AHTTPServer: TF5HTTPServer;
|
|
const ATCPClient: TTCPServerClient);
|
|
begin
|
|
Assert(Assigned(AHTTPServer));
|
|
Assert(Assigned(ATCPClient));
|
|
|
|
inherited Create;
|
|
|
|
FHTTPServer := AHTTPServer;
|
|
FTCPClient := ATCPClient;
|
|
Init;
|
|
end;
|
|
|
|
procedure THTTPServerClient.Init;
|
|
begin
|
|
FLock := TCriticalSection.Create;
|
|
FState := hscsInit;
|
|
|
|
InitHTTPRequest(FRequest);
|
|
InitHTTPResponse(FResponse);
|
|
|
|
FHTTPParser := THTTPParser.Create;
|
|
|
|
FRequestContentReader := THTTPContentReader.Create(
|
|
ContentReaderReadProc,
|
|
ContentReaderContentProc,
|
|
ContentReaderContentCompleteProc);
|
|
FRequestContentReader.OnLog := ContentReaderLog;
|
|
FRequestContentReader.Mechanism := FHTTPServer.FRequestContentMechanism;
|
|
|
|
FResponseContentWriter := THTTPContentWriter.Create(ContentWriterWriteProc);
|
|
FResponseContentWriter.OnLog := ContentWriterLog;
|
|
FResponseContentWriter.Mechanism := hctmNone;
|
|
end;
|
|
|
|
destructor THTTPServerClient.Destroy;
|
|
begin
|
|
FreeAndNil(FResponseContentWriter);
|
|
FreeAndNil(FRequestContentReader);
|
|
FreeAndNil(FHTTPParser);
|
|
FreeAndNil(FLock);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure THTTPServerClient.Finalise;
|
|
begin
|
|
FHTTPServer := nil;
|
|
FTCPClient := nil;
|
|
end;
|
|
|
|
procedure THTTPServerClient.Log(const LogType: THTTPServerLogType; const Msg: String; const LogLevel: Integer);
|
|
begin
|
|
if Assigned(FHTTPServer) then
|
|
FHTTPServer.ClientLog(self, LogType, Msg, LogLevel);
|
|
end;
|
|
|
|
procedure THTTPServerClient.Log(const LogType: THTTPServerLogType; const Msg: String; const Args: array of const; const LogLevel: Integer);
|
|
begin
|
|
Log(LogType, Format(Msg, Args), LogLevel);
|
|
end;
|
|
|
|
procedure THTTPServerClient.Lock;
|
|
begin
|
|
FLock.Acquire;
|
|
end;
|
|
|
|
procedure THTTPServerClient.Unlock;
|
|
begin
|
|
FLock.Release;
|
|
end;
|
|
|
|
function THTTPServerClient.GetState: THTTPServerClientState;
|
|
begin
|
|
Lock;
|
|
try
|
|
Result := FState;
|
|
finally
|
|
Unlock;
|
|
end;
|
|
end;
|
|
|
|
function THTTPServerClient.GetStateStr: String;
|
|
begin
|
|
Result := SClientState[GetState];
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetState(const State: THTTPServerClientState);
|
|
begin
|
|
Lock;
|
|
try
|
|
Assert(State <> FState);
|
|
FState := State;
|
|
finally
|
|
Unlock;
|
|
end;
|
|
TriggerStateChanged;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRemoteAddr: TSocketAddr;
|
|
begin
|
|
Result := FTCPClient.RemoteAddr;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRemoteAddrStr: String;
|
|
begin
|
|
Result := FTCPClient.RemoteAddrStr;
|
|
end;
|
|
|
|
procedure THTTPServerClient.TriggerStateChanged;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'State:%s', [GetStateStr]);
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FHTTPServer));
|
|
FHTTPServer.ClientStateChanged(self);
|
|
end;
|
|
|
|
procedure THTTPServerClient.TriggerRequestHeader;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'RequestHeader:');
|
|
Log(sltDebug, String(HTTPRequestToStr(FRequest)));
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FHTTPServer));
|
|
FHTTPServer.ClientRequestHeader(self);
|
|
end;
|
|
|
|
procedure THTTPServerClient.TriggerRequestContentBuffer(const Buf; const Size: Integer);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'RequestContentBuffer');
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FHTTPServer));
|
|
FHTTPServer.ClientRequestContentBuffer(self, Buf, Size);
|
|
end;
|
|
|
|
procedure THTTPServerClient.TriggerRequestContentComplete;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'RequestContentComplete');
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FHTTPServer));
|
|
FHTTPServer.ClientRequestContentComplete(self);
|
|
end;
|
|
|
|
procedure THTTPServerClient.TriggerPrepareResponse;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'PrepareResponse');
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FHTTPServer));
|
|
FHTTPServer.ClientPrepareResponse(self);
|
|
end;
|
|
|
|
procedure THTTPServerClient.TriggerResponseComplete;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ResponseComplete');
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FHTTPServer));
|
|
FHTTPServer.ClientResponseComplete(self);
|
|
end;
|
|
|
|
procedure THTTPServerClient.TCPClientStateChange;
|
|
begin
|
|
end;
|
|
|
|
procedure THTTPServerClient.TCPClientRead;
|
|
begin
|
|
{ Assert(FState in [
|
|
hscsInit,
|
|
hscsAwaitingRequest,
|
|
hscsReceivingContent,
|
|
hscsResponseComplete,
|
|
hscsResponseCompleteAndClosing,
|
|
hscsResponseCompleteAndClosed]); } //// 2020/05/01 OnRead can be called when closed in TCP connection
|
|
if FState = hscsResponseComplete then
|
|
SetState(hscsAwaitingRequest);
|
|
if FState = hscsAwaitingRequest then
|
|
ReadRequestHeader;
|
|
if FState = hscsReceivedRequestHeader then
|
|
if FRequest.HasContent then
|
|
begin
|
|
InitRequestContent;
|
|
SetState(hscsReceivingContent);
|
|
end
|
|
else
|
|
SetRequestComplete;
|
|
if FState = hscsReceivingContent then
|
|
ReadRequestContent;
|
|
end;
|
|
|
|
procedure THTTPServerClient.TCPClientWrite;
|
|
begin
|
|
end;
|
|
|
|
procedure THTTPServerClient.TCPClientClose;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPClient_Close');
|
|
{$ENDIF}
|
|
|
|
if FState in [hscsInit,
|
|
hscsResponseCompleteAndClosed,
|
|
hscsRequestInterruptedAndClosed] then
|
|
exit;
|
|
if FState in [hscsResponseComplete,
|
|
hscsResponseCompleteAndClosing] then
|
|
SetState(hscsResponseCompleteAndClosed);
|
|
if FState in [hscsAwaitingRequest,
|
|
hscsReceivedRequestHeader,
|
|
hscsReceivingContent,
|
|
hscsRequestComplete,
|
|
hscsPreparingResponse,
|
|
hscsSendingResponseHeader,
|
|
hscsSendingContent] then
|
|
SetState(hscsRequestInterruptedAndClosed);
|
|
end;
|
|
|
|
procedure THTTPServerClient.ContentReaderLog(const Sender: THTTPContentReader; const LogMsg: String; const LogLevel: Integer);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, Format('ContentReader:%s', [LogMsg]), LogLevel + 1);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function THTTPServerClient.ContentReaderReadProc(const Sender: THTTPContentReader;
|
|
var Buf; const Size: Integer): Integer;
|
|
begin
|
|
Assert(Assigned(FTCPClient));
|
|
Assert(FState in [hscsReceivingContent]);
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ContentReader_Read');
|
|
{$ENDIF}
|
|
|
|
Result := FTCPClient.Connection.Read(Buf, Size);
|
|
end;
|
|
|
|
procedure THTTPServerClient.ContentReaderContentProc(const Sender: THTTPContentReader;
|
|
const Buf; const Size: Integer);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ContentReader_Content');
|
|
{$ENDIF}
|
|
|
|
TriggerRequestContentBuffer(Buf, Size);
|
|
end;
|
|
|
|
procedure THTTPServerClient.ContentReaderContentCompleteProc(const Sender: THTTPContentReader);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ContentReader_ContentComplete');
|
|
{$ENDIF}
|
|
|
|
FinaliseRequestContent;
|
|
SetRequestComplete;
|
|
end;
|
|
|
|
procedure THTTPServerClient.ContentWriterLog(const Sender: THTTPContentWriter;
|
|
const LogMsg: String);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, Format('ContentWriter:%s', [LogMsg]), 1);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
function THTTPServerClient.ContentWriterWriteProc(const Sender: THTTPContentWriter;
|
|
const Buf; const Size: Integer): Integer;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ContentWriter_Write');
|
|
{$ENDIF}
|
|
|
|
Result := FTCPClient.Connection.Write(Buf, Size);
|
|
end;
|
|
|
|
procedure THTTPServerClient.SendStr(const S: RawByteString);
|
|
begin
|
|
Assert(Assigned(FTCPClient));
|
|
FTCPClient.Connection.WriteByteString(S);
|
|
end;
|
|
|
|
procedure THTTPServerClient.Start;
|
|
begin
|
|
Assert(FState = hscsInit);
|
|
SetState(hscsAwaitingRequest);
|
|
end;
|
|
|
|
procedure THTTPServerClient.ClearResponse;
|
|
begin
|
|
ClearHTTPResponse(FResponse);
|
|
FResponseReady := False;
|
|
FResponseContentWriter.Clear;
|
|
FResponseContentWriter.Mechanism := hctmNone;
|
|
end;
|
|
|
|
procedure THTTPServerClient.ReadRequestHeader;
|
|
const
|
|
HdrBufSize = HTTPSERVER_RequestHeader_MaxSize + HTTPSERVER_RequestHeader_DelimLen;
|
|
var
|
|
HdrBuf : array[0..HdrBufSize - 1] of Byte;
|
|
HdrLen : Integer;
|
|
begin
|
|
Assert(Assigned(FTCPClient));
|
|
Assert(FState in [hscsAwaitingRequest]);
|
|
|
|
HdrLen := FTCPClient.Connection.PeekDelimited(
|
|
HdrBuf[0], HdrBufSize,
|
|
HTTPSERVER_RequestHeader_Delim,
|
|
HTTPSERVER_RequestHeader_MaxSize);
|
|
if HdrLen < 0 then
|
|
exit;
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'RequestHeader:%db', [HdrLen]);
|
|
{$ENDIF}
|
|
|
|
ClearHTTPRequest(FRequest);
|
|
FHTTPParser.SetTextBuf(HdrBuf[0], HdrLen);
|
|
FHTTPParser.ParseRequest(FRequest);
|
|
if not FRequest.HeaderComplete then
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'RequestHeader:BadFormat:ClosingConnection');
|
|
{$ENDIF}
|
|
|
|
FTCPClient.Close;
|
|
exit;
|
|
end;
|
|
FTCPClient.Connection.Discard(HdrLen);
|
|
|
|
ClearResponse;
|
|
ProcessRequestHeader;
|
|
SetState(hscsReceivedRequestHeader);
|
|
TriggerRequestHeader;
|
|
end;
|
|
|
|
procedure THTTPServerClient.ProcessRequestHeader;
|
|
begin
|
|
end;
|
|
|
|
procedure THTTPServerClient.InitRequestContent;
|
|
begin
|
|
FRequestContentReader.InitReader(FRequest.Header.CommonHeaders);
|
|
end;
|
|
|
|
procedure THTTPServerClient.ReadRequestContent;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ReadRequestContent');
|
|
{$ENDIF}
|
|
FRequestContentReader.Process;
|
|
end;
|
|
|
|
procedure THTTPServerClient.FinaliseRequestContent;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'FinaliseRequestContent');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetRequestComplete;
|
|
begin
|
|
SetState(hscsRequestComplete);
|
|
InitResponse;
|
|
TriggerRequestContentComplete;
|
|
SetState(hscsPreparingResponse);
|
|
PrepareResponse;
|
|
if not FResponseReady then
|
|
begin
|
|
SetState(hscsAwaitingPreparedResponse);
|
|
exit;
|
|
end;
|
|
ResponsePrepared;
|
|
end;
|
|
|
|
procedure THTTPServerClient.InitResponse;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'InitResponse');
|
|
{$ENDIF}
|
|
|
|
FResponse.StartLine.Version := FRequest.StartLine.Version;
|
|
if FRequest.StartLine.Version.Version = hvHTTP11 then
|
|
case FRequest.Header.CommonHeaders.Connection.Value of
|
|
hcfClose : FResponse.Header.CommonHeaders.Connection.Value := hcfClose;
|
|
hcfKeepAlive : FResponse.Header.CommonHeaders.Connection.Value := hcfKeepAlive;
|
|
end;
|
|
|
|
FResponse.Header.CommonHeaders.Date.Value := hdDateTime;
|
|
FResponse.Header.CommonHeaders.Date.DateTime := Now;
|
|
|
|
if FHTTPServer.FServerName <> '' then
|
|
FResponse.Header.FixedHeaders[hntServer] := FHTTPServer.FServerName;
|
|
end;
|
|
|
|
procedure THTTPServerClient.PrepareResponse;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'PrepareResponse');
|
|
{$ENDIF}
|
|
|
|
TriggerPrepareResponse;
|
|
if FResponse.StartLine.Msg = hslmNone then
|
|
FResponse.StartLine.Msg := HTTPResponseCodeToStartLineMessage(FResponse.StartLine.Code);
|
|
end;
|
|
|
|
procedure THTTPServerClient.InitResponseContent;
|
|
var HasContent : Boolean;
|
|
ContentLen : Int64;
|
|
B : Int64;
|
|
begin
|
|
FResponseContentWriter.InitContent(HasContent, ContentLen);
|
|
if not HasContent then
|
|
B := 0
|
|
else
|
|
B := ContentLen;
|
|
FResponse.Header.CommonHeaders.ContentLength.Value := hcltByteCount;
|
|
FResponse.Header.CommonHeaders.ContentLength.ByteCount := B;
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, Format('InitResponseContent:%d:%db:%db', [Ord(HasContent), ContentLen, B]));
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure THTTPServerClient.SendResponseContent;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'SendResponseContent');
|
|
{$ENDIF}
|
|
|
|
FResponseContentWriter.SendContent;
|
|
end;
|
|
|
|
procedure THTTPServerClient.ResponsePrepared;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ResponsePrepared');
|
|
{$ENDIF}
|
|
|
|
SendResponse;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SendResponse;
|
|
var ResponseHdr : RawByteString;
|
|
begin
|
|
InitResponseContent;
|
|
|
|
SetState(hscsSendingResponseHeader);
|
|
ResponseHdr := HTTPResponseToStr(FResponse);
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ResponseHeader:');
|
|
Log(sltDebug, String(ResponseHdr));
|
|
{$ENDIF}
|
|
|
|
SendStr(HTTPResponseToStr(FResponse));
|
|
SetState(hscsSendingContent);
|
|
SendResponseContent;
|
|
if not FResponseContentWriter.ContentComplete then
|
|
exit;
|
|
|
|
SetResponseComplete;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseComplete;
|
|
begin
|
|
Assert(FState = hscsSendingContent);
|
|
SetState(hscsResponseComplete);
|
|
|
|
TriggerResponseComplete;
|
|
|
|
if (FRequest.StartLine.Version.Version = hvHTTP10) or
|
|
(FRequest.Header.CommonHeaders.Connection.Value = hcfClose) or
|
|
(FResponse.Header.CommonHeaders.Connection.Value = hcfClose) then
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'SetResponseComplete:ConnectionClose');
|
|
{$ENDIF}
|
|
|
|
FTCPClient.Connection.Shutdown;
|
|
SetState(hscsResponseCompleteAndClosing);
|
|
end;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestMethod: RawByteString;
|
|
begin
|
|
Result := HTTPMethodToStr(FRequest.StartLine.Method);
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestURI: RawByteString;
|
|
begin
|
|
Result := FRequest.StartLine.URI;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestHost: RawByteString;
|
|
begin
|
|
Result := FRequest.Header.FixedHeaders[hntHost];
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestCookie: RawByteString;
|
|
begin
|
|
Result := HTTPCookieFieldValueToStr(FRequest.Header.Cookie);
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestHasContent: Boolean;
|
|
begin
|
|
Result := FRequest.HasContent;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestContentType: RawByteString;
|
|
begin
|
|
Result := HTTPContentTypeValueToStr(FRequest.Header.CommonHeaders.ContentType);
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestRecordPtr: PHTTPRequest;
|
|
begin
|
|
Result := @FRequest;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseCode: Integer;
|
|
begin
|
|
Result := FResponse.StartLine.Code;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseCode(const AResponseCode: Integer);
|
|
begin
|
|
FResponse.StartLine.Code := AResponseCode;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseMsg: RawByteString;
|
|
begin
|
|
Result := FResponse.StartLine.CustomMsg;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseMsg(const AResponseMsg: RawByteString);
|
|
begin
|
|
FResponse.StartLine.Msg := hslmCustom;
|
|
FResponse.StartLine.CustomMsg := AResponseMsg;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseContentType: RawByteString;
|
|
begin
|
|
Result := HTTPContentTypeValueToStr(FResponse.Header.CommonHeaders.ContentType);
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseContentType(
|
|
const AResponseContentType: RawByteString);
|
|
begin
|
|
FResponse.Header.CommonHeaders.ContentType.Value := hctCustomString;
|
|
FResponse.Header.CommonHeaders.ContentType.CustomStr := AResponseContentType;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseRecordPtr: PHTTPResponse;
|
|
begin
|
|
Result := @FResponse;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestContentStream: TStream;
|
|
begin
|
|
Result := FRequestContentReader.ContentStream;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetRequestContentStream(const ARequestContentStream: TStream);
|
|
begin
|
|
FRequestContentReader.ContentStream := ARequestContentStream;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestContentFileName: String;
|
|
begin
|
|
Result := FRequestContentReader.ContentFileName;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetRequestContentFileName(const ARequestContentFileName: String);
|
|
begin
|
|
FRequestContentReader.ContentFileName := ARequestContentFileName;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestContentStr: RawByteString;
|
|
begin
|
|
Result := FRequestContentReader.ContentString;
|
|
end;
|
|
|
|
function THTTPServerClient.GetRequestContentReceivedSize: Int64;
|
|
begin
|
|
Result := FRequestContentReader.ContentReceivedSize;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseContentMechanism: THTTPContentWriterMechanism;
|
|
begin
|
|
Result := FResponseContentWriter.Mechanism;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseContentMechanism(
|
|
const AResponseContentMechanism: THTTPContentWriterMechanism);
|
|
begin
|
|
FResponseContentWriter.Mechanism := AResponseContentMechanism;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseContentStr: RawByteString;
|
|
begin
|
|
Result := FResponseContentWriter.ContentString;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseContentStr(const AResponseContentStr: RawByteString);
|
|
begin
|
|
FResponseContentWriter.Mechanism := hctmString;
|
|
FResponseContentWriter.ContentString := AResponseContentStr;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseContentStream: TStream;
|
|
begin
|
|
Result := FResponseContentWriter.ContentStream;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseContentStream(const AResponseContentStream: TStream);
|
|
begin
|
|
FResponseContentWriter.Mechanism := hctmStream;
|
|
FResponseContentWriter.ContentStream := AResponseContentStream;
|
|
end;
|
|
|
|
function THTTPServerClient.GetResponseContentFileName: String;
|
|
begin
|
|
Result := FResponseContentWriter.ContentFileName;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseContentFileName(const AResponseContentFileName: String);
|
|
begin
|
|
FResponseContentWriter.Mechanism := hctmFile;
|
|
FResponseContentWriter.ContentFileName := AResponseContentFileName;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseReady(const AResponseReady: Boolean);
|
|
begin
|
|
if not AResponseReady then
|
|
exit;
|
|
Assert(FState in [hscsInit, hscsAwaitingRequest, hscsReceivedRequestHeader,
|
|
hscsReceivingContent, hscsRequestComplete, hscsPreparingResponse,
|
|
hscsAwaitingPreparedResponse]);
|
|
|
|
FResponseReady := AResponseReady;
|
|
if FState = hscsAwaitingPreparedResponse then
|
|
ResponsePrepared;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseOKHtmlStr(const AHtmlStr: RawByteString);
|
|
var ContentType : THTTPContentTypeEnum;
|
|
begin
|
|
ResponseCode := HTTP_ResponseCode_OK;
|
|
if Length(AHtmlStr) > 0 then
|
|
ContentType := hctTextHtml
|
|
else
|
|
ContentType := hctNone;
|
|
ResponseRecordPtr^.Header.CommonHeaders.ContentType.Value := ContentType;
|
|
|
|
ResponseContentMechanism := hctmString;
|
|
ResponseContentStr := AHtmlStr;
|
|
ResponseReady := True;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseOKFile(
|
|
const AContentType: THTTPContentTypeEnum;
|
|
const AFileName: String);
|
|
begin
|
|
ResponseCode := HTTP_ResponseCode_OK;
|
|
ResponseRecordPtr^.Header.CommonHeaders.ContentType.Value := AContentType;
|
|
ResponseContentMechanism := hctmFile;
|
|
ResponseContentFileName := AFileName;
|
|
ResponseReady := True;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseNotFound;
|
|
begin
|
|
ResponseCode := HTTP_ResponseCode_NotFound;
|
|
ResponseRecordPtr^.Header.CommonHeaders.Connection.Value := hcfClose;
|
|
ResponseReady := True;
|
|
end;
|
|
|
|
procedure THTTPServerClient.SetResponseRedirect(const ALocation: RawByteString);
|
|
begin
|
|
ResponseCode := HTTP_ResponseCode_SeeOther;
|
|
ResponseRecordPtr^.Header.FixedHeaders[hntLocation] := ALocation;
|
|
ResponseReady := True;
|
|
end;
|
|
|
|
procedure THTTPServerClient.Disconnect;
|
|
begin
|
|
if Assigned(FTCPClient) then
|
|
FTCPClient.Close;
|
|
end;
|
|
|
|
|
|
|
|
{ }
|
|
{ TF5HTTPServer }
|
|
{ }
|
|
constructor TF5HTTPServer.Create(AOwner: TComponent);
|
|
begin
|
|
inherited Create(AOwner);
|
|
Init;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Init;
|
|
begin
|
|
FLock := TCriticalSection.Create;
|
|
InitDefaults;
|
|
InitTCPServer;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.InitTCPServer;
|
|
begin
|
|
FTCPServer := TF5TCPServer.Create(nil);
|
|
FTCPServer.OnLog := TCPServerLog;
|
|
FTCPServer.OnStateChanged := TCPServerStateChanged;
|
|
FTCPServer.OnClientAccept := TCPServerClientAccept;
|
|
FTCPServer.OnClientCreate := TCPServerClientCreate;
|
|
FTCPServer.OnClientAdd := TCPServerClientAdd;
|
|
FTCPServer.OnClientRemove := TCPServerClientRemove;
|
|
FTCPServer.OnClientStateChange := TCPServerClientStateChange;
|
|
FTCPServer.OnClientRead := TCPServerClientRead;
|
|
FTCPServer.OnClientWrite := TCPServerClientWrite;
|
|
FTCPServer.OnClientClose := TCPServerClientClose;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.InitDefaults;
|
|
begin
|
|
FAddressFamily := safIP4;
|
|
FBindAddressStr := '0.0.0.0';
|
|
FServerPort := HTTPSERVER_DefaultPort;
|
|
FMaxBacklog := HTTPSERVER_DefaultMaxBacklog;
|
|
FMaxClients := HTTPSERVER_DefaultMaxClients;
|
|
{$IFDEF HTTP_TLS}
|
|
FHTTPSEnabled := False;
|
|
{$ENDIF}
|
|
FRequestContentMechanism := hcrmEvent;
|
|
FResponseContentMechanism := hctmNone;
|
|
end;
|
|
|
|
destructor TF5HTTPServer.Destroy;
|
|
begin
|
|
FreeAndNil(FTCPServer);
|
|
FreeAndNil(FLock);
|
|
inherited Destroy;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Finalise;
|
|
begin
|
|
FUserObject := nil;
|
|
if Assigned(FTCPServer) then
|
|
FTCPServer.Finalise;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Loaded;
|
|
begin
|
|
inherited Loaded;
|
|
if FActivateOnLoaded then
|
|
DoStart;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Log(
|
|
const LogType: THTTPServerLogType;
|
|
const Msg: String;
|
|
const LogLevel: Integer);
|
|
begin
|
|
if Assigned(FOnLog) then
|
|
FOnLog(self, LogType, Msg, LogLevel);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Log(
|
|
const LogType: THTTPServerLogType;
|
|
const Msg: String;
|
|
const Args: array of const;
|
|
const LogLevel: Integer);
|
|
begin
|
|
Log(LogType, Format(Msg, Args), LogLevel);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Lock;
|
|
begin
|
|
FLock.Acquire;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.Unlock;
|
|
begin
|
|
FLock.Release;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.CheckNotActive;
|
|
begin
|
|
if not (csDesigning in ComponentState) then
|
|
if FActive then
|
|
raise EHTTPServer.Create(SError_NotAllowedWhileActive);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetAddressFamily(const AddressFamily: THTTPServerAddressFamily);
|
|
begin
|
|
if AddressFamily = FAddressFamily then
|
|
exit;
|
|
CheckNotActive;
|
|
FAddressFamily := AddressFamily;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetBindAddress(const BindAddressStr: String);
|
|
begin
|
|
if BindAddressStr = FBindAddressStr then
|
|
exit;
|
|
CheckNotActive;
|
|
FBindAddressStr := BindAddressStr;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetServerPort(const ServerPort: Integer);
|
|
begin
|
|
if ServerPort = FServerPort then
|
|
exit;
|
|
|
|
CheckNotActive;
|
|
FServerPort := ServerPort;
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ServerPort:%d', [ServerPort]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetMaxBacklog(const MaxBacklog: Integer);
|
|
begin
|
|
FMaxBacklog := MaxBacklog;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetMaxClients(const MaxClients: Integer);
|
|
begin
|
|
FMaxClients := MaxClients;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetServerName(const ServerName: RawByteString);
|
|
begin
|
|
if ServerName = FServerName then
|
|
exit;
|
|
|
|
CheckNotActive;
|
|
FServerName := ServerName;
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'ServerName:%s', [ServerName]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
procedure TF5HTTPServer.SetHTTPSEnabled(const HTTPSEnabled: Boolean);
|
|
begin
|
|
if HTTPSEnabled = FHTTPSEnabled then
|
|
exit;
|
|
|
|
CheckNotActive;
|
|
FHTTPSEnabled := HTTPSEnabled;
|
|
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'HTTPSEnabled:%d', [Ord(HTTPSEnabled)]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetHTTPSOptions(const HTTPSOptions: THTTPSServerOptions);
|
|
begin
|
|
if HTTPSOptions = FHTTPSOptions then
|
|
exit;
|
|
|
|
CheckNotActive;
|
|
FHTTPSOptions := HTTPSOptions;
|
|
end;
|
|
{$ENDIF}
|
|
|
|
procedure TF5HTTPServer.SetRequestContentMechanism(
|
|
const RequestContentMechanism: THTTPContentReaderMechanism);
|
|
begin
|
|
if RequestContentMechanism = FRequestContentMechanism then
|
|
exit;
|
|
|
|
CheckNotActive;
|
|
FRequestContentMechanism := RequestContentMechanism;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerStart;
|
|
begin
|
|
if Assigned(FOnStart) then
|
|
FOnStart(self);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerStop;
|
|
begin
|
|
if Assigned(FOnStop) then
|
|
FOnStop(self);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerActive;
|
|
begin
|
|
if Assigned(FOnActive) then
|
|
FOnActive(self);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerInactive;
|
|
begin
|
|
if Assigned(FOnInactive) then
|
|
FOnInactive(self);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerRequestHeader(const Client: THTTPServerClient);
|
|
begin
|
|
if Assigned(FOnRequestHeader) then
|
|
FOnRequestHeader(self, Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerRequestContent(
|
|
const Client: THTTPServerClient;
|
|
const Buf; const Size: Integer);
|
|
begin
|
|
if Assigned(FOnRequestContent) then
|
|
FOnRequestContent(self, Client, Buf, Size);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerRequestComplete(const Client: THTTPServerClient);
|
|
begin
|
|
if Assigned(FOnRequestComplete) then
|
|
FOnRequestComplete(self, Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerPrepareResponse(const Client: THTTPServerClient);
|
|
begin
|
|
if Assigned(FOnPrepareResponse) then
|
|
FOnPrepareResponse(self, Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TriggerResponseComplete(const Client: THTTPServerClient);
|
|
begin
|
|
if Assigned(FOnResponseComplete) then
|
|
FOnResponseComplete(self, Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerLog(
|
|
Sender: TF5TCPServer;
|
|
LogType: TTCPLogType;
|
|
Msg: String;
|
|
LogLevel: Integer);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer:%s', [Msg], LogLevel + 1);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerStateChanged(Sender: TF5TCPServer; State: TTCPServerState);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ServerStateChange:%s', [Sender.StateStr]);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientAccept(Sender: TF5TCPServer; Address: TSocketAddr;
|
|
var AcceptClient: Boolean);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientAccept');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientCreate(Sender: TTCPServerClient);
|
|
var C : THTTPServerClient;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientCreate');
|
|
{$ENDIF}
|
|
|
|
C := THTTPServerClient.Create(self, Sender);
|
|
Sender.UserObject := C;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientAdd(Sender: TTCPServerClient);
|
|
var C : THTTPServerClient;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientAdd');
|
|
{$ENDIF}
|
|
|
|
Assert(Sender.UserObject is THTTPServerClient);
|
|
C := THTTPServerClient(Sender.UserObject);
|
|
C.Start;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientRemove(Sender: TTCPServerClient);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientRemove');
|
|
{$ENDIF}
|
|
|
|
Assert(not Assigned(Sender.UserObject) or (Sender.UserObject is THTTPServerClient));
|
|
if Assigned(Sender.UserObject) then
|
|
begin
|
|
THTTPServerClient(Sender.UserObject).Finalise;
|
|
{$IFNDEF NEXTGEN}
|
|
Sender.UserObject.Free;
|
|
{$ENDIF}
|
|
Sender.UserObject := nil;
|
|
end;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientStateChange(Sender: TTCPServerClient);
|
|
var C : THTTPServerClient;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientStateChange:%s', [Sender.StateStr]);
|
|
{$ENDIF}
|
|
|
|
C := Sender.UserObject as THTTPServerClient;
|
|
C.TCPClientStateChange;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientRead(Sender: TTCPServerClient);
|
|
var C : THTTPServerClient;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientRead');
|
|
{$ENDIF}
|
|
|
|
Assert(Sender.UserObject is THTTPServerClient);
|
|
C := Sender.UserObject as THTTPServerClient;
|
|
C.TCPClientRead;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientWrite(Sender: TTCPServerClient);
|
|
var C : THTTPServerClient;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientWrite');
|
|
{$ENDIF}
|
|
|
|
Assert(Sender.UserObject is THTTPServerClient);
|
|
C := THTTPServerClient(Sender.UserObject);
|
|
C.TCPClientWrite;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.TCPServerClientClose(Sender: TTCPServerClient);
|
|
var C : THTTPServerClient;
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'TCPServer_ClientClose');
|
|
{$ENDIF}
|
|
|
|
Assert(Sender.UserObject is THTTPServerClient);
|
|
C := THTTPServerClient(Sender.UserObject);
|
|
C.TCPClientClose;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientLog(
|
|
const Client: THTTPServerClient;
|
|
const LogType: THTTPServerLogType;
|
|
const Msg: String;
|
|
const LogLevel: Integer);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(LogType, 'Client:%s', [Msg], LogLevel + 1);
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientStateChanged(const Client: THTTPServerClient);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'Client_StateChange');
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientRequestHeader(const Client: THTTPServerClient);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'Client_RequestHeader');
|
|
{$ENDIF}
|
|
|
|
TriggerRequestHeader(Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientRequestContentBuffer(
|
|
const Client: THTTPServerClient;
|
|
const Buf; const Size: Integer);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'Client_RequestContentBuffer');
|
|
{$ENDIF}
|
|
|
|
TriggerRequestContent(Client, Buf, Size);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientRequestContentComplete(const Client: THTTPServerClient);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'Client_RequestContentComplete');
|
|
{$ENDIF}
|
|
|
|
TriggerRequestComplete(Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientPrepareResponse(const Client: THTTPServerClient);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'Client_PrepareResponse');
|
|
{$ENDIF}
|
|
|
|
TriggerPrepareResponse(Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.ClientResponseComplete(const Client: THTTPServerClient);
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'Client_ResponseComplete');
|
|
{$ENDIF}
|
|
|
|
TriggerResponseComplete(Client);
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetupTCPServer;
|
|
var
|
|
AF : TIPAddressFamily;
|
|
{$IFDEF HTTP_TLS}
|
|
//TLSOpt : TTLSServerOptions;
|
|
{$ENDIF}
|
|
begin
|
|
{$IFDEF HTTP_DEBUG}
|
|
Log(sltDebug, 'SetupTCPServer');
|
|
{$ENDIF}
|
|
|
|
Assert(Assigned(FTCPServer));
|
|
|
|
case FAddressFamily of
|
|
safIP4 : AF := iaIP4;
|
|
safIP6 : AF := iaIP6;
|
|
else
|
|
raise EHTTPServer.Create('Invalid parameter');
|
|
end;
|
|
FTCPServer.AddressFamily := AF;
|
|
FTCPServer.BindAddress := FBindAddressStr;
|
|
FTCPServer.ServerPort := FServerPort;
|
|
|
|
{$IFDEF HTTP_TLS}
|
|
FTCPServer.TLSEnabled := FHTTPSEnabled;
|
|
{
|
|
TLSOpt := [];
|
|
if ssoDontUseSSL3 in FHTTPSOptions then
|
|
Include(TLSOpt, tlssoDontUseSSL3);
|
|
if ssoDontUseTLS10 in FHTTPSOptions then
|
|
Include(TLSOpt, tlssoDontUseTLS10);
|
|
if ssoDontUseTLS11 in FHTTPSOptions then
|
|
Include(TLSOpt, tlssoDontUseTLS11);
|
|
if ssoDontUseTLS12 in FHTTPSOptions then
|
|
Include(TLSOpt, tlssoDontUseTLS12);
|
|
FTCPServer.TLSServer.Options := TLSOpt;
|
|
}
|
|
////
|
|
{$ENDIF}
|
|
end;
|
|
|
|
procedure TF5HTTPServer.DoStart;
|
|
begin
|
|
Lock;
|
|
try
|
|
if FActive then
|
|
exit;
|
|
FActive := True;
|
|
finally
|
|
Unlock;
|
|
end;
|
|
|
|
Log(sltInfo, 'Active');
|
|
TriggerActive;
|
|
|
|
Log(sltInfo, 'Start');
|
|
TriggerStart;
|
|
|
|
SetupTCPServer;
|
|
FTCPServer.Start;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.DoStop;
|
|
begin
|
|
Lock;
|
|
try
|
|
if not FActive or FStopping then
|
|
exit;
|
|
FStopping := True;
|
|
finally
|
|
Unlock;
|
|
end;
|
|
|
|
try
|
|
Log(sltInfo, 'Stop');
|
|
TriggerStop;
|
|
|
|
Assert(Assigned(FTCPServer));
|
|
FTCPServer.Stop;
|
|
finally
|
|
Lock;
|
|
try
|
|
FActive := False;
|
|
FStopping := False;
|
|
finally
|
|
Unlock;
|
|
end;
|
|
end;
|
|
|
|
Log(sltInfo, 'Inactive');
|
|
TriggerInactive;
|
|
end;
|
|
|
|
procedure TF5HTTPServer.SetActive(const AActive: Boolean);
|
|
begin
|
|
if AActive then
|
|
DoStart
|
|
else
|
|
DoStop;
|
|
end;
|
|
|
|
function TF5HTTPServer.GetClientCount: Integer;
|
|
begin
|
|
Result := FTCPServer.ClientCount;
|
|
end;
|
|
|
|
|
|
|
|
end.
|
|
|