2411 lines
83 KiB
Plaintext
2411 lines
83 KiB
Plaintext
{
|
||
$Project$
|
||
$Workfile$
|
||
$Revision$
|
||
$DateUTC$
|
||
$Id$
|
||
|
||
This file is part of the Indy (Internet Direct) project, and is offered
|
||
under the dual-licensing agreement described on the Indy website.
|
||
(http://www.indyproject.org/)
|
||
|
||
Copyright:
|
||
(c) 1993-2005, Chad Z. Hower and the Indy Pit Crew. All rights reserved.
|
||
}
|
||
{
|
||
$Log$
|
||
}
|
||
{
|
||
Rev 1.42 3/14/05 11:45:50 AM RLebeau
|
||
Buf fix for DoExecute() not not filling in the TIdHTTPRequestInfo.FormParams
|
||
correctly.
|
||
|
||
Removed LImplicitPostStream variable from DoExecute(), no longer used.
|
||
TIdHTTPRequestInfo takes ownership of the PostStream anyway, so no need to
|
||
free it early. This also allows the PostStream to always be available in the
|
||
OnCommand... event handlers.
|
||
|
||
Rev 1.41 2/9/05 2:11:02 AM RLebeau
|
||
Removed compiler hint
|
||
|
||
Rev 1.40 2/9/05 1:19:26 AM RLebeau
|
||
Fixes for Compiler errors
|
||
|
||
Rev 1.39 2/8/05 6:47:46 PM RLebeau
|
||
updated OnCommandOther to have ARequestInfo and AResponseInfo parameters
|
||
|
||
Rev 1.38 12/16/04 2:15:20 AM RLebeau
|
||
Another DoExecute() update
|
||
|
||
Rev 1.37 12/15/04 9:03:50 PM RLebeau
|
||
Renamed TIdHTTPRequestInfo.DecodeCommand() to DecodeHTTPCommand() and made it
|
||
into a standalone function.
|
||
|
||
Rev 1.36 12/15/04 4:17:42 PM RLebeau
|
||
Updated DoExecute() to call LRequestInfo.DecodeCommand()
|
||
|
||
Rev 1.35 12/2/2004 4:23:48 PM JPMugaas
|
||
Adjusted for changes in Core.
|
||
|
||
Rev 1.34 10/26/2004 8:59:32 PM JPMugaas
|
||
Updated with new TStrings references for more portability.
|
||
|
||
Rev 1.33 2004.05.20 11:37:12 AM czhower
|
||
IdStreamVCL
|
||
|
||
Rev 1.32 5/6/04 3:19:00 PM RLebeau
|
||
Added extra comments
|
||
|
||
Rev 1.31 2004.04.18 12:52:06 AM czhower
|
||
Big bug fix with server disconnect and several other bug fixed that I found
|
||
along the way.
|
||
|
||
Rev 1.30 2004.04.08 1:46:32 AM czhower
|
||
Small Optimizations
|
||
|
||
Rev 1.29 7/4/2004 4:10:44 PM SGrobety
|
||
Small fix to keep it synched with the IOHandler properties
|
||
|
||
Rev 1.28 6/4/2004 5:15:02 PM SGrobety
|
||
Implemented MaximumHeaderLineCount property (default to 1024)
|
||
|
||
Rev 1.27 2004.02.03 5:45:02 PM czhower
|
||
Name changes
|
||
|
||
Rev 1.26 1/27/2004 3:58:52 PM SPerry
|
||
StringStream ->IdStringStream
|
||
|
||
Rev 1.25 2004.01.22 5:58:58 PM czhower
|
||
IdCriticalSection
|
||
|
||
Rev 1.24 1/22/2004 8:26:28 AM JPMugaas
|
||
Ansi* calls changed.
|
||
|
||
Rev 1.23 1/21/2004 1:57:30 PM JPMugaas
|
||
InitComponent
|
||
|
||
Rev 1.22 21.1.2004 <20>. 13:22:18 DBondzhev
|
||
Fix for Dccil bug
|
||
|
||
Rev 1.21 10/25/2003 06:51:44 AM JPMugaas
|
||
Updated for new API changes and tried to restore some functionality.
|
||
|
||
Rev 1.20 2003.10.24 10:43:02 AM czhower
|
||
TIdSTream to dos
|
||
|
||
Rev 1.19 10/19/2003 11:49:40 AM DSiders
|
||
Added localization comments.
|
||
|
||
Rev 1.18 10/17/2003 12:05:40 AM DSiders
|
||
Corrected spelling error in resource string.
|
||
|
||
Rev 1.17 10/15/2003 11:10:16 PM GGrieve
|
||
DotNet changes
|
||
|
||
Rev 1.16 2003.10.12 3:37:58 PM czhower
|
||
Now compiles again.
|
||
|
||
Rev 1.15 6/24/2003 11:38:50 AM BGooijen
|
||
Fixed ssl support
|
||
|
||
Rev 1.14 6/18/2003 11:44:04 PM BGooijen
|
||
Moved ServeFile and SmartServeFile to TIdHTTPResponseInfo.
|
||
Added TIdHTTPResponseInfo.HTTPServer field
|
||
|
||
Rev 1.13 05.6.2003 <20>. 11:11:12 DBondzhev
|
||
Socket exceptions should not be stopped after DoCommandGet.
|
||
|
||
Rev 1.12 4/9/2003 9:38:40 PM BGooijen
|
||
fixed av on FSessionList.PurgeStaleSessions(Terminated);
|
||
|
||
Rev 1.11 20/3/2003 19:49:24 GGrieve
|
||
Define SmartServeFile
|
||
|
||
Rev 1.10 3/13/2003 10:21:14 AM BGooijen
|
||
Changed result of function .execute
|
||
|
||
Rev 1.9 2/25/2003 10:43:36 AM BGooijen
|
||
removed unneeded assignment
|
||
|
||
Rev 1.8 2/25/2003 10:38:46 AM BGooijen
|
||
The Serversoftware wasn't send to the client, because of duplicate properties
|
||
(.Server and .ServerSoftware).
|
||
|
||
Rev 1.7 2/24/2003 08:20:50 PM JPMugaas
|
||
Now should compile with new code.
|
||
|
||
Rev 1.6 11.2.2003 13:36:14 TPrami
|
||
- Fixed URL get paremeter handling (SeeRFC 1866 section 8.2.1.)
|
||
|
||
Rev 1.5 1/17/2003 05:35:20 PM JPMugaas
|
||
Now compiles with new design.
|
||
|
||
Rev 1.4 1-1-2003 20:12:44 BGooijen
|
||
Changed to support the new TIdContext class
|
||
|
||
Rev 1.3 12-15-2002 13:08:38 BGooijen
|
||
simplified TimeStampInterval
|
||
|
||
Rev 1.2 6/12/2002 10:59:34 AM SGrobety Version: 1.1
|
||
Made to work with Indy 10
|
||
|
||
Rev 1.0 21/11/2002 12:41:04 PM SGrobety Version: Indy 10
|
||
|
||
Rev 1.0 11/14/2002 02:16:32 PM JPMugaas
|
||
}
|
||
|
||
unit IdCustomHTTPServer;
|
||
|
||
interface
|
||
|
||
{$i IdCompilerDefines.inc}
|
||
|
||
uses
|
||
Classes,
|
||
{$IFDEF HAS_UNIT_Generics_Collections}
|
||
System.Generics.Collections,
|
||
{$ENDIF}
|
||
IdAssignedNumbers,
|
||
IdContext, IdException,
|
||
IdGlobal, IdStack,
|
||
IdExceptionCore, IdGlobalProtocols, IdHeaderList, IdCustomTCPServer,
|
||
IdTCPConnection, IdThread, IdCookie, IdHTTPHeaderInfo, IdStackConsts,
|
||
IdBaseComponent, IdThreadSafe,
|
||
SysUtils;
|
||
|
||
type
|
||
// Enums
|
||
THTTPCommandType = (hcUnknown, hcHEAD, hcGET, hcPOST, hcDELETE, hcPUT, hcTRACE, hcOPTION);
|
||
|
||
const
|
||
Id_TId_HTTPServer_KeepAlive = false;
|
||
Id_TId_HTTPServer_ParseParams = True;
|
||
Id_TId_HTTPServer_SessionState = False;
|
||
Id_TId_HTTPSessionTimeOut = 0;
|
||
Id_TId_HTTPAutoStartSession = False;
|
||
|
||
Id_TId_HTTPMaximumHeaderLineCount = 1024;
|
||
|
||
GResponseNo = 200;
|
||
GFContentLength = -1;
|
||
GServerSoftware = gsIdProductName + '/' + gsIdVersion; {Do not Localize}
|
||
GContentType = 'text/html'; {Do not Localize}
|
||
GSessionIDCookie = 'IDHTTPSESSIONID'; {Do not Localize}
|
||
HTTPRequestStrings: array[0..Ord(High(THTTPCommandType))] of string = ('UNKNOWN', 'HEAD','GET','POST','DELETE','PUT','TRACE', 'OPTIONS'); {do not localize}
|
||
|
||
type
|
||
// Forwards
|
||
TIdHTTPSession = class;
|
||
TIdHTTPCustomSessionList = class;
|
||
TIdHTTPRequestInfo = class;
|
||
TIdHTTPResponseInfo = class;
|
||
TIdCustomHTTPServer = class;
|
||
|
||
//events
|
||
TIdHTTPSessionEndEvent = procedure(Sender: TIdHTTPSession) of object;
|
||
TIdHTTPSessionStartEvent = procedure(Sender: TIdHTTPSession) of object;
|
||
TIdHTTPCreateSession = procedure(ASender:TIdContext;
|
||
var VHTTPSession: TIdHTTPSession) of object;
|
||
TIdHTTPCreatePostStream = procedure(AContext: TIdContext; AHeaders: TIdHeaderList; var VPostStream: TStream) of object;
|
||
TIdHTTPDoneWithPostStream = procedure(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; var VCanFree: Boolean) of object;
|
||
TIdHTTPParseAuthenticationEvent = procedure(AContext: TIdContext; const AAuthType, AAuthData: String; var VUsername, VPassword: String; var VHandled: Boolean) of object;
|
||
TIdHTTPCommandEvent = procedure(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo) of object;
|
||
TIdHTTPCommandError = procedure(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo;
|
||
AException: Exception) of object;
|
||
TIdHTTPInvalidSessionEvent = procedure(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo;
|
||
var VContinueProcessing: Boolean; const AInvalidSessionID: String) of object;
|
||
TIdHTTPHeadersAvailableEvent = procedure(AContext: TIdContext; const AUri: string; AHeaders: TIdHeaderList; var VContinueProcessing: Boolean) of object;
|
||
TIdHTTPHeadersBlockedEvent = procedure(AContext: TIdContext; AHeaders: TIdHeaderList; var VResponseNo: Integer; var VResponseText, VContentText: String) of object;
|
||
TIdHTTPHeaderExpectationsEvent = procedure(AContext: TIdContext; const AExpectations: String; var VContinueProcessing: Boolean) of object;
|
||
TIdHTTPQuerySSLPortEvent = procedure(APort: TIdPort; var VUseSSL: Boolean) of object;
|
||
|
||
//objects
|
||
EIdHTTPServerError = class(EIdException);
|
||
EIdHTTPHeaderAlreadyWritten = class(EIdHTTPServerError);
|
||
EIdHTTPErrorParsingCommand = class(EIdHTTPServerError);
|
||
EIdHTTPUnsupportedAuthorisationScheme = class(EIdHTTPServerError);
|
||
EIdHTTPCannotSwitchSessionStateWhenActive = class(EIdHTTPServerError);
|
||
EIdHTTPCannotSwitchSessionIDCookieNameWhenActive = class(EIdHTTPServerError);
|
||
|
||
TIdHTTPRequestInfo = class(TIdRequestHeaderInfo)
|
||
protected
|
||
FAuthExists: Boolean;
|
||
FCookies: TIdCookies;
|
||
FParams: TStrings;
|
||
FPostStream: TStream;
|
||
FRawHTTPCommand: string;
|
||
FRemoteIP: string;
|
||
FSession: TIdHTTPSession;
|
||
FDocument: string;
|
||
FURI: string;
|
||
FCommand: string;
|
||
FVersion: string;
|
||
FVersionMajor: Integer;
|
||
FVersionMinor: Integer;
|
||
FAuthUsername: string;
|
||
FAuthPassword: string;
|
||
FUnparsedParams: string;
|
||
FQueryParams: string;
|
||
FFormParams: string;
|
||
FCommandType: THTTPCommandType;
|
||
//
|
||
procedure DecodeAndSetParams(const AValue: String); virtual;
|
||
public
|
||
constructor Create(AOwner: TPersistent); override;
|
||
destructor Destroy; override;
|
||
//
|
||
function IsVersionAtLeast(const AMajor, AMinor: Integer): Boolean;
|
||
property Session: TIdHTTPSession read FSession;
|
||
//
|
||
property AuthExists: Boolean read FAuthExists;
|
||
property AuthPassword: string read FAuthPassword;
|
||
property AuthUsername: string read FAuthUsername;
|
||
property Command: string read FCommand;
|
||
property CommandType: THTTPCommandType read FCommandType;
|
||
property Cookies: TIdCookies read FCookies;
|
||
property Document: string read FDocument write FDocument; // writable for isapi compatibility. Use with care
|
||
property URI: string read FURI;
|
||
property Params: TStrings read FParams;
|
||
property PostStream: TStream read FPostStream write FPostStream;
|
||
property RawHTTPCommand: string read FRawHTTPCommand;
|
||
property RemoteIP: String read FRemoteIP;
|
||
property UnparsedParams: string read FUnparsedParams write FUnparsedParams; // writable for isapi compatibility. Use with care
|
||
property FormParams: string read FFormParams write FFormParams; // writable for isapi compatibility. Use with care
|
||
property QueryParams: string read FQueryParams write FQueryParams; // writable for isapi compatibility. Use with care
|
||
property Version: string read FVersion;
|
||
property VersionMajor: Integer read FVersionMajor;
|
||
property VersionMinor: Integer read FVersionMinor;
|
||
end;
|
||
|
||
TIdHTTPResponseInfo = class(TIdResponseHeaderInfo)
|
||
protected
|
||
FAuthRealm: string;
|
||
FConnection: TIdTCPConnection;
|
||
FResponseNo: Integer;
|
||
FCookies: TIdCookies;
|
||
FContentStream: TStream;
|
||
FContentText: string;
|
||
FCloseConnection: Boolean;
|
||
FFreeContentStream: Boolean;
|
||
FHeaderHasBeenWritten: Boolean;
|
||
FResponseText: string;
|
||
FHTTPServer: TIdCustomHTTPServer;
|
||
FSession: TIdHTTPSession;
|
||
FRequestInfo: TIdHTTPRequestInfo;
|
||
//
|
||
procedure ReleaseContentStream;
|
||
procedure SetCookies(const AValue: TIdCookies);
|
||
procedure SetHeaders; override;
|
||
procedure SetResponseNo(const AValue: Integer);
|
||
procedure SetCloseConnection(const Value: Boolean);
|
||
public
|
||
function GetServer: string;
|
||
procedure SetServer(const Value: string);
|
||
public
|
||
procedure CloseSession;
|
||
constructor Create(AServer: TIdCustomHTTPServer; ARequestInfo: TIdHTTPRequestInfo; AConnection: TIdTCPConnection); reintroduce;
|
||
destructor Destroy; override;
|
||
procedure Redirect(const AURL: string);
|
||
procedure WriteHeader;
|
||
procedure WriteContent;
|
||
//
|
||
function ServeFile(AContext: TIdContext; const AFile: String): Int64; virtual;
|
||
function SmartServeFile(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo; const AFile: String): Int64;
|
||
//
|
||
property AuthRealm: string read FAuthRealm write FAuthRealm;
|
||
property CloseConnection: Boolean read FCloseConnection write SetCloseConnection;
|
||
property ContentStream: TStream read FContentStream write FContentStream;
|
||
property ContentText: string read FContentText write FContentText;
|
||
property Cookies: TIdCookies read FCookies write SetCookies;
|
||
property FreeContentStream: Boolean read FFreeContentStream write FFreeContentStream;
|
||
// writable for isapi compatibility. Use with care
|
||
property HeaderHasBeenWritten: Boolean read FHeaderHasBeenWritten write FHeaderHasBeenWritten;
|
||
property ResponseNo: Integer read FResponseNo write SetResponseNo;
|
||
property ResponseText: String read FResponseText write FResponseText;
|
||
property HTTPServer: TIdCustomHTTPServer read FHTTPServer;
|
||
property ServerSoftware: string read GetServer write SetServer;
|
||
property Session: TIdHTTPSession read FSession;
|
||
end;
|
||
|
||
TIdHTTPSession = Class(TObject)
|
||
protected
|
||
FContent: TStrings;
|
||
FLastTimeStamp: TDateTime;
|
||
FLock: TIdCriticalSection;
|
||
{$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FOwner: TIdHTTPCustomSessionList;
|
||
FSessionID: string;
|
||
FRemoteHost: string;
|
||
//
|
||
procedure SetContent(const Value: TStrings);
|
||
function IsSessionStale: boolean; virtual;
|
||
procedure DoSessionEnd; virtual;
|
||
public
|
||
constructor Create(AOwner: TIdHTTPCustomSessionList); virtual;
|
||
constructor CreateInitialized(AOwner: TIdHTTPCustomSessionList; const SessionID,
|
||
RemoteIP: string); virtual;
|
||
destructor Destroy; override;
|
||
procedure Lock;
|
||
procedure Unlock;
|
||
//
|
||
property Content: TStrings read FContent write SetContent;
|
||
property LastTimeStamp: TDateTime read FLastTimeStamp;
|
||
property RemoteHost: string read FRemoteHost;
|
||
property SessionID: String read FSessionID;
|
||
end;
|
||
|
||
{$IFDEF HAS_GENERICS_TThreadList}
|
||
TIdHTTPSessionThreadList = TThreadList<TIdHTTPSession>;
|
||
TIdHTTPSessionList = TList<TIdHTTPSession>;
|
||
{$ELSE}
|
||
// TODO: flesh out to match TThreadList<TIdHTTPSession> and TList<TIdHTTPSession> for non-Generics compilers
|
||
TIdHTTPSessionThreadList = TThreadList;
|
||
TIdHTTPSessionList = TList;
|
||
{$ENDIF}
|
||
|
||
TIdHTTPCustomSessionList = class(TIdBaseComponent)
|
||
private
|
||
FSessionTimeout: Integer;
|
||
FOnSessionEnd: TIdHTTPSessionEndEvent;
|
||
FOnSessionStart: TIdHTTPSessionStartEvent;
|
||
protected
|
||
// remove a session from the session list. Called by the session on "Free"
|
||
procedure RemoveSession(Session: TIdHTTPSession); virtual; abstract;
|
||
public
|
||
procedure Clear; virtual; abstract;
|
||
procedure PurgeStaleSessions(PurgeAll: Boolean = false); virtual; abstract;
|
||
function CreateUniqueSession(const RemoteIP: String): TIdHTTPSession; virtual; abstract;
|
||
function CreateSession(const RemoteIP, SessionID: String): TIdHTTPSession; virtual; abstract;
|
||
function GetSession(const SessionID, RemoteIP: string): TIdHTTPSession; virtual; abstract;
|
||
procedure Add(ASession: TIdHTTPSession); virtual; Abstract;
|
||
published
|
||
property SessionTimeout: Integer read FSessionTimeout write FSessionTimeout;
|
||
property OnSessionEnd: TIdHTTPSessionEndEvent read FOnSessionEnd write FOnSessionEnd;
|
||
property OnSessionStart: TIdHTTPSessionStartEvent read FOnSessionStart write FOnSessionStart;
|
||
end;
|
||
|
||
TIdThreadSafeMimeTable = class(TIdThreadSafe)
|
||
protected
|
||
FTable: TIdMimeTable;
|
||
function GetLoadTypesFromOS: Boolean;
|
||
procedure SetLoadTypesFromOS(AValue: Boolean);
|
||
function GetOnBuildCache: TNotifyEvent;
|
||
procedure SetOnBuildCache(AValue: TNotifyEvent);
|
||
public
|
||
constructor Create(const AutoFill: Boolean = True); reintroduce;
|
||
destructor Destroy; override;
|
||
procedure BuildCache;
|
||
procedure AddMimeType(const Ext, MIMEType: string; const ARaiseOnError: Boolean = True);
|
||
function GetFileMIMEType(const AFileName: string): string;
|
||
function GetDefaultFileExt(const MIMEType: string): string;
|
||
procedure LoadFromStrings(const AStrings: TStrings; const MimeSeparator: Char = '='); {Do not Localize}
|
||
procedure SaveToStrings(const AStrings: TStrings; const MimeSeparator: Char = '='); {Do not Localize}
|
||
function Lock: TIdMimeTable; reintroduce;
|
||
procedure Unlock; reintroduce;
|
||
//
|
||
property LoadTypesFromOS: Boolean read GetLoadTypesFromOS write SetLoadTypesFromOS;
|
||
property OnBuildCache: TNotifyEvent read GetOnBuildCache write SetOnBuildCache;
|
||
end;
|
||
|
||
TIdCustomHTTPServer = class(TIdCustomTCPServer)
|
||
protected
|
||
FAutoStartSession: Boolean;
|
||
FKeepAlive: Boolean;
|
||
FParseParams: Boolean;
|
||
FServerSoftware: string;
|
||
FMIMETable: TIdThreadSafeMimeTable;
|
||
{$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FSessionList: TIdHTTPCustomSessionList;
|
||
FImplicitSessionList: Boolean;
|
||
FSessionState: Boolean;
|
||
FSessionTimeOut: Integer;
|
||
//
|
||
FOnCreatePostStream: TIdHTTPCreatePostStream;
|
||
FOnDoneWithPostStream: TIdHTTPDoneWithPostStream;
|
||
FOnCreateSession: TIdHTTPCreateSession;
|
||
FOnInvalidSession: TIdHTTPInvalidSessionEvent;
|
||
FOnParseAuthentication: TIdHTTPParseAuthenticationEvent;
|
||
FOnSessionEnd: TIdHTTPSessionEndEvent;
|
||
FOnSessionStart: TIdHTTPSessionStartEvent;
|
||
FOnCommandGet: TIdHTTPCommandEvent;
|
||
FOnCommandOther: TIdHTTPCommandEvent;
|
||
FOnCommandError: TIdHTTPCommandError;
|
||
FOnHeadersAvailable: TIdHTTPHeadersAvailableEvent;
|
||
FOnHeadersBlocked: TIdHTTPHeadersBlockedEvent;
|
||
FOnHeaderExpectations: TIdHTTPHeaderExpectationsEvent;
|
||
FOnQuerySSLPort: TIdHTTPQuerySSLPortEvent;
|
||
//
|
||
FSessionCleanupThread: TIdThread;
|
||
FMaximumHeaderLineCount: Integer;
|
||
FSessionIDCookieName: string;
|
||
//
|
||
procedure CreatePostStream(ASender: TIdContext; AHeaders: TIdHeaderList; var VPostStream: TStream); virtual;
|
||
procedure DoneWithPostStream(ASender: TIdContext; ARequestInfo: TIdHTTPRequestInfo); virtual;
|
||
procedure DoOnCreateSession(AContext: TIdContext; var VNewSession: TIdHTTPSession); virtual;
|
||
procedure DoInvalidSession(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo;
|
||
var VContinueProcessing: Boolean; const AInvalidSessionID: String); virtual;
|
||
procedure DoCommandGet(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo;
|
||
AResponseInfo: TIdHTTPResponseInfo); virtual;
|
||
procedure DoCommandOther(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo;
|
||
AResponseInfo: TIdHTTPResponseInfo); virtual;
|
||
procedure DoCommandError(AContext: TIdContext; ARequestInfo: TIdHTTPRequestInfo;
|
||
AResponseInfo: TIdHTTPResponseInfo; AException: Exception); virtual;
|
||
procedure DoConnect(AContext: TIdContext); override;
|
||
function DoHeadersAvailable(ASender: TIdContext; const AUri: String; AHeaders: TIdHeaderList): Boolean; virtual;
|
||
procedure DoHeadersBlocked(ASender: TIdContext; AHeaders: TIdHeaderList; var VResponseNo: Integer; var VResponseText, VContentText: String); virtual;
|
||
function DoHeaderExpectations(ASender: TIdContext; const AExpectations: String): Boolean; virtual;
|
||
function DoParseAuthentication(ASender: TIdContext; const AAuthType, AAuthData: String; var VUsername, VPassword: String): Boolean;
|
||
function DoQuerySSLPort(APort: TIdPort): Boolean; virtual;
|
||
procedure DoSessionEnd(Sender: TIdHTTPSession); virtual;
|
||
procedure DoSessionStart(Sender: TIdHTTPSession); virtual;
|
||
//
|
||
function DoExecute(AContext:TIdContext): Boolean; override;
|
||
//
|
||
procedure Startup; override;
|
||
procedure Shutdown; override;
|
||
procedure SetSessionList(const AValue: TIdHTTPCustomSessionList);
|
||
procedure SetSessionState(const Value: Boolean);
|
||
procedure SetSessionIDCookieName(const AValue: string);
|
||
function IsSessionIDCookieNameStored: Boolean;
|
||
function GetSessionFromCookie(AContext:TIdContext;
|
||
AHTTPrequest: TIdHTTPRequestInfo; AHTTPResponse: TIdHTTPResponseInfo;
|
||
var VContinueProcessing: Boolean): TIdHTTPSession;
|
||
procedure InitComponent; override;
|
||
procedure Notification(AComponent: TComponent; Operation: TOperation); override;
|
||
{ to be published in TIdHTTPServer}
|
||
property OnCreatePostStream: TIdHTTPCreatePostStream read FOnCreatePostStream write FOnCreatePostStream;
|
||
property OnDoneWithPostStream: TIdHTTPDoneWithPostStream read FOnDoneWithPostStream write FOnDoneWithPostStream;
|
||
property OnCommandGet: TIdHTTPCommandEvent read FOnCommandGet write FOnCommandGet;
|
||
public
|
||
function CreateSession(AContext:TIdContext;
|
||
HTTPResponse: TIdHTTPResponseInfo;
|
||
HTTPRequest: TIdHTTPRequestInfo): TIdHTTPSession;
|
||
destructor Destroy; override;
|
||
function EndSession(const SessionName: String; const RemoteIP: String = ''): Boolean;
|
||
//
|
||
property MIMETable: TIdThreadSafeMimeTable read FMIMETable;
|
||
property SessionList: TIdHTTPCustomSessionList read FSessionList write SetSessionList;
|
||
published
|
||
property AutoStartSession: boolean read FAutoStartSession write FAutoStartSession default Id_TId_HTTPAutoStartSession;
|
||
property DefaultPort default IdPORT_HTTP;
|
||
property KeepAlive: Boolean read FKeepAlive write FKeepAlive default Id_TId_HTTPServer_KeepAlive;
|
||
property MaximumHeaderLineCount: Integer read FMaximumHeaderLineCount write FMaximumHeaderLineCount default Id_TId_HTTPMaximumHeaderLineCount;
|
||
property ParseParams: boolean read FParseParams write FParseParams default Id_TId_HTTPServer_ParseParams;
|
||
property ServerSoftware: string read FServerSoftware write FServerSoftware;
|
||
property SessionState: Boolean read FSessionState write SetSessionState default Id_TId_HTTPServer_SessionState;
|
||
property SessionTimeOut: Integer read FSessionTimeOut write FSessionTimeOut default Id_TId_HTTPSessionTimeOut;
|
||
property SessionIDCookieName: string read FSessionIDCookieName write SetSessionIDCookieName stored IsSessionIDCookieNameStored;
|
||
//
|
||
property OnCommandError: TIdHTTPCommandError read FOnCommandError write FOnCommandError;
|
||
property OnCommandOther: TIdHTTPCommandEvent read FOnCommandOther write FOnCommandOther;
|
||
property OnCreateSession: TIdHTTPCreateSession read FOnCreateSession write FOnCreateSession;
|
||
property OnInvalidSession: TIdHTTPInvalidSessionEvent read FOnInvalidSession write FOnInvalidSession;
|
||
property OnHeadersAvailable: TIdHTTPHeadersAvailableEvent read FOnHeadersAvailable write FOnHeadersAvailable;
|
||
property OnHeadersBlocked: TIdHTTPHeadersBlockedEvent read FOnHeadersBlocked write FOnHeadersBlocked;
|
||
property OnHeaderExpectations: TIdHTTPHeaderExpectationsEvent read FOnHeaderExpectations write FOnHeaderExpectations;
|
||
property OnParseAuthentication: TIdHTTPParseAuthenticationEvent read FOnParseAuthentication write FOnParseAuthentication;
|
||
property OnQuerySSLPort: TIdHTTPQuerySSLPortEvent read FOnQuerySSLPort write FOnQuerySSLPort;
|
||
property OnSessionStart: TIdHTTPSessionStartEvent read FOnSessionStart write FOnSessionStart;
|
||
property OnSessionEnd: TIdHTTPSessionEndEvent read FOnSessionEnd write FOnSessionEnd;
|
||
end;
|
||
|
||
TIdHTTPDefaultSessionList = Class(TIdHTTPCustomSessionList)
|
||
protected
|
||
FSessionList: TIdHTTPSessionThreadList;
|
||
procedure RemoveSession(Session: TIdHTTPSession); override;
|
||
// remove a session surgically when list already locked down (prevent deadlock)
|
||
procedure RemoveSessionFromLockedList(AIndex: Integer; ALockedSessionList: TIdHTTPSessionList);
|
||
protected
|
||
procedure InitComponent; override;
|
||
public
|
||
destructor Destroy; override;
|
||
property SessionList: TIdHTTPSessionThreadList read FSessionList;
|
||
procedure Clear; override;
|
||
procedure Add(ASession: TIdHTTPSession); override;
|
||
procedure PurgeStaleSessions(PurgeAll: Boolean = false); override;
|
||
function CreateUniqueSession(const RemoteIP: String): TIdHTTPSession; override;
|
||
function CreateSession(const RemoteIP, SessionID: String): TIdHTTPSession; override;
|
||
function GetSession(const SessionID, RemoteIP: string): TIdHTTPSession; override;
|
||
end;
|
||
|
||
TIdHTTPRangeStream = class(TIdBaseStream)
|
||
private
|
||
FSourceStream: TStream;
|
||
FOwnsSource: Boolean;
|
||
FRangeStart, FRangeEnd: Int64;
|
||
FResponseCode: Integer;
|
||
protected
|
||
function IdRead(var VBuffer: TIdBytes; AOffset, ACount: Longint): Longint; override;
|
||
function IdWrite(const ABuffer: TIdBytes; AOffset, ACount: Longint): Longint; override;
|
||
function IdSeek(const AOffset: Int64; AOrigin: TSeekOrigin): Int64; override;
|
||
procedure IdSetSize(ASize: Int64); override;
|
||
public
|
||
constructor Create(ASource: TStream; ARangeStart, ARangeEnd: Int64; AOwnsSource: Boolean = True);
|
||
destructor Destroy; override;
|
||
property ResponseCode: Integer read FResponseCode;
|
||
property RangeStart: Int64 read FRangeStart;
|
||
property RangeEnd: Int64 read FRangeEnd;
|
||
property SourceStream: TStream read FSourceStream;
|
||
end;
|
||
|
||
implementation
|
||
|
||
uses
|
||
{$IFDEF VCL_XE3_OR_ABOVE}
|
||
System.SyncObjs,
|
||
{$ENDIF}
|
||
{$IFDEF KYLIXCOMPAT}
|
||
Libc,
|
||
{$ENDIF}
|
||
{$IFDEF USE_VCL_POSIX}
|
||
Posix.SysSelect,
|
||
Posix.SysTime,
|
||
{$ENDIF}
|
||
{$IFDEF DOTNET}
|
||
{$IFDEF USE_INLINE}
|
||
System.IO,
|
||
System.Threading,
|
||
{$ENDIF}
|
||
{$IFDEF WINDOWS}
|
||
Windows,
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
{$IFDEF VCL_2010_OR_ABOVE}
|
||
{$IFDEF WINDOWS}
|
||
Windows,
|
||
{$ENDIF}
|
||
{$ENDIF}
|
||
IdCoderMIME, IdResourceStringsProtocols, IdURI, IdIOHandler, IdIOHandlerSocket,
|
||
IdSSL, IdResourceStringsCore, IdStream;
|
||
|
||
const
|
||
SessionCapacity = 128;
|
||
ContentTypeFormUrlencoded = 'application/x-www-form-urlencoded'; {Do not Localize}
|
||
|
||
// Calculate the number of MS between two TimeStamps
|
||
|
||
function TimeStampInterval(const AStartStamp, AEndStamp: TDateTime): integer;
|
||
begin
|
||
Result := Trunc((AEndStamp - AStartStamp) * MSecsPerDay);
|
||
end;
|
||
|
||
{ //(Bas Gooijen) was:
|
||
function TimeStampInterval(StartStamp, EndStamp: TDateTime): integer;
|
||
var
|
||
days: Integer;
|
||
hour, min, s, ms: Word;
|
||
begin
|
||
days := Trunc(EndStamp - StartStamp); // whole days
|
||
DecodeTime(EndStamp - StartStamp, hour, min, s, ms);
|
||
Result := (((days * 24 + hour) * 60 + min) * 60 + s) * 1000 + ms;
|
||
end;
|
||
}
|
||
|
||
|
||
function GetRandomString(NumChar: UInt32): string;
|
||
const
|
||
CharMap = 'qwertzuiopasdfghjklyxcvbnmQWERTZUIOPASDFGHJKLYXCVBNM1234567890'; {Do not Localize}
|
||
MaxChar: UInt32 = Length(CharMap) - 1;
|
||
var
|
||
i: integer;
|
||
{$IFDEF STRING_IS_IMMUTABLE}
|
||
LSB: TIdStringBuilder;
|
||
{$ENDIF}
|
||
begin
|
||
randomize;
|
||
{$IFDEF STRING_IS_IMMUTABLE}
|
||
LSB := TIdStringBuilder.Create(NumChar);
|
||
{$ELSE}
|
||
SetLength(Result, NumChar);
|
||
{$ENDIF}
|
||
for i := 1 to NumChar do
|
||
begin
|
||
// Add one because CharMap is 1-based
|
||
{$IFDEF STRING_IS_IMMUTABLE}
|
||
LSB.Append(CharMap[Random(MaxChar) + 1]);
|
||
{$ELSE}
|
||
Result[i] := CharMap[Random(MaxChar) + 1];
|
||
{$ENDIF}
|
||
end;
|
||
{$IFDEF STRING_IS_IMMUTABLE}
|
||
Result := LSB.ToString;
|
||
{$ENDIF}
|
||
end;
|
||
|
||
function DecodeHTTPCommand(const ACmd: string): THTTPCommandType;
|
||
var
|
||
I: Integer;
|
||
begin
|
||
Result := hcUnknown;
|
||
for I := Low(HTTPRequestStrings) to High(HTTPRequestStrings) do begin
|
||
if TextIsSame(ACmd, HTTPRequestStrings[i]) then begin
|
||
Result := THTTPCommandType(i);
|
||
Exit;
|
||
end;
|
||
end; // for
|
||
end;
|
||
|
||
type
|
||
TIdHTTPSessionCleanerThread = Class(TIdThread)
|
||
protected
|
||
{$IFDEF USE_OBJECT_ARC}[Weak]{$ENDIF} FSessionList: TIdHTTPCustomSessionList;
|
||
public
|
||
constructor Create(SessionList: TIdHTTPCustomSessionList); reintroduce;
|
||
procedure AfterRun; override;
|
||
procedure Run; override;
|
||
end; // class
|
||
|
||
function InternalReadLn(AIOHandler: TIdIOHandler): String;
|
||
begin
|
||
Result := AIOHandler.ReadLn;
|
||
if AIOHandler.ReadLnTimedout then begin
|
||
raise EIdReadTimeout.Create(RSReadTimeout);
|
||
end;
|
||
end;
|
||
|
||
{ TIdThreadSafeMimeTable }
|
||
|
||
constructor TIdThreadSafeMimeTable.Create(const AutoFill: Boolean = True);
|
||
begin
|
||
inherited Create;
|
||
FTable := TIdMimeTable.Create(AutoFill);
|
||
end;
|
||
|
||
destructor TIdThreadSafeMimeTable.Destroy;
|
||
begin
|
||
inherited Lock;
|
||
try
|
||
FreeAndNil(FTable);
|
||
finally
|
||
inherited Unlock;
|
||
end;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TIdThreadSafeMimeTable.GetLoadTypesFromOS: Boolean;
|
||
begin
|
||
Lock;
|
||
try
|
||
Result := FTable.LoadTypesFromOS;
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.SetLoadTypesFromOS(AValue: Boolean);
|
||
begin
|
||
Lock;
|
||
try
|
||
FTable.LoadTypesFromOS := AValue;
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
function TIdThreadSafeMimeTable.GetOnBuildCache: TNotifyEvent;
|
||
begin
|
||
Lock;
|
||
try
|
||
Result := FTable.OnBuildCache;
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.SetOnBuildCache(AValue: TNotifyEvent);
|
||
begin
|
||
Lock;
|
||
try
|
||
FTable.OnBuildCache := AValue;
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.BuildCache;
|
||
begin
|
||
Lock;
|
||
try
|
||
FTable.BuildCache;
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.AddMimeType(const Ext, MIMEType: string; const ARaiseOnError: Boolean = True);
|
||
begin
|
||
Lock;
|
||
try
|
||
FTable.AddMimeType(Ext, MIMEType, ARaiseOnError);
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
function TIdThreadSafeMimeTable.GetFileMIMEType(const AFileName: string): string;
|
||
begin
|
||
Lock;
|
||
try
|
||
Result := FTable.GetFileMIMEType(AFileName);
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
function TIdThreadSafeMimeTable.GetDefaultFileExt(const MIMEType: string): string;
|
||
begin
|
||
Lock;
|
||
try
|
||
Result := FTable.GetDefaultFileExt(MIMEType);
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.LoadFromStrings(const AStrings: TStrings; const MimeSeparator: Char = '='); {Do not Localize}
|
||
begin
|
||
Lock;
|
||
try
|
||
FTable.LoadFromStrings(AStrings, MimeSeparator);
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.SaveToStrings(const AStrings: TStrings; const MimeSeparator: Char = '='); {Do not Localize}
|
||
begin
|
||
Lock;
|
||
try
|
||
FTable.SaveToStrings(AStrings, MimeSeparator);
|
||
finally
|
||
Unlock;
|
||
end;
|
||
end;
|
||
|
||
function TIdThreadSafeMimeTable.Lock: TIdMimeTable;
|
||
begin
|
||
inherited Lock;
|
||
Result := FTable;
|
||
end;
|
||
|
||
procedure TIdThreadSafeMimeTable.Unlock;
|
||
begin
|
||
inherited Unlock;
|
||
end;
|
||
|
||
{ TIdHTTPRangeStream }
|
||
|
||
constructor TIdHTTPRangeStream.Create(ASource: TStream; ARangeStart, ARangeEnd: Int64;
|
||
AOwnsSource: Boolean = True);
|
||
var
|
||
LSize: Int64;
|
||
begin
|
||
inherited Create;
|
||
FSourceStream := ASource;
|
||
FOwnsSource := AOwnsSource;
|
||
FResponseCode := 200;
|
||
if (ARangeStart > -1) or (ARangeEnd > -1) then begin
|
||
LSize := ASource.Size;
|
||
if ARangeStart > -1 then begin
|
||
// requesting prefix range from BOF
|
||
if ARangeStart >= LSize then begin
|
||
// range unsatisfiable
|
||
FResponseCode := 416;
|
||
Exit;
|
||
end;
|
||
if ARangeEnd > -1 then begin
|
||
if ARangeEnd < ARangeStart then begin
|
||
// invalid syntax
|
||
Exit;
|
||
end;
|
||
ARangeEnd := IndyMin(ARangeEnd, LSize-1);
|
||
end else begin
|
||
ARangeEnd := LSize-1;
|
||
end;
|
||
end else begin
|
||
// requesting suffix range from EOF
|
||
if ARangeEnd = 0 then begin
|
||
// range unsatisfiable
|
||
FResponseCode := 416;
|
||
Exit;
|
||
end;
|
||
ARangeStart := IndyMax(LSize - ARangeEnd, 0);
|
||
ARangeEnd := LSize-1;
|
||
end;
|
||
FResponseCode := 206;
|
||
FRangeStart := ARangeStart;
|
||
FRangeEnd := ARangeEnd;
|
||
end;
|
||
end;
|
||
|
||
destructor TIdHTTPRangeStream.Destroy;
|
||
begin
|
||
if FOwnsSource then begin
|
||
FreeAndNil(FSourceStream);
|
||
end;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TIdHTTPRangeStream.IdRead(var VBuffer: TIdBytes; AOffset, ACount: Longint): Longint;
|
||
begin
|
||
if FResponseCode = 206 then begin
|
||
ACount := Longint(IndyMin(Int64(ACount), (FRangeEnd+1) - FSourceStream.Position));
|
||
end;
|
||
Result := TIdStreamHelper.ReadBytes(FSourceStream, VBuffer, ACount, AOffset);
|
||
end;
|
||
|
||
function TIdHTTPRangeStream.IdSeek(const AOffset: Int64; AOrigin: TSeekOrigin): Int64;
|
||
var
|
||
LOffset: Int64;
|
||
begin
|
||
if FResponseCode = 206 then begin
|
||
case AOrigin of
|
||
soBeginning: LOffset := FRangeStart + AOffset;
|
||
soCurrent: LOffset := FSourceStream.Position + AOffset;
|
||
soEnd: LOffset := (FRangeEnd+1) + AOffset;
|
||
else
|
||
// TODO: move this into IdResourceStringsProtocols.pas
|
||
raise EIdException.Create('Unknown Seek Origin'); {do not localize}
|
||
end;
|
||
LOffset := IndyMax(LOffset, FRangeStart);
|
||
LOffset := IndyMin(LOffset, FRangeEnd+1);
|
||
Result := TIdStreamHelper.Seek(FSourceStream, LOffset, soBeginning) - FRangeStart;
|
||
end else begin
|
||
Result := TIdStreamHelper.Seek(FSourceStream, AOffset, AOrigin);
|
||
end;
|
||
end;
|
||
|
||
function TIdHTTPRangeStream.IdWrite(const ABuffer: TIdBytes; AOffset, ACount: Longint): Longint;
|
||
begin
|
||
Result := 0;
|
||
end;
|
||
|
||
procedure TIdHTTPRangeStream.IdSetSize(ASize: Int64);
|
||
begin
|
||
end;
|
||
|
||
{ TIdCustomHTTPServer }
|
||
|
||
procedure TIdCustomHTTPServer.InitComponent;
|
||
begin
|
||
inherited InitComponent;
|
||
FSessionState := Id_TId_HTTPServer_SessionState;
|
||
DefaultPort := IdPORT_HTTP;
|
||
ParseParams := Id_TId_HTTPServer_ParseParams;
|
||
FMIMETable := TIdThreadSafeMimeTable.Create(False);
|
||
FSessionTimeOut := Id_TId_HTTPSessionTimeOut;
|
||
FAutoStartSession := Id_TId_HTTPAutoStartSession;
|
||
FKeepAlive := Id_TId_HTTPServer_KeepAlive;
|
||
FMaximumHeaderLineCount := Id_TId_HTTPMaximumHeaderLineCount;
|
||
FSessionIDCookieName := GSessionIDCookie;
|
||
end;
|
||
|
||
// under ARC, all weak references to a freed object get nil'ed automatically
|
||
// so this is mostly redundant
|
||
procedure TIdCustomHTTPServer.Notification(AComponent: TComponent; Operation: TOperation);
|
||
begin
|
||
if (Operation = opRemove) and (AComponent = FSessionList) then begin
|
||
FSessionList := nil;
|
||
FImplicitSessionList := False;
|
||
end;
|
||
inherited Notification(AComponent, Operation);
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.DoParseAuthentication(ASender: TIdContext;
|
||
const AAuthType, AAuthData: String; var VUsername, VPassword: String): Boolean;
|
||
var
|
||
s: String;
|
||
LDecoder: TIdDecoderMIME;
|
||
begin
|
||
Result := False;
|
||
if Assigned(FOnParseAuthentication) then begin
|
||
FOnParseAuthentication(ASender, AAuthType, AAuthData, VUsername, VPassword, Result);
|
||
end;
|
||
if (not Result) and TextIsSame(AAuthType, 'Basic') then begin {Do not Localize}
|
||
LDecoder := TIdDecoderMIME.Create;
|
||
try
|
||
s := LDecoder.DecodeString(AAuthData);
|
||
finally
|
||
LDecoder.Free;
|
||
end;
|
||
VUsername := Fetch(s, ':'); {Do not Localize}
|
||
VPassword := s;
|
||
Result := True;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoOnCreateSession(AContext: TIdContext; Var VNewSession: TIdHTTPSession);
|
||
begin
|
||
VNewSession := nil;
|
||
if Assigned(FOnCreateSession) then
|
||
begin
|
||
OnCreateSession(AContext, VNewSession);
|
||
end;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.CreateSession(AContext: TIdContext; HTTPResponse: TIdHTTPResponseInfo;
|
||
HTTPRequest: TIdHTTPRequestInfo): TIdHTTPSession;
|
||
var
|
||
LCookie: TIdCookie;
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
Result := nil;
|
||
if SessionState then begin
|
||
LSessionList := FSessionList;
|
||
if Assigned(LSessionList) then begin
|
||
DoOnCreateSession(AContext, Result);
|
||
if not Assigned(Result) then begin
|
||
Result := LSessionList.CreateUniqueSession(HTTPRequest.RemoteIP);
|
||
end else begin
|
||
LSessionList.Add(Result);
|
||
end;
|
||
|
||
LCookie := HTTPResponse.Cookies.Add;
|
||
LCookie.CookieName := SessionIDCookieName;
|
||
LCookie.Value := Result.SessionID;
|
||
LCookie.Path := '/'; {Do not Localize}
|
||
|
||
// By default the cookie will be valid until the user has closed his browser window.
|
||
// MaxAge := SessionTimeOut div 1000;
|
||
HTTPResponse.FSession := Result;
|
||
HTTPRequest.FSession := Result;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
destructor TIdCustomHTTPServer.Destroy;
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
Active := False; // Set Active to false in order to close all active sessions.
|
||
FreeAndNil(FMIMETable);
|
||
LSessionList := FSessionList;
|
||
if Assigned(LSessionList) and FImplicitSessionList then begin
|
||
FSessionList := nil;
|
||
FImplicitSessionList := False;
|
||
IdDisposeAndNil(LSessionList);
|
||
end;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoCommandGet(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
|
||
begin
|
||
if Assigned(FOnCommandGet) then begin
|
||
FOnCommandGet(AContext, ARequestInfo, AResponseInfo);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoCommandOther(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo);
|
||
begin
|
||
if Assigned(FOnCommandOther) then begin
|
||
FOnCommandOther(AContext, ARequestInfo, AResponseInfo);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoCommandError(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo;
|
||
AException: Exception);
|
||
begin
|
||
if Assigned(FOnCommandError) then begin
|
||
FOnCommandError(AContext, ARequestInfo, AResponseInfo, AException);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoConnect(AContext: TIdContext);
|
||
begin
|
||
// RLebeau 6/17/08: let the user decide whether to enable SSL in their
|
||
// own event handler. Indy should not be making any assumptions about
|
||
// whether to implicitally force SSL on any given connection. This
|
||
// prevents a single server from handling both SSL and non-SSL connections
|
||
// together. The whole point of the PassThrough property is to allow
|
||
// per-connection SSL handling.
|
||
//
|
||
// TODO: move this new logic into TIdCustomTCPServer directly somehow
|
||
|
||
if AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase then begin
|
||
TIdSSLIOHandlerSocketBase(AContext.Connection.IOHandler).PassThrough :=
|
||
not DoQuerySSLPort(AContext.Connection.Socket.Binding.Port);
|
||
end;
|
||
inherited DoConnect(AContext);
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.DoQuerySSLPort(APort: TIdPort): Boolean;
|
||
begin
|
||
Result := not Assigned(FOnQuerySSLPort);
|
||
if not Result then begin
|
||
FOnQuerySSLPort(APort, Result);
|
||
end;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.DoHeadersAvailable(ASender: TIdContext; const AUri: String;
|
||
AHeaders: TIdHeaderList): Boolean;
|
||
begin
|
||
Result := True;
|
||
if Assigned(OnHeadersAvailable) then begin
|
||
OnHeadersAvailable(ASender, AUri, AHeaders, Result);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoHeadersBlocked(ASender: TIdContext; AHeaders: TIdHeaderList;
|
||
var VResponseNo: Integer; var VResponseText, VContentText: String);
|
||
begin
|
||
VResponseNo := 403;
|
||
VResponseText := '';
|
||
VContentText := '';
|
||
if Assigned(OnHeadersBlocked) then begin
|
||
OnHeadersBlocked(ASender, AHeaders, VResponseNo, VResponseText, VContentText);
|
||
end;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.DoHeaderExpectations(ASender: TIdContext; const AExpectations: String): Boolean;
|
||
begin
|
||
Result := TextIsSame(AExpectations, '100-continue'); {Do not Localize}
|
||
if Assigned(OnHeaderExpectations) then begin
|
||
OnHeaderExpectations(ASender, AExpectations, Result);
|
||
end;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.DoExecute(AContext:TIdContext): boolean;
|
||
var
|
||
LRequestInfo: TIdHTTPRequestInfo;
|
||
LResponseInfo: TIdHTTPResponseInfo;
|
||
|
||
procedure ReadCookiesFromRequestHeader;
|
||
var
|
||
LRawCookies: TStringList;
|
||
begin
|
||
LRawCookies := TStringList.Create;
|
||
try
|
||
LRequestInfo.RawHeaders.Extract('Cookie', LRawCookies); {Do not Localize}
|
||
LRequestInfo.Cookies.AddClientCookies(LRawCookies);
|
||
finally
|
||
FreeAndNil(LRawCookies);
|
||
end;
|
||
end;
|
||
|
||
function GetRemoteIP(ASocket: TIdIOHandlerSocket): String;
|
||
begin
|
||
Result := '';
|
||
if ASocket <> nil then begin
|
||
if ASocket.Binding <> nil then begin
|
||
Result := ASocket.Binding.PeerIP;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
function HeadersCanContinue: Boolean;
|
||
var
|
||
LResponseNo: Integer;
|
||
LResponseText, LContentText, S: String;
|
||
begin
|
||
// let the user decide if the request headers are acceptable
|
||
Result := DoHeadersAvailable(AContext, LRequestInfo.URI, LRequestInfo.RawHeaders);
|
||
if not Result then begin
|
||
DoHeadersBlocked(AContext, LRequestInfo.RawHeaders, LResponseNo, LResponseText, LContentText);
|
||
LResponseInfo.ResponseNo := LResponseNo;
|
||
if Length(LResponseText) > 0 then begin
|
||
LResponseInfo.ResponseText := LResponseText;
|
||
end;
|
||
LResponseInfo.ContentText := LContentText;
|
||
LResponseInfo.CloseConnection := True;
|
||
LResponseInfo.WriteHeader;
|
||
if Length(LContentText) > 0 then begin
|
||
LResponseInfo.WriteContent;
|
||
end;
|
||
Exit;
|
||
end;
|
||
|
||
// check for HTTP v1.1 'Host' and 'Expect' headers...
|
||
|
||
if not LRequestInfo.IsVersionAtLeast(1, 1) then begin
|
||
Exit;
|
||
end;
|
||
|
||
// MUST report a 400 (Bad Request) error if an HTTP/1.1
|
||
// request does not include a 'Host' header
|
||
S := LRequestInfo.RawHeaders.Values['Host'];
|
||
if Length(S) = 0 then begin
|
||
LResponseInfo.ResponseNo := 400;
|
||
LResponseInfo.CloseConnection := True;
|
||
LResponseInfo.WriteHeader;
|
||
Exit;
|
||
end;
|
||
|
||
// if the client has already sent some or all of the request
|
||
// body then don't bother checking for a v1.1 'Expect' header
|
||
if not AContext.Connection.IOHandler.InputBufferIsEmpty then begin
|
||
Exit;
|
||
end;
|
||
|
||
S := LRequestInfo.RawHeaders.Values['Expect'];
|
||
if Length(S) = 0 then begin
|
||
Exit;
|
||
end;
|
||
|
||
// check if the client expectations can be satisfied...
|
||
Result := DoHeaderExpectations(AContext, S);
|
||
if not Result then begin
|
||
LResponseInfo.ResponseNo := 417;
|
||
LResponseInfo.CloseConnection := True;
|
||
LResponseInfo.WriteHeader;
|
||
Exit;
|
||
end;
|
||
|
||
if Pos('100-continue', LowerCase(S)) > 0 then begin {Do not Localize}
|
||
// the client requested a '100-continue' expectation so send
|
||
// a '100 Continue' reply now before the request body can be read
|
||
AContext.Connection.IOHandler.WriteLn(LRequestInfo.Version + ' 100 ' + RSHTTPContinue + EOL); {Do not Localize}
|
||
end;
|
||
end;
|
||
|
||
function PreparePostStream: Boolean;
|
||
var
|
||
I, Size: Integer;
|
||
S: String;
|
||
LIOHandler: TIdIOHandler;
|
||
begin
|
||
Result := False;
|
||
LIOHandler := AContext.Connection.IOHandler;
|
||
|
||
// RLebeau 1/6/2009: don't create the PostStream unless there is
|
||
// actually something to read. This should make it easier for the
|
||
// request handler to know when to use the PostStream and when to
|
||
// use the (Unparsed)Params instead...
|
||
|
||
if (LRequestInfo.TransferEncoding <> '') and
|
||
(not TextIsSame(LRequestInfo.TransferEncoding, 'identity')) then {do not localize}
|
||
begin
|
||
if IndyPos('chunked', LowerCase(LRequestInfo.TransferEncoding)) = 0 then begin {do not localize}
|
||
LResponseInfo.ResponseNo := 400; // bad request
|
||
LResponseInfo.CloseConnection := True;
|
||
LResponseInfo.WriteHeader;
|
||
Exit;
|
||
end;
|
||
CreatePostStream(AContext, LRequestInfo.RawHeaders, LRequestInfo.FPostStream);
|
||
if LRequestInfo.FPostStream = nil then begin
|
||
LRequestInfo.FPostStream := TMemoryStream.Create;
|
||
end;
|
||
LRequestInfo.PostStream.Position := 0;
|
||
repeat
|
||
S := InternalReadLn(LIOHandler);
|
||
I := IndyPos(';', S); {do not localize}
|
||
if I > 0 then begin
|
||
S := Copy(S, 1, I - 1);
|
||
end;
|
||
Size := IndyStrToInt('$' + Trim(S), 0); {do not localize}
|
||
if Size = 0 then begin
|
||
Break;
|
||
end;
|
||
LIOHandler.ReadStream(LRequestInfo.PostStream, Size);
|
||
InternalReadLn(LIOHandler); // CRLF at end of chunk data
|
||
until False;
|
||
// skip trailer headers
|
||
repeat until InternalReadLn(LIOHandler) = '';
|
||
LRequestInfo.PostStream.Position := 0;
|
||
end
|
||
else if LRequestInfo.HasContentLength then
|
||
begin
|
||
CreatePostStream(AContext, LRequestInfo.RawHeaders, LRequestInfo.FPostStream);
|
||
if LRequestInfo.FPostStream = nil then begin
|
||
LRequestInfo.FPostStream := TMemoryStream.Create;
|
||
end;
|
||
LRequestInfo.PostStream.Position := 0;
|
||
if LRequestInfo.ContentLength > 0 then begin
|
||
LIOHandler.ReadStream(LRequestInfo.PostStream, LRequestInfo.ContentLength);
|
||
LRequestInfo.PostStream.Position := 0;
|
||
end;
|
||
end
|
||
// If HTTP Pipelining is used by the client, bytes may exist that belong to
|
||
// the NEXT request! We need to look at the CURRENT request and only check
|
||
// for misreported body data if a body is actually expected. GET and HEAD
|
||
// requests do not have bodies...
|
||
else if LRequestInfo.CommandType in [hcPOST, hcPUT] then
|
||
begin
|
||
if LIOHandler.InputBufferIsEmpty then begin
|
||
LIOHandler.CheckForDataOnSource(1);
|
||
end;
|
||
if not LIOHandler.InputBufferIsEmpty then begin
|
||
LResponseInfo.ResponseNo := 411; // length required
|
||
LResponseInfo.CloseConnection := True;
|
||
LResponseInfo.WriteHeader;
|
||
Exit;
|
||
end;
|
||
end;
|
||
Result := True;
|
||
end;
|
||
|
||
var
|
||
i: integer;
|
||
s, LInputLine, LRawHTTPCommand, LCmd, LContentType, LAuthType: String;
|
||
LURI: TIdURI;
|
||
LContinueProcessing, LCloseConnection: Boolean;
|
||
LConn: TIdTCPConnection;
|
||
LEncoding: IIdTextEncoding;
|
||
begin
|
||
LContinueProcessing := True;
|
||
Result := False;
|
||
LCloseConnection := not KeepAlive;
|
||
try
|
||
try
|
||
LConn := AContext.Connection;
|
||
repeat
|
||
LInputLine := InternalReadLn(LConn.IOHandler);
|
||
i := RPos(' ', LInputLine, -1); {Do not Localize}
|
||
if i = 0 then begin
|
||
raise EIdHTTPErrorParsingCommand.Create(RSHTTPErrorParsingCommand);
|
||
end;
|
||
LRequestInfo := TIdHTTPRequestInfo.Create(Self);
|
||
try
|
||
LResponseInfo := TIdHTTPResponseInfo.Create(Self, LRequestInfo, LConn);
|
||
try
|
||
// SG 05.07.99
|
||
// Set the ServerSoftware string to what it's supposed to be. {Do not Localize}
|
||
LResponseInfo.ServerSoftware := Trim(ServerSoftware);
|
||
|
||
// S.G. 6/4/2004: Set the maximum number of lines that will be catured
|
||
// S.G. 6/4/2004: to prevent a remote resource starvation DOS
|
||
LConn.IOHandler.MaxCapturedLines := MaximumHeaderLineCount;
|
||
|
||
// Retrieve the HTTP version
|
||
LRawHTTPCommand := LInputLine;
|
||
LRequestInfo.FVersion := Copy(LInputLine, i + 1, MaxInt);
|
||
|
||
s := LRequestInfo.Version;
|
||
Fetch(s, '/'); {Do not localize}
|
||
LRequestInfo.FVersionMajor := IndyStrToInt(Fetch(s, '.'), -1); {Do not Localize}
|
||
LRequestInfo.FVersionMinor := IndyStrToInt(S, -1);
|
||
|
||
SetLength(LInputLine, i - 1);
|
||
|
||
// Retrieve the HTTP header
|
||
LRequestInfo.RawHeaders.Clear;
|
||
LConn.IOHandler.Capture(LRequestInfo.RawHeaders, '', False); {Do not Localize}
|
||
// TODO: call HeadersCanContinue() here before the headers are parsed,
|
||
// in case the user needs to overwrite any values...
|
||
LRequestInfo.ProcessHeaders;
|
||
|
||
// HTTP 1.1 connections are keep-alive by default
|
||
if not FKeepAlive then begin
|
||
LResponseInfo.CloseConnection := True;
|
||
end
|
||
else if LRequestInfo.IsVersionAtLeast(1, 1) then begin
|
||
LResponseInfo.CloseConnection := TextIsSame(LRequestInfo.Connection, 'close'); {Do not Localize}
|
||
end else begin
|
||
LResponseInfo.CloseConnection := not TextIsSame(LRequestInfo.Connection, 'keep-alive'); {Do not Localize}
|
||
end;
|
||
|
||
{TODO Check for 1.0 only at this point}
|
||
LCmd := UpperCase(Fetch(LInputLine, ' ')); {Do not Localize}
|
||
|
||
// check for overrides when LCmd is 'POST'...
|
||
if TextIsSame(LCmd, 'POST') then begin
|
||
s := LRequestInfo.MethodOverride; // Google/GData
|
||
if s = '' then begin
|
||
// TODO: make RequestInfo properties for these
|
||
s := LRequestInfo.RawHeaders.Values['X-HTTP-Method']; // Microsoft {do not localize}
|
||
if s = '' then begin
|
||
s := LRequestInfo.RawHeaders.Values['X-METHOD-OVERRIDE']; // IBM {do not localize}
|
||
end;
|
||
end;
|
||
if s <> '' then begin
|
||
LCmd := UpperCase(s);
|
||
end;
|
||
end;
|
||
|
||
LRequestInfo.FRawHTTPCommand := LRawHTTPCommand;
|
||
LRequestInfo.FRemoteIP := GetRemoteIP(LConn.Socket);
|
||
LRequestInfo.FCommand := LCmd;
|
||
LRequestInfo.FCommandType := DecodeHTTPCommand(LCmd);
|
||
|
||
// GET data - may exist with POSTs also
|
||
LRequestInfo.QueryParams := LInputLine;
|
||
LInputLine := Fetch(LRequestInfo.FQueryParams, '?'); {Do not Localize}
|
||
|
||
// Host
|
||
// the next line is done in TIdHTTPRequestInfo.ProcessHeaders()...
|
||
// LRequestInfo.FHost := LRequestInfo.Headers.Values['host']; {Do not Localize}
|
||
|
||
LRequestInfo.FURI := LInputLine;
|
||
|
||
// Parse the document input line
|
||
if LInputLine = '*' then begin {Do not Localize}
|
||
LRequestInfo.FDocument := '*'; {Do not Localize}
|
||
end else begin
|
||
LURI := TIdURI.Create(LInputLine);
|
||
try
|
||
// SG 29/11/01: Per request of Doychin
|
||
// Try to fill the "host" parameter
|
||
LRequestInfo.FDocument := TIdURI.URLDecode(LURI.Path) + TIdURI.URLDecode(LURI.Document);
|
||
if (Length(LURI.Host) > 0) and (Length(LRequestInfo.FHost) = 0) then begin
|
||
LRequestInfo.FHost := LURI.Host;
|
||
end;
|
||
finally
|
||
FreeAndNil(LURI);
|
||
end;
|
||
end;
|
||
|
||
// RLebeau 12/14/2005: provide the user with the headers and let the
|
||
// user decide whether the response processing should continue...
|
||
if not HeadersCanContinue then begin
|
||
Break;
|
||
end;
|
||
|
||
// retreive the base ContentType with attributes omitted
|
||
LContentType := ExtractHeaderItem(LRequestInfo.ContentType);
|
||
|
||
// Grab Params so we can parse them
|
||
// POSTed data - may exist with GETs also. With GETs, the action
|
||
// params from the form element will be posted
|
||
// TODO: Rune this is the area that needs fixed. Ive hacked it for now
|
||
// Get data can exists with POSTs, but can POST data exist with GETs?
|
||
// If only the first, the solution is easy. If both - need more
|
||
// investigation.
|
||
|
||
if not PreparePostStream then begin
|
||
Break;
|
||
end;
|
||
|
||
if LRequestInfo.PostStream <> nil then begin
|
||
if TextIsSame(LContentType, ContentTypeFormUrlencoded) then
|
||
begin
|
||
// decoding percent-encoded octets and applying the CharSet is handled by DecodeAndSetParams() further below...
|
||
EnsureEncoding(LEncoding, enc8Bit);
|
||
LRequestInfo.FormParams := ReadStringFromStream(LRequestInfo.PostStream, -1, LEncoding{$IFDEF STRING_IS_ANSI}, LEncoding{$ENDIF});
|
||
DoneWithPostStream(AContext, LRequestInfo); // don't need the PostStream anymore
|
||
end;
|
||
end;
|
||
|
||
// glue together parameters passed in the URL and those
|
||
//
|
||
// RLebeau: should we really be doing this? For a GET, it might
|
||
// makes sense to do, but for a POST the FormParams is the content
|
||
// and the QueryParams belongs to the URL only, not the content.
|
||
// We should be keeping everything separate for accuracy...
|
||
LRequestInfo.UnparsedParams := LRequestInfo.FormParams;
|
||
if Length(LRequestInfo.QueryParams) > 0 then begin
|
||
if Length(LRequestInfo.UnparsedParams) = 0 then begin
|
||
LRequestInfo.FUnparsedParams := LRequestInfo.QueryParams;
|
||
end else begin
|
||
LRequestInfo.FUnparsedParams := LRequestInfo.UnparsedParams + '&' {Do not Localize}
|
||
+ LRequestInfo.QueryParams;
|
||
end;
|
||
end;
|
||
|
||
// Parse Params
|
||
if ParseParams then begin
|
||
if TextIsSame(LContentType, ContentTypeFormUrlencoded) then begin
|
||
LRequestInfo.DecodeAndSetParams(LRequestInfo.UnparsedParams);
|
||
end else begin
|
||
// Parse only query params when content type is not 'application/x-www-form-urlencoded' {Do not Localize}
|
||
LRequestInfo.DecodeAndSetParams(LRequestInfo.QueryParams);
|
||
end;
|
||
end;
|
||
|
||
// Cookies
|
||
ReadCookiesFromRequestHeader;
|
||
|
||
// Authentication
|
||
s := LRequestInfo.RawHeaders.Values['Authorization']; {Do not Localize}
|
||
if Length(s) > 0 then begin
|
||
LAuthType := Fetch(s, ' ');
|
||
LRequestInfo.FAuthExists := DoParseAuthentication(AContext, LAuthType, s, LRequestInfo.FAuthUsername, LRequestInfo.FAuthPassword);
|
||
if not LRequestInfo.FAuthExists then begin
|
||
raise EIdHTTPUnsupportedAuthorisationScheme.Create(
|
||
RSHTTPUnsupportedAuthorisationScheme);
|
||
end;
|
||
end;
|
||
|
||
// Session management
|
||
GetSessionFromCookie(AContext, LRequestInfo, LResponseInfo, LContinueProcessing);
|
||
if LContinueProcessing then begin
|
||
try
|
||
// These essentially all "retrieve" so they are all "Get"s
|
||
if LRequestInfo.CommandType in [hcGET, hcPOST, hcHEAD] then begin
|
||
DoCommandGet(AContext, LRequestInfo, LResponseInfo);
|
||
end else begin
|
||
DoCommandOther(AContext, LRequestInfo, LResponseInfo);
|
||
end;
|
||
except
|
||
on E: EIdSocketError do begin // don't stop socket exceptions
|
||
raise;
|
||
end;
|
||
on E: Exception do begin
|
||
LResponseInfo.ResponseNo := 500;
|
||
LResponseInfo.ContentText := E.Message;
|
||
DoCommandError(AContext, LRequestInfo, LResponseInfo, E);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
// Write even though WriteContent will, may be a redirect or other
|
||
if not LResponseInfo.HeaderHasBeenWritten then begin
|
||
LResponseInfo.WriteHeader;
|
||
end;
|
||
// Always check ContentText first
|
||
if (Length(LResponseInfo.ContentText) > 0)
|
||
or Assigned(LResponseInfo.ContentStream) then begin
|
||
LResponseInfo.WriteContent;
|
||
end;
|
||
finally
|
||
LCloseConnection := LResponseInfo.CloseConnection;
|
||
FreeAndNil(LResponseInfo);
|
||
end;
|
||
finally
|
||
FreeAndNil(LRequestInfo);
|
||
end;
|
||
until LCloseConnection;
|
||
except
|
||
on E: EIdSocketError do begin
|
||
if not ((E.LastError = Id_WSAESHUTDOWN) or (E.LastError = Id_WSAECONNABORTED) or (E.LastError = Id_WSAECONNRESET)) then begin
|
||
raise;
|
||
end;
|
||
end;
|
||
on E: EIdClosedSocket do begin
|
||
AContext.Connection.Disconnect;
|
||
end;
|
||
end;
|
||
finally
|
||
AContext.Connection.Disconnect(False);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoInvalidSession(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; AResponseInfo: TIdHTTPResponseInfo;
|
||
var VContinueProcessing: Boolean; const AInvalidSessionID: String);
|
||
begin
|
||
if Assigned(FOnInvalidSession) then begin
|
||
FOnInvalidSession(AContext, ARequestInfo, AResponseInfo, VContinueProcessing, AInvalidSessionID)
|
||
end;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.EndSession(const SessionName: String; const RemoteIP: String = ''): Boolean;
|
||
var
|
||
LSession: TIdHTTPSession;
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
Result := False;
|
||
LSessionList := SessionList;
|
||
if Assigned(LSessionList) then begin
|
||
LSession := SessionList.GetSession(SessionName, RemoteIP); {Do not Localize}
|
||
if Assigned(LSession) then begin
|
||
LSessionList.RemoveSession(LSession);
|
||
LSession.DoSessionEnd;
|
||
// must set the owner to nil or the session will try to fire the OnSessionEnd
|
||
// event again, and also remove itself from the session list and deadlock
|
||
LSession.FOwner := nil;
|
||
FreeAndNil(LSession);
|
||
Result := True;
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoSessionEnd(Sender: TIdHTTPSession);
|
||
begin
|
||
if Assigned(FOnSessionEnd) then begin
|
||
FOnSessionEnd(Sender);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoSessionStart(Sender: TIdHTTPSession);
|
||
begin
|
||
if Assigned(FOnSessionStart) then begin
|
||
FOnSessionStart(Sender);
|
||
end;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.GetSessionFromCookie(AContext: TIdContext;
|
||
AHTTPRequest: TIdHTTPRequestInfo; AHTTPResponse: TIdHTTPResponseInfo;
|
||
var VContinueProcessing: Boolean): TIdHTTPSession;
|
||
var
|
||
LIndex: Integer;
|
||
LSessionID: String;
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
Result := nil;
|
||
VContinueProcessing := True;
|
||
if SessionState then
|
||
begin
|
||
LSessionList := FSessionList;
|
||
LIndex := AHTTPRequest.Cookies.GetCookieIndex(SessionIDCookieName);
|
||
while LIndex >= 0 do
|
||
begin
|
||
LSessionID := AHTTPRequest.Cookies[LIndex].Value;
|
||
if Assigned(LSessionList) then begin
|
||
Result := LSessionList.GetSession(LSessionID, AHTTPRequest.RemoteIP);
|
||
if Assigned(Result) then begin
|
||
Break;
|
||
end;
|
||
end;
|
||
DoInvalidSession(AContext, AHTTPRequest, AHTTPResponse, VContinueProcessing, LSessionID);
|
||
if not VContinueProcessing then begin
|
||
Break;
|
||
end;
|
||
LIndex := AHTTPRequest.Cookies.GetCookieIndex(SessionIDCookieName, LIndex+1);
|
||
end; { while }
|
||
// check if a session was returned. If not and if AutoStartSession is set to
|
||
// true, Create a new session
|
||
if (Result = nil) and VContinueProcessing and FAutoStartSession then begin
|
||
Result := CreateSession(AContext, AHTTPResponse, AHTTPrequest);
|
||
end;
|
||
end;
|
||
AHTTPRequest.FSession := Result;
|
||
AHTTPResponse.FSession := Result;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.Startup;
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
inherited Startup;
|
||
|
||
// set the session timeout and options
|
||
LSessionList := FSessionList;
|
||
if not Assigned(LSessionList) then begin
|
||
LSessionList := TIdHTTPDefaultSessionList.Create(Self);
|
||
FSessionList := LSessionList;
|
||
FImplicitSessionList := True;
|
||
end;
|
||
|
||
if FSessionTimeOut <> 0 then begin
|
||
LSessionList.FSessionTimeout := FSessionTimeOut;
|
||
end else begin
|
||
FSessionState := False;
|
||
end;
|
||
|
||
// Session events
|
||
LSessionList.OnSessionStart := DoSessionStart;
|
||
LSessionList.OnSessionEnd := DoSessionEnd;
|
||
|
||
// If session handling is enabled, create the housekeeper thread
|
||
if SessionState then begin
|
||
FSessionCleanupThread := TIdHTTPSessionCleanerThread.Create(LSessionList);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.Shutdown;
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
// Boost the clear thread priority to give it a good chance to terminate
|
||
if Assigned(FSessionCleanupThread) then begin
|
||
IndySetThreadPriority(FSessionCleanupThread, tpNormal);
|
||
FSessionCleanupThread.TerminateAndWaitFor;
|
||
FreeAndNil(FSessionCleanupThread);
|
||
end;
|
||
|
||
// RLebeau: FSessionList might not be assignd yet if Shutdown() is being
|
||
// called due to an exception raised in Startup()...
|
||
LSessionList := FSessionList;
|
||
if Assigned(LSessionList) then begin
|
||
if FImplicitSessionList then begin
|
||
SetSessionList(nil);
|
||
end else begin
|
||
LSessionList.Clear;
|
||
end;
|
||
{$IFDEF USE_OBJECT_ARC}LSessionList := nil;{$ENDIF}
|
||
end;
|
||
|
||
inherited Shutdown;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.SetSessionList(const AValue: TIdHTTPCustomSessionList);
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
LSessionList := FSessionList;
|
||
|
||
if LSessionList <> AValue then
|
||
begin
|
||
// RLebeau - is this really needed? What should happen if this
|
||
// gets called by Notification() if the sessionList is freed while
|
||
// the server is still Active?
|
||
if Active then begin
|
||
raise EIdException.Create(RSHTTPCannotSwitchSessionListWhenActive);
|
||
end;
|
||
|
||
// under ARC, all weak references to a freed object get nil'ed automatically
|
||
|
||
// If implicit one already exists free it
|
||
// Free the default SessionList
|
||
if FImplicitSessionList then begin
|
||
// Under D8 notification gets called after .Free of FreeAndNil, but before
|
||
// its set to nil with a side effect of IDisposable. To counteract this we
|
||
// set it to nil first.
|
||
// -Kudzu
|
||
FSessionList := nil;
|
||
FImplicitSessionList := False;
|
||
IdDisposeAndNil(LSessionList);
|
||
end;
|
||
|
||
{$IFNDEF USE_OBJECT_ARC}
|
||
// Ensure we will no longer be notified when the component is freed
|
||
if LSessionList <> nil then begin
|
||
LSessionList.RemoveFreeNotification(Self);
|
||
end;
|
||
{$ENDIF}
|
||
|
||
FSessionList := AValue;
|
||
|
||
{$IFNDEF USE_OBJECT_ARC}
|
||
// Ensure we will be notified when the component is freed, even is it's on
|
||
// another form
|
||
if AValue <> nil then begin
|
||
AValue.FreeNotification(Self);
|
||
end;
|
||
{$ENDIF}
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.SetSessionState(const Value: Boolean);
|
||
begin
|
||
// ToDo: Add thread multiwrite protection here
|
||
if (not (IsDesignTime or IsLoading)) and Active then begin
|
||
raise EIdHTTPCannotSwitchSessionStateWhenActive.Create(RSHTTPCannotSwitchSessionStateWhenActive);
|
||
end;
|
||
FSessionState := Value;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.SetSessionIDCookieName(const AValue: string);
|
||
var
|
||
LCookieName: string;
|
||
begin
|
||
// ToDo: Add thread multiwrite protection here
|
||
if (not (IsDesignTime or IsLoading)) and Active then begin
|
||
raise EIdHTTPCannotSwitchSessionIDCookieNameWhenActive.Create(RSHTTPCannotSwitchSessionIDCookieNameWhenActive);
|
||
end;
|
||
LCookieName := Trim(AValue);
|
||
if LCookieName = '' then begin
|
||
// TODO: move this into IdResourceStringsProtocols.pas
|
||
raise EIdException.Create('Invalid cookie name'); {do not localize}
|
||
end;
|
||
FSessionIDCookieName := AValue;
|
||
end;
|
||
|
||
function TIdCustomHTTPServer.IsSessionIDCookieNameStored: Boolean;
|
||
begin
|
||
Result := not TextIsSame(SessionIDCookieName, GSessionIDCookie);
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.CreatePostStream(ASender: TIdContext;
|
||
AHeaders: TIdHeaderList; var VPostStream: TStream);
|
||
begin
|
||
if Assigned(OnCreatePostStream) then begin
|
||
OnCreatePostStream(ASender, AHeaders, VPostStream);
|
||
end;
|
||
end;
|
||
|
||
procedure TIdCustomHTTPServer.DoneWithPostStream(ASender: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo);
|
||
var
|
||
LCanFree: Boolean;
|
||
begin
|
||
LCanFree := True;
|
||
if Assigned(FOnDoneWithPostStream) then begin
|
||
FOnDoneWithPostStream(ASender, ARequestInfo, LCanFree);
|
||
end;
|
||
if LCanFree then begin
|
||
FreeAndNil(ARequestInfo.FPostStream);
|
||
end;
|
||
end;
|
||
|
||
{ TIdHTTPSession }
|
||
|
||
constructor TIdHTTPSession.Create(AOwner: TIdHTTPCustomSessionList);
|
||
begin
|
||
inherited Create;
|
||
|
||
FLock := TIdCriticalSection.Create;
|
||
FContent := TStringList.Create;
|
||
FOwner := AOwner;
|
||
if Assigned(AOwner) then
|
||
begin
|
||
if Assigned(AOwner.OnSessionStart) then begin
|
||
AOwner.OnSessionStart(Self);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
constructor TIdHTTPSession.CreateInitialized(AOwner: TIdHTTPCustomSessionList; const SessionID, RemoteIP: string);
|
||
begin
|
||
inherited Create;
|
||
|
||
FSessionID := SessionID;
|
||
FRemoteHost := RemoteIP;
|
||
FLastTimeStamp := Now;
|
||
FLock := TIdCriticalSection.Create;
|
||
FContent := TStringList.Create;
|
||
FOwner := AOwner;
|
||
if Assigned(AOwner) then
|
||
begin
|
||
if Assigned(AOwner.OnSessionStart) then begin
|
||
AOwner.OnSessionStart(Self);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
destructor TIdHTTPSession.Destroy;
|
||
begin
|
||
// code added here should also be reflected in
|
||
// the TIdHTTPDefaultSessionList.RemoveSessionFromLockedList method
|
||
// Why? It calls this function and this code gets executed?
|
||
DoSessionEnd;
|
||
FreeAndNil(FContent);
|
||
FreeAndNil(FLock);
|
||
if Assigned(FOwner) then begin
|
||
FOwner.RemoveSession(Self);
|
||
end;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TIdHTTPSession.DoSessionEnd;
|
||
begin
|
||
if Assigned(FOwner) and Assigned(FOwner.FOnSessionEnd) then begin
|
||
FOwner.FOnSessionEnd(Self);
|
||
end;
|
||
end;
|
||
|
||
function TIdHTTPSession.IsSessionStale: boolean;
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LOwner: TIdHTTPCustomSessionList;
|
||
begin
|
||
LOwner := FOwner;
|
||
if Assigned(LOwner) then begin
|
||
Result := TimeStampInterval(FLastTimeStamp, Now) > Integer(LOwner.SessionTimeout);
|
||
end else begin
|
||
Result := True;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPSession.Lock;
|
||
begin
|
||
// ToDo: Add session locking code here
|
||
FLock.Enter;
|
||
end;
|
||
|
||
procedure TIdHTTPSession.SetContent(const Value: TStrings);
|
||
begin
|
||
FContent.Assign(Value);
|
||
end;
|
||
|
||
procedure TIdHTTPSession.Unlock;
|
||
begin
|
||
// ToDo: Add session unlocking code here
|
||
FLock.Leave;
|
||
end;
|
||
|
||
{ TIdHTTPRequestInfo }
|
||
|
||
constructor TIdHTTPRequestInfo.Create(AOwner: TPersistent);
|
||
begin
|
||
inherited Create(AOwner);
|
||
FCommandType := hcUnknown;
|
||
FCookies := TIdCookies.Create(Self);
|
||
FParams := TStringList.Create;
|
||
ContentLength := -1;
|
||
end;
|
||
|
||
procedure TIdHTTPRequestInfo.DecodeAndSetParams(const AValue: String);
|
||
var
|
||
i, j : Integer;
|
||
s: string;
|
||
LEncoding: IIdTextEncoding;
|
||
begin
|
||
// Convert special characters
|
||
// ampersand '&' separates values {Do not Localize}
|
||
Params.BeginUpdate;
|
||
try
|
||
Params.Clear;
|
||
// TODO: provide an event or property that lets the user specify
|
||
// which charset to use for decoding query string parameters. We
|
||
// should not be using the 'Content-Type' charset for that. For
|
||
// 'application/x-www-form-urlencoded' forms, we should be, though...
|
||
LEncoding := CharsetToEncoding(CharSet);
|
||
i := 1;
|
||
while i <= Length(AValue) do
|
||
begin
|
||
j := i;
|
||
while (j <= Length(AValue)) and (AValue[j] <> '&') do {do not localize}
|
||
begin
|
||
Inc(j);
|
||
end;
|
||
s := Copy(AValue, i, j-i);
|
||
// See RFC 1866 section 8.2.1. TP
|
||
s := ReplaceAll(s, '+', ' '); {do not localize}
|
||
Params.Add(TIdURI.URLDecode(s, LEncoding));
|
||
i := j + 1;
|
||
end;
|
||
finally
|
||
Params.EndUpdate;
|
||
end;
|
||
end;
|
||
|
||
destructor TIdHTTPRequestInfo.Destroy;
|
||
begin
|
||
FreeAndNil(FCookies);
|
||
FreeAndNil(FParams);
|
||
FreeAndNil(FPostStream);
|
||
inherited Destroy;
|
||
end;
|
||
|
||
function TIdHTTPRequestInfo.IsVersionAtLeast(const AMajor, AMinor: Integer): Boolean;
|
||
begin
|
||
Result := (FVersionMajor > AMajor) or
|
||
((FVersionMajor = AMajor) and (FVersionMinor >= AMinor));
|
||
end;
|
||
|
||
{ TIdHTTPResponseInfo }
|
||
|
||
procedure TIdHTTPResponseInfo.CloseSession;
|
||
var
|
||
i: Integer;
|
||
LCookie: TIdCookie;
|
||
begin
|
||
i := Cookies.GetCookieIndex(HTTPServer.SessionIDCookieName);
|
||
while i > -1 do begin
|
||
Cookies.Delete(i);
|
||
i := Cookies.GetCookieIndex(HTTPServer.SessionIDCookieName, i);
|
||
end;
|
||
LCookie := Cookies.Add;
|
||
LCookie.CookieName := HTTPServer.SessionIDCookieName;
|
||
LCookie.Expires := Date-7;
|
||
FreeAndNil(FSession);
|
||
end;
|
||
|
||
constructor TIdHTTPResponseInfo.Create(AServer: TIdCustomHTTPServer;
|
||
ARequestInfo: TIdHTTPRequestInfo; AConnection: TIdTCPConnection);
|
||
begin
|
||
inherited Create(AServer);
|
||
|
||
FRequestInfo := ARequestInfo;
|
||
FConnection := AConnection;
|
||
FHttpServer := AServer;
|
||
|
||
FFreeContentStream := True;
|
||
|
||
ResponseNo := GResponseNo;
|
||
ContentType := ''; //GContentType;
|
||
ContentLength := GFContentLength;
|
||
|
||
{Some clients may not support folded lines}
|
||
RawHeaders.FoldLines := False;
|
||
FCookies := TIdCookies.Create(Self);
|
||
|
||
{TODO Specify version - add a class method dummy that calls version}
|
||
ServerSoftware := GServerSoftware;
|
||
|
||
end;
|
||
|
||
destructor TIdHTTPResponseInfo.Destroy;
|
||
begin
|
||
FreeAndNil(FCookies);
|
||
ReleaseContentStream;
|
||
inherited Destroy;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.Redirect(const AURL: string);
|
||
begin
|
||
ResponseNo := 302;
|
||
Location := AURL;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.ReleaseContentStream;
|
||
begin
|
||
if FreeContentStream then begin
|
||
FreeAndNil(FContentStream);
|
||
end else begin
|
||
FContentStream := nil;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.SetCloseConnection(const Value: Boolean);
|
||
begin
|
||
Connection := iif(Value, 'close', 'keep-alive'); {Do not Localize}
|
||
// TODO: include a 'Keep-Alive' header to specify a timeout value
|
||
FCloseConnection := Value;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.SetCookies(const AValue: TIdCookies);
|
||
begin
|
||
FCookies.Assign(AValue);
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.SetHeaders;
|
||
begin
|
||
inherited SetHeaders;
|
||
if Server <> '' then begin
|
||
FRawHeaders.Values['Server'] := Server; {Do not Localize}
|
||
end;
|
||
if Location <> '' then begin
|
||
FRawHeaders.Values['Location'] := Location; {Do not Localize}
|
||
end;
|
||
if FLastModified > 0 then begin
|
||
FRawHeaders.Values['Last-Modified'] := LocalDateTimeToHttpStr(FLastModified); {do not localize}
|
||
end;
|
||
if AuthRealm <> '' then begin
|
||
FRawHeaders.Values['WWW-Authenticate'] := 'Basic realm="' + AuthRealm + '"'; {Do not Localize}
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.SetResponseNo(const AValue: Integer);
|
||
begin
|
||
FResponseNo := AValue;
|
||
case FResponseNo of
|
||
100: ResponseText := RSHTTPContinue;
|
||
// 2XX: Success
|
||
200: ResponseText := RSHTTPOK;
|
||
201: ResponseText := RSHTTPCreated;
|
||
202: ResponseText := RSHTTPAccepted;
|
||
203: ResponseText := RSHTTPNonAuthoritativeInformation;
|
||
204: ResponseText := RSHTTPNoContent;
|
||
205: ResponseText := RSHTTPResetContent;
|
||
206: ResponseText := RSHTTPPartialContent;
|
||
// 3XX: Redirections
|
||
301: ResponseText := RSHTTPMovedPermanently;
|
||
302: ResponseText := RSHTTPMovedTemporarily;
|
||
303: ResponseText := RSHTTPSeeOther;
|
||
304: ResponseText := RSHTTPNotModified;
|
||
305: ResponseText := RSHTTPUseProxy;
|
||
// 4XX Client Errors
|
||
400: ResponseText := RSHTTPBadRequest;
|
||
401: ResponseText := RSHTTPUnauthorized;
|
||
403: ResponseText := RSHTTPForbidden;
|
||
404: begin
|
||
ResponseText := RSHTTPNotFound;
|
||
// Close connection
|
||
CloseConnection := True;
|
||
end;
|
||
405: ResponseText := RSHTTPMethodNotAllowed;
|
||
406: ResponseText := RSHTTPNotAcceptable;
|
||
407: ResponseText := RSHTTPProxyAuthenticationRequired;
|
||
408: ResponseText := RSHTTPRequestTimeout;
|
||
409: ResponseText := RSHTTPConflict;
|
||
410: ResponseText := RSHTTPGone;
|
||
411: ResponseText := RSHTTPLengthRequired;
|
||
412: ResponseText := RSHTTPPreconditionFailed;
|
||
413: ResponseText := RSHTTPRequestEntityTooLong;
|
||
414: ResponseText := RSHTTPRequestURITooLong;
|
||
415: ResponseText := RSHTTPUnsupportedMediaType;
|
||
417: ResponseText := RSHTTPExpectationFailed;
|
||
428: ResponseText := RSHTTPPreconditionRequired;
|
||
429: ResponseText := RSHTTPTooManyRequests;
|
||
431: ResponseText := RSHTTPRequestHeaderFieldsTooLarge;
|
||
// 5XX Server errors
|
||
500: ResponseText := RSHTTPInternalServerError;
|
||
501: ResponseText := RSHTTPNotImplemented;
|
||
502: ResponseText := RSHTTPBadGateway;
|
||
503: ResponseText := RSHTTPServiceUnavailable;
|
||
504: ResponseText := RSHTTPGatewayTimeout;
|
||
505: ResponseText := RSHTTPHTTPVersionNotSupported;
|
||
511: ResponseText := RSHTTPNetworkAuthenticationRequired;
|
||
else
|
||
ResponseText := RSHTTPUnknownResponseCode;
|
||
end;
|
||
|
||
{if ResponseNo >= 400 then
|
||
// Force COnnection closing when there is error during the request processing
|
||
CloseConnection := true;
|
||
end;}
|
||
end;
|
||
|
||
function TIdHTTPResponseInfo.ServeFile(AContext: TIdContext; const AFile: String): Int64;
|
||
var
|
||
EnableTransferFile: Boolean;
|
||
begin
|
||
if Length(ContentType) = 0 then begin
|
||
ContentType := HTTPServer.MIMETable.GetFileMIMEType(AFile);
|
||
end;
|
||
ContentLength := FileSizeByName(AFile);
|
||
if Length(ContentDisposition) = 0 then begin
|
||
// TODO: use EncodeHeader() here...
|
||
ContentDisposition := IndyFormat('attachment; filename="%s";', [ExtractFileName(AFile)]);
|
||
end;
|
||
WriteHeader;
|
||
EnableTransferFile := not (AContext.Connection.IOHandler is TIdSSLIOHandlerSocketBase);
|
||
Result := AContext.Connection.IOHandler.WriteFile(AFile, EnableTransferFile);
|
||
end;
|
||
|
||
function TIdHTTPResponseInfo.SmartServeFile(AContext: TIdContext;
|
||
ARequestInfo: TIdHTTPRequestInfo; const AFile: String): Int64;
|
||
var
|
||
LFileDate : TDateTime;
|
||
LReqDate : TDateTime;
|
||
begin
|
||
LFileDate := IndyFileAge(AFile);
|
||
if (LFileDate = 0.0) and (not FileExists(AFile)) then
|
||
begin
|
||
ResponseNo := 404;
|
||
Result := 0;
|
||
end else
|
||
begin
|
||
LReqDate := GMTToLocalDateTime(ARequestInfo.RawHeaders.Values['If-Modified-Since']); {do not localize}
|
||
// if the file date in the If-Modified-Since header is within 2 seconds of the
|
||
// actual file, then we will send a 304. We don't use the ETag - offers nothing
|
||
// over the file date for static files on windows. Linux: consider using iNode
|
||
|
||
// RLebeau 2/21/2011: TODO - make use of ETag. It is supposed to be updated
|
||
// whenever the file contents change, regardless of the file's timestamps.
|
||
|
||
if (LReqDate <> 0) and (abs(LReqDate - LFileDate) < 2 * (1 / (24 * 60 * 60))) then
|
||
begin
|
||
ResponseNo := 304;
|
||
Result := 0;
|
||
end else
|
||
begin
|
||
Date := Now;
|
||
LastModified := LFileDate;
|
||
Result := ServeFile(AContext, AFile);
|
||
end;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.WriteContent;
|
||
begin
|
||
if not HeaderHasBeenWritten then begin
|
||
WriteHeader;
|
||
end;
|
||
|
||
// RLebeau 11/23/2014: Per RFC 2616 Section 4.3:
|
||
//
|
||
// For response messages, whether or not a message-body is included with
|
||
// a message is dependent on both the request method and the response
|
||
// status code (section 6.1.1). All responses to the HEAD request method
|
||
// MUST NOT include a message-body, even though the presence of entity-
|
||
// header fields might lead one to believe they do. All 1xx
|
||
// (informational), 204 (no content), and 304 (not modified) responses
|
||
// MUST NOT include a message-body. All other responses do include a
|
||
// message-body, although it MAY be of zero length.
|
||
|
||
if not (
|
||
(FRequestInfo.CommandType = hcHEAD) or
|
||
((ResponseNo div 100) = 1) or
|
||
(ResponseNo = 204) or
|
||
(ResponseNo = 304)
|
||
) then
|
||
begin
|
||
// Always check ContentText first
|
||
if ContentText <> '' then begin
|
||
FConnection.IOHandler.Write(ContentText, CharsetToEncoding(CharSet));
|
||
end
|
||
else if Assigned(ContentStream) then begin
|
||
ContentStream.Position := 0;
|
||
FConnection.IOHandler.Write(ContentStream);
|
||
end
|
||
else begin
|
||
FConnection.IOHandler.WriteLn('<HTML><BODY><B>' + IntToStr(ResponseNo) + ' ' + ResponseText {Do not Localize}
|
||
+ '</B></BODY></HTML>', CharsetToEncoding(CharSet)); {Do not Localize}
|
||
end;
|
||
end;
|
||
|
||
// Clear All - This signifies that WriteConent has been called.
|
||
ContentText := ''; {Do not Localize}
|
||
ReleaseContentStream;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.WriteHeader;
|
||
var
|
||
i: Integer;
|
||
LBufferingStarted: Boolean;
|
||
begin
|
||
if HeaderHasBeenWritten then begin
|
||
raise EIdHTTPHeaderAlreadyWritten.Create(RSHTTPHeaderAlreadyWritten);
|
||
end;
|
||
FHeaderHasBeenWritten := True;
|
||
|
||
if AuthRealm <> '' then
|
||
begin
|
||
ResponseNo := 401;
|
||
if (Length(ContentText) = 0) and (not Assigned(ContentStream)) then
|
||
begin
|
||
ContentType := 'text/html; charset=utf-8'; {Do not Localize}
|
||
ContentText := '<HTML><BODY><B>' + IntToStr(ResponseNo) + ' ' + ResponseText + '</B></BODY></HTML>'; {Do not Localize}
|
||
ContentLength := -1; // calculated below
|
||
end;
|
||
end;
|
||
|
||
// RLebeau 5/15/2012: for backwards compatibility. We really should
|
||
// make the user set this every time instead...
|
||
if ContentType = '' then begin
|
||
if (ContentText <> '') or (Assigned(ContentStream)) then begin
|
||
ContentType := 'text/html; charset=ISO-8859-1'; {Do not Localize}
|
||
end;
|
||
end;
|
||
|
||
// RLebeau: according to RFC 2616 Section 4.4:
|
||
//
|
||
// If a Content-Length header field (section 14.13) is present, its
|
||
// decimal value in OCTETs represents both the entity-length and the
|
||
// transfer-length. The Content-Length header field MUST NOT be sent
|
||
// if these two lengths are different (i.e., if a Transfer-Encoding
|
||
// header field is present). If a message is received with both a
|
||
// Transfer-Encoding header field and a Content-Length header field,
|
||
// the latter MUST be ignored.
|
||
// ...
|
||
// Messages MUST NOT include both a Content-Length header field and a
|
||
// non-identity transfer-coding. If the message does include a non-
|
||
// identity transfer-coding, the Content-Length MUST be ignored.
|
||
|
||
if (ContentLength = -1) and
|
||
((TransferEncoding = '') or TextIsSame(TransferEncoding, 'identity')) then {do not localize}
|
||
begin
|
||
// Always check ContentText first
|
||
if ContentText <> '' then begin
|
||
ContentLength := CharsetToEncoding(CharSet).GetByteCount(ContentText);
|
||
end
|
||
else if Assigned(ContentStream) then begin
|
||
ContentLength := ContentStream.Size;
|
||
end else begin
|
||
ContentLength := 0;
|
||
end;
|
||
end;
|
||
|
||
if Date <= 0 then begin
|
||
Date := Now;
|
||
end;
|
||
|
||
SetHeaders;
|
||
|
||
LBufferingStarted := not FConnection.IOHandler.WriteBufferingActive;
|
||
if LBufferingStarted then begin
|
||
FConnection.IOHandler.WriteBufferOpen;
|
||
end;
|
||
try
|
||
// Write HTTP status response
|
||
FConnection.IOHandler.WriteLn('HTTP/1.1 ' + IntToStr(ResponseNo) + ' ' + ResponseText); {Do not Localize}
|
||
// Write headers
|
||
FConnection.IOHandler.Write(RawHeaders);
|
||
// Write cookies
|
||
for i := 0 to Cookies.Count - 1 do begin
|
||
FConnection.IOHandler.WriteLn('Set-Cookie: ' + Cookies[i].ServerCookie); {Do not Localize}
|
||
end;
|
||
// HTTP headers end with a double CR+LF
|
||
FConnection.IOHandler.WriteLn;
|
||
if LBufferingStarted then begin
|
||
FConnection.IOHandler.WriteBufferClose;
|
||
end;
|
||
except
|
||
if LBufferingStarted then begin
|
||
FConnection.IOHandler.WriteBufferCancel;
|
||
end;
|
||
raise;
|
||
end;
|
||
end;
|
||
|
||
function TIdHTTPResponseInfo.GetServer: string;
|
||
begin
|
||
Result := Server;
|
||
end;
|
||
|
||
procedure TIdHTTPResponseInfo.SetServer(const Value: string);
|
||
begin
|
||
Server := Value;
|
||
end;
|
||
|
||
{ TIdHTTPDefaultSessionList }
|
||
|
||
procedure TIdHTTPDefaultSessionList.Add(ASession: TIdHTTPSession);
|
||
begin
|
||
SessionList.Add(ASession);
|
||
end;
|
||
|
||
procedure TIdHTTPDefaultSessionList.Clear;
|
||
var
|
||
LSessionList: TIdHTTPSessionList;
|
||
LSession: TIdHTTPSession;
|
||
i: Integer;
|
||
begin
|
||
LSessionList := SessionList.LockList;
|
||
try
|
||
for i := LSessionList.Count - 1 DownTo 0 do
|
||
begin
|
||
LSession := {$IFDEF HAS_GENERICS_TList}LSessionList[i]{$ELSE}TIdHTTPSession(LSessionList[i]){$ENDIF};
|
||
if LSession <> nil then
|
||
begin
|
||
LSession.DoSessionEnd;
|
||
// must set the owner to nil or the session will try to fire the
|
||
// OnSessionEnd event again, and also remove itself from the session
|
||
// list and deadlock
|
||
LSession.FOwner := nil;
|
||
FreeAndNil(LSession);
|
||
end;
|
||
end;
|
||
LSessionList.Clear;
|
||
LSessionList.Capacity := SessionCapacity;
|
||
finally
|
||
SessionList.UnlockList;
|
||
end;
|
||
end;
|
||
|
||
function TIdHTTPDefaultSessionList.CreateSession(const RemoteIP, SessionID: String): TIdHTTPSession;
|
||
begin
|
||
Result := TIdHTTPSession.CreateInitialized(Self, SessionID, RemoteIP);
|
||
SessionList.Add(Result);
|
||
end;
|
||
|
||
function TIdHTTPDefaultSessionList.CreateUniqueSession(
|
||
const RemoteIP: String): TIdHTTPSession;
|
||
var
|
||
SessionID: String;
|
||
begin
|
||
SessionID := GetRandomString(15);
|
||
while GetSession(SessionID, RemoteIP) <> nil do
|
||
begin
|
||
SessionID := GetRandomString(15);
|
||
end; // while
|
||
Result := CreateSession(RemoteIP, SessionID);
|
||
end;
|
||
|
||
destructor TIdHTTPDefaultSessionList.Destroy;
|
||
begin
|
||
Clear;
|
||
FreeAndNil(FSessionList);
|
||
inherited destroy;
|
||
end;
|
||
|
||
function TIdHTTPDefaultSessionList.GetSession(const SessionID, RemoteIP: string): TIdHTTPSession;
|
||
var
|
||
LSessionList: TIdHTTPSessionList;
|
||
LSession: TIdHTTPSession;
|
||
i: Integer;
|
||
begin
|
||
Result := nil;
|
||
LSessionList := SessionList.LockList;
|
||
try
|
||
// get current time stamp
|
||
for i := 0 to LSessionList.Count - 1 do
|
||
begin
|
||
LSession := TIdHTTPSession(LSessionList[i]);
|
||
// the stale sessions check has been removed... the cleanup thread should suffice plenty
|
||
if Assigned(LSession) and TextIsSame(LSession.FSessionID, SessionID) and ((Length(RemoteIP) = 0) or TextIsSame(LSession.RemoteHost, RemoteIP)) then
|
||
begin
|
||
// Session found
|
||
LSession.FLastTimeStamp := Now;
|
||
Result := LSession;
|
||
Break;
|
||
end;
|
||
end;
|
||
finally
|
||
SessionList.UnlockList;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPDefaultSessionList.InitComponent;
|
||
var
|
||
LList: TIdHTTPSessionList;
|
||
begin
|
||
inherited InitComponent;
|
||
FSessionList := TIdHTTPSessionThreadList.Create;
|
||
LList := FSessionList.LockList;
|
||
try
|
||
LList.Capacity := SessionCapacity;
|
||
finally
|
||
FSessionList.UnlockList;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPDefaultSessionList.PurgeStaleSessions(PurgeAll: Boolean = false);
|
||
var
|
||
LSessionList: TIdHTTPSessionList;
|
||
LSession: TIdHTTPSession;
|
||
i: Integer;
|
||
begin
|
||
// S.G. 24/11/00: Added a way to force a session purge (Used when thread is terminated)
|
||
// Get necessary data
|
||
Assert(SessionList<>nil);
|
||
|
||
LSessionList := SessionList.LockList;
|
||
try
|
||
// Loop though the sessions.
|
||
for i := LSessionList.Count - 1 downto 0 do
|
||
begin
|
||
// Identify the stale sessions
|
||
LSession := {$IFDEF HAS_GENERICS_TList}LSessionList[i]{$ELSE}TIdHTTPSession(LSessionList[i]){$ENDIF};
|
||
if Assigned(LSession) and (PurgeAll or LSession.IsSessionStale) then
|
||
begin
|
||
RemoveSessionFromLockedList(i, LSessionList);
|
||
end;
|
||
end;
|
||
finally
|
||
SessionList.UnlockList;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPDefaultSessionList.RemoveSession(Session: TIdHTTPSession);
|
||
var
|
||
LSessionList: TIdHTTPSessionList;
|
||
Index: integer;
|
||
begin
|
||
LSessionList := SessionList.LockList;
|
||
try
|
||
Index := LSessionList.IndexOf(Session);
|
||
if index > -1 then
|
||
begin
|
||
LSessionList.Delete(index);
|
||
end;
|
||
finally
|
||
SessionList.UnlockList;
|
||
end;
|
||
end;
|
||
|
||
procedure TIdHTTPDefaultSessionList.RemoveSessionFromLockedList(AIndex: Integer;
|
||
ALockedSessionList: TIdHTTPSessionList);
|
||
var
|
||
LSession: TIdHTTPSession;
|
||
begin
|
||
LSession := {$IFDEF HAS_GENERICS_TList}ALockedSessionList[AIndex]{$ELSE}TIdHTTPSession(ALockedSessionList[AIndex]){$ENDIF};
|
||
LSession.DoSessionEnd;
|
||
// must set the owner to nil or the session will try to fire the OnSessionEnd
|
||
// event again, and also remove itself from the session list and deadlock
|
||
LSession.FOwner := nil;
|
||
FreeAndNil(LSession);
|
||
ALockedSessionList.Delete(AIndex);
|
||
end;
|
||
|
||
{ TIdHTTPSessionClearThread }
|
||
|
||
procedure TIdHTTPSessionCleanerThread.AfterRun;
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
LSessionList := FSessionList;
|
||
if Assigned(LSessionList) then begin
|
||
LSessionList.PurgeStaleSessions(True);
|
||
end;
|
||
inherited AfterRun;
|
||
end;
|
||
|
||
constructor TIdHTTPSessionCleanerThread.Create(SessionList: TIdHTTPCustomSessionList);
|
||
begin
|
||
inherited Create(false);
|
||
// thread priority used to be set to tpIdle but this is not supported
|
||
// under DotNet. How low do you want to go?
|
||
IndySetThreadPriority(Self, tpLowest);
|
||
FSessionList := SessionList;
|
||
end;
|
||
|
||
procedure TIdHTTPSessionCleanerThread.Run;
|
||
var
|
||
// under ARC, convert a weak reference to a strong reference before working with it
|
||
LSessionList: TIdHTTPCustomSessionList;
|
||
begin
|
||
IndySleep(1000);
|
||
LSessionList := FSessionList;
|
||
if Assigned(LSessionList) then begin
|
||
LSessionList.PurgeStaleSessions(Terminated);
|
||
end;
|
||
end;
|
||
|
||
end.
|