{*_* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: François PIETTE Description: THttpAppSrv is a specialized THttpServer component to ease his use for writing application servers. Creation: Dec 20, 2003 Version: V9.6 EMail: francois.piette@overbyte.be http://www.overbyte.be Support: https://en.delphipraxis.net/forum/37-ics-internet-component-suite/ Legal issues: Copyright (C) 2003-2026 by François PIETTE Rue de Grady 24, 4053 Embourg, Belgium. This software is provided 'as-is', without any express or implied warranty. In no event will the author be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented, you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. 4. You must register this software by sending a picture postcard to the author. Use a nice stamp and mention your name, street address, EMail address and any comment you like to say. Quick User Guide: At the start of your program, you must call THttpAppSrv.AddGetHandler, THttpAppSrv.AddPostHandler, THttpAppSrv.AddDeleteHandler or THttpAppSrv.AddPutHandler for each URL you want to handle by code, that is each URL which has a dynamic page generated by your code. The same handler can be used for multiple verbs, check the verb in the handler itself. You must also derive your own class from THttpAppSrvConnection and feed THttpAppSrv.ClientClass with his class name so that the component instanciate your class to handle each client connection. You will place your database stuff in your THttpAppSrvConnection derived class, as well as anything else is needed to handle the client connection. Usually you also need "session data", that is data which is persitant across several HTTP connections. HTTP is a stateless protocol, so client connect and disconnect at will and at moment independent of the application state. You maintain application data in "session data". For Session data, you have to derive your own class from TWebSessionData with whatever properties you like for your data. You must define published properties so that they are properly serialized and deserialized when using SaveSessionsToFile and LoadSessionsFromFile. You create an instance of your session data within the dynamic page that is the answer for the login form. Once initialized, you link your instance to the session by calling THttpAppSrv.CreateSession History: 16/09/2006 V1.01 Added THttpAppSrvConnection.BeforeGetHandler 11/04/2009 V1.02 Added runtime readonly property THttpAppsrv.WSessions Added overloaded CheckSession. Jun 12, 2009 V7.03 don't ignore event Flags in TriggerGetDocument otherwise authentication fails Jul 14, 2009 V7.04 F. Piette added THttpAppSrvConnection.OnDestroying and related processing. Sept 1, 2009 V7.05 Angus added TriggerHeadDocument, can not ignore HEAD command for virtual pages else 404 returned Added OnVirtualException event to report exceptions creating virtual pages Feb 05, 2010 V7.06 F. Piette added overloaded AnswerPage to get template from resource. Feb 08, 2010 V7.07 F. Piette fixed a bug introduced in 7.06 with ResType (Need to be PChar instead of PAnsiChar). Jan 27, 2010 V7.08 Arno - TUrlHandler.AnswerPage and TUrlHandler.AnswerString take optional code page parameter (D2009+ only). Dec 18, 2011 V7.09 F. Piette fixed THttpAppSrv.GetDispatchVirtualDocument so that OnDestroying is correct initialized. This prevent crashing when defered answer is used and client is gone at the time the answer is sent. May 2012 - V8.00 - Arno added FireMonkey cross platform support with POSIX/MacOS also IPv6 support, include files now in sub-directory New SocketFamily property (sfAny, sfAnyIPv4, sfAnyIPv6, sfIPv4, sfIPv6) New MultiListenSockets property to add extra listening sockets, each with Addr/Port/SocketFamily/SslEnable properties in events check MultiListenIndex, -1 is main socket, >=0 is index into MultiListenSockets[] for socket raising event Aug 17, 2012 V8.02 Angus added TSslHttpAppSrv SslEnable specifies if SSL is used and defaults to FALSE added MaxSessions to allow more than 100 web sessions Jun 09, 2013 V8.03 FPiette added TUrlHandler destructor to clear OnDestroying event handler in client's connection Nov 16, 2013 V8.04 Arno - Added property AppServer to the THttpAppSrvConnection. Added an OnDisplay event and a public method Display to THttAppSrv. Added a method Display to TUrlHandler. Mar 24, 2015 V8.05 Angus onSslServerName event added Apr 26, 2016 V8.06 Angus added OverbyteIcsFormDataDecoder to uses Apr 03, 2017 F. Piette made some THttpAppSrvConnection methods vitual: CancelSession, CheckSession and ValidateSession. TUrlHandler.ValidateSession is made virtual. Apr 11, 2017 V8.45 Added SSL IcsHosts property May 24, 2017 V8.48 Added HostTag parameter to AddGetHandler, AddPostHandler and AddGetAllowedPath which will cause that handler to be matched against an IcsHosts HostTag to support multiple hosts per server. Added IcsLoadTHttpAppSrvFromIni function which loads HttpAppSrv from an open INI file to simplify application creation. May 30, 2017 V8.48 PostDispatchVirtualDocument was broken in last update Jul 5, 2017 V8.49 Start is now a function, see HttpSrv Aug 10, 2017 V8.50 Corrected onSslServerName to OnSslServerName to keep C++ happy Jul 6, 2018 V8.56 Added OnSslAlpnSelect called after OnSslServerName for HTTP/2. Oct 10, 2018 V8.57 INI file now reads Options as enumerated type literals, ie Options=[hoContentEncoding,hoAllowDirList,hoSendServerHdr,hoAllowPut] INI file reads SslCliCertMethod, SslCertAutoOrder, CertExpireDays. FSessionTimer is now TIcsTimer so Vcl.ExtCtrls can disappear Oct 19, 2018 V8.58 INI file reads ListenBacklog. Nov 19, 2018 V8.59 Sanity checks reading mistyped enumerated values from INI file. Aug 7, 2019 V8.62 Builds without AUTO_X509_CERTS or USE_SSL Dec 23, 2019 V8.64 Ignore handler free errors. Jun 23, 2020 FPiette made TUrlHandler.CreateSession and THttpAppSrvConnection.CreateSession virtual methods. Dec 09, 2020 V8.65 Renamed Ics.Posix.Messages.pas to Ics.Posix.PXMessages.pas. Mar 11, 2021 V8.66 Added onBeforeCtxInit event which if set is called once before each IcsHosts SslContext is initialised to allow the context parameters to be adjusted for special ciphers or protocols. Jul 23, 2021 V8.67 Added NO_CACHE_EX as Cache-Control: no-cache to replace Pragma: no-cache. Added NO_STORE_EX as Cache-Control: no-store better than no-cache Added optional LastModified param to AnswerStream, AnswerPage, and AnswerString to avoid needing custom header line. Added PUT and DELETE verb handlers, similar to GET and POST. May 26, 2022 V8.69 Added OCSP (Online Certificate Status Protocol) support using the TOcspHttp. Read OcspSrvStapling property from INI file. Aug 08, 2023 V9.0 Updated version to major release 9. Dec 05, 2023 V9.1 Added properties PostedDataTB and PostedDataStr to return posted data in easier to use types than an PAnsiChar buffer. Added MaxUploadMB defaults to 200 MBbyte to restrict maximum size of POST or PUT requests. Added MaxStreamMB defaults to 50 MBbyte as the maximum TMemoryStream size before a TFileStream is instead used with a temporary file name. Added PostedDataStream to which POST and PUT content is written which is what TFormDataAnalyser needs, PostedData pointer now points to the stream memory rather than a stack buffer. This change allows file uploads larger than memory, up to MaxUploadSize. Added new property NoSSL that prevents use of HTTPS, must be set before server is started. INI file reads NoSSl, MaxUploadMB and MaxStreamMB. PUT requests now save uploaded data similarly to POST. Apr 17, 2024 V9.2 Builds with D7 again. POST and PUT template pages now correctly support authentication. Aug 09, 2024 V9.3 Using OverbyteIcsTypes for consolidated types and constants, allowing other import units to be removed. Nov 21, 2024 V9.4 Fixed memory leak with multiple virtual PUT and POST documents, thanks to Yves Vermeersch. Jun 25, 2025 V9.5 INI file reads AttachmentTypes. Added OCSP conditionals. Don't read DHParams from INI without DEFINE OpenSSL_Deprecated, no longer needed for modern cyphers. GetDispatchVirtualDocument and DeleteDispatchVirtualDocument now handle uploaded content similarly to POST/PUT, except it must be smaller than MaxStreamMB (50MB). Sep 25, 2025 V9.5 Updated IcsLoadTHttpAppSrvFromIni to read new default certificate properties for TSslWSocketServer, note these are only public in this component and not published so can not be set in the IDE. Mar 25, 2026 V9.6 New onDisplay event. Set WSDebugOptions from INI file. Renamed TWebSession/s to TIcsWebSession/s to avoid conflict with Delphi 13. Content Upload strategies Web clients can upload content to web servers using POST or PUT requests, provided there is a web page handler ready to receive the content and do something with it. With the basic THttpServer component, the application has events with user written code that handles all this upload activity. The THttpAppSrv component has page handling built-in, orginally for REST type applications with relatively small content sizes, to reduce the code needed in the application, specifically content is saved for later processing as AnsiString data in a stack memory. This AnsiString is then written to a disk file for simple uploads or if multipart/form-data written to a TStream for processing by the TFormDataAnalyser component that will save one or more parts as disk files. But this limits the size of uploads to memory. With V9.1, the THttpAppSrv component now saves content uploads directly to a TStream, by default a TMemoryStream but optionally a TFileStream if larger content is received, we should always know the actual content size from the request header. If the content size is more than MaxUploadSize (default 200MB) the request will fail with a 403 error, if more than MaxStreamSize (default 50MB) a temporary TFileStream will be created in the specified UploadDir defaulting to the system TEMP directory if blank. This stream can be passed to TFormDataAnalyser for saving as files and will be deleted afterwards, or renamed if being directly saved as a file. If the upload content is REST type parameters, Json, XML, etc, PostedDataTB and PostedDataStr return the content in easy to manipulate data types. Example from \Samples\Delphi\SslInternet\OverbyteIcsSslMultiWebServ.ini which can be read using the functions IcsLoadTHttpAppSrvFromIni and IcsLoadIcsHostsFromIni. [WebAppServer] MaxClients=200 MaxSessions= SessionTimeout=14400 ; CA root bundle to validate certificates and local chains RootCA=c:\certificates\RootCaCertsBundle.pem ; should maximum speed limit be imposed BandwidthLimitKB=0 ; how long idle clients should remain open KeepAliveTimeSec=60 ; how long active but stalled clients should remain open KeepAliveTimeXferSec=300 ; minimum and maxmum sized content to GZIP compress , no point in compressing ; small files, very large ones can take a long time and block server. SizeCompressMin=5000 SizeCompressMax=5000000 ; Header items that should be included in any response header PersistentHeader= ; multiple server Options: hoAllowDirList, hoAllowOutsideRoot, hoContentEncoding, hoAllowOptions, ; hoAllowPut, hoAllowDelete, hoAllowTrace, hoAllowPatch, hoAllowConnect, hoSendServerHdr, hoIgnoreIfModSince Options=[hoContentEncoding,hoSendServerHdr,hoAllowPut] ; should browser send certificate: sslCliCertNone, sslCliCertOptional, sslCliCertRequire SslCliCertMethod=sslCliCertNone ; how many new connections should be queued before rejecting new connections ListenBacklog=25 ; maximum upload content size in MBytes MaxUploadMB=205 ; maximum memory stream size in MBytes before temporary disk file is used MaxStreamMB=51 ; set true if no SSL/TLS connections allowed on port 443 or other ports NoSSL=False ; should server automatically order and install SSL certificates, also needs CertSupplierProto specified ; also needs a Certificate Supplier Account to be created first SslCertAutoOrder=True ; how many days before expiry of SSL certificates should warnings and AutoOrder start CertExpireDays=30 X509ProxyURL= SrvSupplierTitle=LetsEncrypt-New SrvAcmeSupplier=AcmeLetsEncrypt SrvAcmeCertProfile=tlsserver SrvAcmeCertValidity=90 SrvCertChallenge=ChallAlpnApp SrvCertPKeyType=PrivKeyECsecp256 SrvCertSignDigest=Digest_sha256 [Host4] Hosts=test7.ftptest.org,test7.ftptest.org.uk,test7.ftptest.co.uk HostTag=HTTP-FTPTEST Desc=test7-LetsEncrypt BindIpAddr=192.168.1.123 BindNonPort=80 BindSslPort=443 HostEnabled=False SslSecLevel=sslSrvSecInterFS WellKnownPath=c:\websites\well-known\ WebRedirectURL=https://www.telecom-tariffs.co.uk/ WebRedirectStat=301 SslCert=c:\certificates\local\test7_ftptest_org.pfx SslPassword=password CliCertMethod=sslCliCertNone CertSupplierProto=SuppProtoAcmeV2 {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *_*} {$IFNDEF ICS_INCLUDE_MODE} unit OverbyteIcsHttpAppServer; {$ENDIF} {$B-} { Enable partial boolean evaluation } {$T-} { Untyped pointers } {$X+} { Enable extended syntax } {$H+} { Use long strings } {$J+} { Allow typed constant to be modified } {$I Include\OverbyteIcsDefs.inc} {$IFDEF COMPILER14_UP} {$IFDEF NO_EXTENDED_RTTI} {$RTTI EXPLICIT METHODS([]) FIELDS([]) PROPERTIES([])} {$ENDIF} {$ENDIF} {$IFDEF DELPHI6_UP} {$WARN SYMBOL_PLATFORM OFF} {$WARN SYMBOL_LIBRARY OFF} {$WARN SYMBOL_DEPRECATED OFF} {$ENDIF} interface uses {$IFDEF MSWINDOWS} {$IFDEF RTL_NAMESPACES}Winapi.Windows{$ELSE}Windows{$ENDIF}, {$IFDEF RTL_NAMESPACES}Winapi.Messages{$ELSE}Messages{$ENDIF}, {$ENDIF} {$IFDEF POSIX} Ics.Posix.WinTypes, Ics.Posix.PXMessages, {$ENDIF} {$IFDEF RTL_NAMESPACES}System.SysUtils{$ELSE}SysUtils{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.TypInfo{$ELSE}TypInfo{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.IniFiles{$ELSE}IniFiles{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.Classes{$ELSE}Classes{$ENDIF}, {$IFDEF COMPILER7_UP} {$IFDEF RTL_NAMESPACES}System.StrUtils{$ELSE}StrUtils{$ENDIF}, {$ENDIF} // OverbyteIcsSSLEAY, OverbyteIcsLIBEAY, {$IFDEF FMX} FMX.Types, Ics.Fmx.OverbyteIcsWndControl, Ics.Fmx.OverbyteIcsWSocket, Ics.Fmx.OverbyteIcsWSocketS, { V9.5 } Ics.Fmx.OverbyteIcsHttpSrv, {$ELSE} OverbyteIcsWndControl, { V8.57 } OverbyteIcsWSocket, OverbyteIcsWSocketS, { V9.5 } OverbyteIcsHttpSrv, {$ENDIF} OverbyteIcsWebSession, OverbyteIcsUtils, OverbyteIcsFormDataDecoder, OverbyteIcsStreams, { V9.1 } OverbyteIcsCharSetUtils, { V9.1 } OverbyteIcsTypes; // for TBytes and TThreadID V9.2 type THttpAppSrvDisplayEvent = procedure(Sender : TObject; const Msg : String) of object; TVirtualExceptionEvent = procedure (Sender : TObject; E : Exception; Method : THttpMethod; const Path : string) of object; { V7.05 } TMyHttpHandler = procedure (var Flags: THttpGetFlag) of object; TUrlHandler = class; THttpAppSrv = class; THttpAppSrvConnection = class(THttpConnection) protected FOnDestroying : TNotifyEvent; FAppServer : THttpAppSrv; FPostedDataPtr : PAnsiChar; { V9.1 } FPostedDataTB : TBytes; { V9.1 } FPostedDataStr : String; { V9.1 } FRxBuffer : TBytes; { V9.1 } function GetHostName: String; function GetPostedData: PAnsiChar; { V9.1 } function GetPostedDataTB: TBytes; { V9.1 } function GetPostedDataStr: String; { V9.1 } public // PostedData : PAnsiChar; // Will hold dynamically allocated buffer { V9.1 now points to TBytes } PostedDataLen : Int64; // Keep track of received byte count. V9.1 was integer PostedDataStream: TStream; { V9.1 } PostTempName : String; { V9.1 } MaxPostMB : Integer; { V9.1 } WSessions : TIcsWebSessions; { V9.6 } WSession : TIcsWebSession; { V9.6 } WSessionID : String; WSessionCookie : String; destructor Destroy; override; function CreateSession(const Params : String; Expiration : TDateTime; SessionData : TWebSessionData) : String; virtual; function CancelSession : String; virtual; function CheckSession(var Flags : THttpGetFlag; const NegativeAnswerHtml : String) : Boolean; overload; virtual; function CheckSession(var Flags : THttpGetFlag; const Status : String; const Header : String; const NegativeAnswerHtml : String; UserData : TObject; Tags : array of const) : Boolean; overload; virtual; function ValidateSession: Boolean; virtual; procedure BeforeGetHandler(Proc : TMyHttpHandler; var OK : Boolean); virtual; procedure BeforeObjGetHandler(SObj : TUrlHandler; var OK : Boolean); virtual; procedure BeforePostHandler(Proc : TMyHttpHandler; var OK : Boolean); virtual; procedure BeforeObjPostHandler(SObj : TUrlHandler; var OK : Boolean); virtual; procedure NoGetHandler(var OK : Boolean); virtual; procedure BeforeDeleteHandler(Proc : TMyHttpHandler; var OK : Boolean); virtual; { V8.67 } procedure BeforeObjDeleteHandler(SObj : TUrlHandler; var OK : Boolean); virtual; { V8.67 } procedure BeforePutHandler(Proc : TMyHttpHandler; var OK : Boolean); virtual; { V8.67 } procedure BeforeObjPutHandler(SObj : TUrlHandler; var OK : Boolean); virtual; { V8.67 } property PostedData : PAnsiChar read GetPostedData; { V9.1 } property PostedDataTB : TBytes read GetPostedDataTB; { V9.1 } property PostedDataStr : String read GetPostedDataStr; { V9.1 } property HostName : String read GetHostName; property OnDestroying : TNotifyEvent read FOnDestroying write FOnDestroying; property AppServer : THttpAppSrv read FAppServer write FAppServer; end; THttpAllowedFlag = (afBeginBy, afExactMatch, afDirList); THttpAllowedElement = class Path : String; HostTag : String; { V8.48 } Flags : THttpAllowedFlag; end; THttpAllowedPath = class(TStringList) protected function GetElem(NItem: Integer): THttpAllowedElement; public destructor Destroy; override; property Elem[NItem: Integer] : THttpAllowedElement read GetElem; end; TUrlHandler = class(TComponent) protected FClient : THttpAppSrvConnection; FFlags : THttpGetFlag; FMsg_WM_FINISH : UINT; FWndHandle : HWND; FMethod : THttpMethod; function GetWSession: TIcsWebSession; function GetDocStream: TStream; procedure setDocStream(const Value: TStream); function GetOnGetRowData: THttpGetRowDataEvent; procedure SetOnGetRowData(const Value: THttpGetRowDataEvent); procedure ClientDestroying(Sender : TObject); virtual; public destructor Destroy; override; procedure Execute; virtual; procedure Finish; virtual; procedure Display(const AMsg: String); virtual; function CreateSession(const Params : String; Expiration : TDateTime; SessionData : TWebSessionData) : String; virtual; function ValidateSession: Boolean; virtual; procedure DeleteSession; function CheckSession(const NegativeAnswerHtml : String) : Boolean; overload; function CheckSession(const Status : String; const Header : String; const NegativeAnswerHtml : String; UserData : TObject; Tags : array of const) : Boolean; overload; // Answer a page from a template file procedure AnswerPage( const Status : String; // if empty, default to '200 OK' const Header : String; // Do not use Content-Length nor Content-Type const HtmlFile : String; UserData : TObject; Tags : array of const; {$IFDEF COMPILER12_UP} FileCodepage : LongWord = CP_ACP; DstCodepage : LongWord = CP_ACP; {$ENDIF} LastModified : TDateTime = 0); overload; virtual; { V8.67 } // Answer a page from a template resource procedure AnswerPage( const Status : String; // if empty, default to '200 OK' const Header : String; // Do not use Content-Length nor Content-Type const ResName : String; // Resource name const ResType : PChar; // Resource type UserData : TObject; Tags : array of const; {$IFDEF COMPILER12_UP} ResCodepage : LongWord = CP_ACP; DstCodepage : LongWord = CP_ACP; {$ENDIF} LastModified : TDateTime = 0); overload; virtual; { V8.67 } procedure AnswerStream(const Status : String; const ContType : String; const Header : String; LastModified : TDateTime = 0); virtual; { V8.67 } procedure AnswerString(const Status : String; const ContType : String; const Header : String; const Body : String; {$IFDEF COMPILER12_UP} BodyCodepage : LongWord = CP_ACP; {$ENDIF} LastModified : TDateTime = 0); virtual; { V8.67 } function GetParams: String; procedure SetParams(const Value: String); property Client : THttpAppSrvConnection read FClient; property Flags : THttpGetFlag read FFlags write FFlags; property Params : String read GetParams write SetParams; property WSession : TIcsWebSession read GetWSession; property DocStream : TStream read GetDocStream write setDocStream; property OnGetRowData : THttpGetRowDataEvent read GetOnGetRowData write SetOnGetRowData; end; THttpHandlerClass = class of TUrlHandler; THttpDispatchElement = class Path : String; HostTag : String; { V8.48 } FLags : THttpGetFlag; Proc : Pointer; SObjClass : THttpHandlerClass; end; THttpHandlerList = class(TStringList) protected function GetDisp(NItem: Integer): THttpDispatchElement; public destructor Destroy; override; property Disp[NItem: Integer] : THttpDispatchElement read GetDisp; end; ArrayOfTVarRec = array of TVarRec; TArrayOfConstBuilder = class(TObject) protected FArray : ArrayOfTVarRec; public destructor Destroy; override; procedure Add(const Value : String); overload; procedure Add(const Value : Integer); overload; procedure Add(const Value1, Value2 : String); overload; procedure Add(const Value1 : String; const Value2 : Integer); overload; property Value : ArrayOfTVarRec read FArray; end; TDeleteSessionEvent = procedure (Sender : TObject; Session : TIcsWebSession) of object; {$IFDEF USE_SSL} THttpAppSrv = class(TCustomSslHttpServer) // V8.02 Angus {$ELSE} THttpAppSrv = class(THttpServer) {$ENDIF USE_SSL} protected FGetHandler : THttpHandlerList; FPostHandler : THttpHandlerList; FDeleteHandler : THttpHandlerList; { V8.67 } FPutHandler : THttpHandlerList; { V8.67 } FGetAllowedPath : THttpAllowedPath; FWSessions : TIcsWebSessions; FSessionTimer : TIcsTimer; { V8.57 } FMaxUploadMB : Int64; { V9.1 100M } FMaxStreamMB : Int64; { V9.1 100M } FUploadDir : String; { V9.1, if blank used TEMP } FMsg_WM_FINISH : UINT; FHasAllocateHWnd : Boolean; FOnDeleteSession : TDeleteSessionEvent; FOnVirtualExceptionEvent : TVirtualExceptionEvent; { V7.05 } // FOnDisplay : THttpAppSrvDisplayEvent; { V9.6 now in THttpServer } procedure AllocateMsgHandlers; override; procedure FreeMsgHandlers; override; function MsgHandlersCount: Integer; override; procedure WndProc(var MsgRec: TMessage); override; procedure WMFinish(var msg: TMessage); function GetDispatchVirtualDocument(ClientCnx: THttpAppSrvConnection; var Flags: THttpGetFlag; ExecFlag: Boolean = True): Boolean; { V9.5 added Exec } function GetDispatchNormalDocument(ClientCnx: THttpConnection; var Flags: THttpGetFlag): Boolean; function PostDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag : Boolean): Boolean; function DeleteDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag: Boolean = True): Boolean; { V9.5 added Exec } function PutDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag : Boolean = False): Boolean; { V9.1 added Exec } procedure TriggerPostDocument(Sender : TObject; var Flags : THttpGetFlag); override; procedure TriggerGetDocument(Sender : TObject; var Flags : THttpGetFlag); override; procedure TriggerHeadDocument(Sender : TObject; var Flags : THttpGetFlag); override; procedure TriggerPostedData(Sender: TObject; ErrCode: WORD); override; procedure TriggerDeleteDocument(Sender : TObject; var Flags : THttpGetFlag); override; { V8.67 } procedure TriggerPutDocument(Sender : TObject; var Flags : THttpGetFlag); override; { V8.67 } procedure TriggerClientConnect(Client : TObject; ErrCode : WORD); override; function GetSessions(nIndex: Integer): TIcsWebSession; function GetSessionsCount: Integer; function GetSessionTimeout: Integer; procedure SetSessionTimeout(const Value: Integer); function GetMaxSessions: Integer; { V8.02 } procedure SetMaxSessions(const Value: Integer); { V8.02 } procedure DeleteSessionHandler(Sender: TObject; Session: TIcsWebSession); procedure SessionTimerHandler(Sender: TObject); public constructor Create(AOwner : TComponent); override; destructor Destroy; override; function Start(ReturnErrs: Boolean = false): String; override; { V8.49 made function } procedure Stop; override; procedure SaveSessionsToFile(const FileName : String); procedure LoadSessionsFromFile(const FileName : String); procedure ClearSessions; // procedure Display(Sender: TObject; const AMsg: String); now in THttpSever procedure AddGetHandler(const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } overload; procedure AddGetHandler(const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } overload; procedure AddGetAllowedPath(const Path : String; Flags : THttpAllowedFlag; HostTag : String = ''); { V8.48 } procedure AddPostHandler(const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } overload; procedure AddPostHandler(const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } overload; procedure AddDeleteHandler(const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.67 } overload; procedure AddDeleteHandler(const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.67 } overload; procedure AddPutHandler(const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.67 } overload; procedure AddPutHandler(const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.67 } overload; property SessionsCount : Integer read GetSessionsCount; property Sessions[nIndex : Integer] : TIcsWebSession read GetSessions; property WSessions : TIcsWebSessions read FWSessions; published property SessionTimeout : Integer read GetSessionTimeout write SetSessionTimeout; property MaxSessions : Integer read GetMaxSessions { V8.02 } write SetMaxSessions; property MaxUploadMB : Int64 read FMaxUploadMB write FMaxUploadMB; { V9.1 } property MaxStreamMB : Int64 read FMaxStreamMB write FMaxStreamMB; { V9.1 } property UploadDir : String read FUploadDir write FUploadDir; { V9.1 } property OnDeleteSession : TDeleteSessionEvent read FOnDeleteSession write FOnDeleteSession; property OnVirtualException : TVirtualExceptionEvent read FOnVirtualExceptionEvent write FOnVirtualExceptionEvent; { V7.05 } // property OnDisplay : THttpAppSrvDisplayEvent read FOnDisplay // write FOnDisplay; { V9.6 now in THttpServer } end; {$IFDEF USE_SSL} TSslHttpAppSrv = class(THttpAppSrv) // V8.02 Angus published property SslEnable; property SslContext; property IcsHosts; { V8.45 } property RootCA; { V8.45 } // property DHParams; { V8.45 } property SslCliCertMethod; { V8.57 } property SslCertAutoOrder; { V8.57 } property CertExpireDays; { V8.57 } {$IFDEF AUTO_X509_CERTS} { V8.62 } property SslX509Certs; { V8.57 } // property OcspSrvStapling; { V8.69 } // property OcspSrvHttp; { V8.69 } {$ENDIF} property OnSslVerifyPeer; property OnSslSetSessionIDContext; property OnSslSvrNewSession; property OnSslSvrGetSession; property OnSslHandshakeDone; property OnSslServerName; { V8.50 } property OnSslAlpnSelect; { V8.56 } property OnBeforeCtxInit; { V8.66 } property OnDisplay; { V9.6 } end; procedure IcsLoadTHttpAppSrvFromIni(MyIniFile: TCustomIniFile; HttpAppSrv: THttpAppSrv; const Section: String = 'HttpAppSrv'); { V8.48 } {$ENDIF} // USE_SSL const NO_CACHE: String = 'Pragma: no-cache' + #13#10 + 'Expires: -1' + #13#10; NO_CACHE_EX: String = 'Cache-Control: no-cache' + #13#10; { V8.67 the HTTP/1.1 version } NO_STORE_EX: String = 'Cache-Control: no-store' + #13#10; { V8.67 better than no-cache } implementation {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} constructor THttpAppSrv.Create(AOwner: TComponent); begin inherited Create(AOwner); // At time of writing, the ancestor class do not call AllocateHWnd, so // we must do it. Just chech Window Handle to avoid allocating twice... if FHandle = 0 then begin FHasAllocateHWnd := TRUE; AllocateHWnd; end; FGetHandler := THttpHandlerList.Create; FGetAllowedPath := THttpAllowedPath.Create; FPostHandler := THttpHandlerList.Create; FDeleteHandler := THttpHandlerList.Create; { V8.67 } FPutHandler := THttpHandlerList.Create; { V8.67 } FWSessions := TIcsWebSessions.Create(nil); FWSessions.OnDeleteSession := DeleteSessionHandler; FClientClass := THttpAppSrvConnection; FSessionTimer := TIcsTimer.Create(Self); { V8.57 } FSessionTimer.Enabled := FALSE; FSessionTimer.OnTimer := SessionTimerHandler; {$IFDEF USE_SSL} FHttpSslEnable := FALSE; // V8.02, renamed V8.50 FWSocketServer.SslEnable := FALSE; // V8.02 {$ENDIF} FMaxUploadMB := 200; { V9.1 } FMaxStreamMB := 50; { V9.1 } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} destructor THttpAppSrv.Destroy; begin try { V9.4 } FreeAndNil(FSessionTimer); FreeAndNil(FGetHandler); FreeAndNil(FGetAllowedPath); FreeAndNil(FPostHandler); FreeAndNil(FDeleteHandler); FreeAndNil(FPutHandler); FreeAndNil(FWSessions); finally inherited; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {procedure THttpAppSrv.Display(Sender: TObject; const AMsg: String); now in THttpSever begin if Assigned(FOnDisplay) then FOnDisplay(Sender, AMsg); end; } {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.MsgHandlersCount : Integer; begin Result := 1 + inherited MsgHandlersCount; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AllocateMsgHandlers; begin inherited AllocateMsgHandlers; FMsg_WM_FINISH := FWndHandler.AllocateMsgHandler(Self); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.FreeMsgHandlers; begin if Assigned(FWndHandler) then FWndHandler.UnregisterMessage(FMsg_WM_FINISH); inherited FreeMsgHandlers; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.WndProc(var MsgRec: TMessage); begin with MsgRec do begin { We *MUST* handle all exception to avoid application shutdown } if Msg = FMsg_WM_FINISH then begin try WMFinish(MsgRec) except on E:Exception do HandleBackGroundException(E); end; end else inherited WndProc(MsgRec); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.WMFinish(var Msg: TMessage); var SObj : TUrlHandler; I : Integer; begin SObj := TUrlHandler(Msg.LParam); if Assigned(SObj) then begin for I := 0 to ComponentCount - 1 do begin if SObj = Components[I] then begin SObj.Free; Exit; end; end; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.Start(ReturnErrs: Boolean = false): String; { V8.49 made function } begin FSessionTimer.Interval := 15000; FSessionTimer.Enabled := TRUE; Result := inherited Start(ReturnErrs); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.Stop; begin FSessionTimer.Enabled := FALSE; inherited Stop; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddGetHandler( const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; { V8.48 } Index := FGetHandler.IndexOf(Key); { V8.48 } if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FGetHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; { V8.48 } Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; FGetHandler.AddObject(Key, Disp); { V8.48 } end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddGetHandler( const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; { V8.48 } Index := FGetHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FGetHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; { V8.48 } Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; FGetHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddPostHandler( const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; { V8.48 } Index := FPostHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FPostHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.FLags := Flags; Disp.HostTag := HostTag; { V8.48 } Disp.Proc := nil; Disp.SObjClass := SObjClass; FPostHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddPostHandler( const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); { V8.48 } var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; { V8.48 } Index := FPostHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FPostHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; { V8.48 } Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; FPostHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddDeleteHandler( { V8.67 } const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; Index := FDeleteHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FDeleteHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; FDeleteHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddDeleteHandler( { V8.67 } const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; Index := FDeleteHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FDeleteHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; FDeleteHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddPutHandler( { V8.67 } const Path : String; Proc : Pointer; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; Index := FPutHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FPutHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; Disp.FLags := Flags; Disp.Proc := Proc; Disp.SObjClass := nil; FPutHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddPutHandler( { V8.67 } const Path : String; SObjClass : THttpHandlerClass; FLags : THttpGetFlag = hgWillSendMySelf; HostTag : String = ''); var Disp : THttpDispatchElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; Index := FPutHandler.IndexOf(Key); if Index >= 0 then begin // Already exists, update Disp := THttpDispatchElement(FPutHandler.Objects[Index]); Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; end else begin // Add a new entry Disp := THttpDispatchElement.Create; Disp.Path := Path; Disp.HostTag := HostTag; Disp.FLags := Flags; Disp.Proc := nil; Disp.SObjClass := SObjClass; FPutHandler.AddObject(Key, Disp); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {$IFNDEF COMPILER7_UP} function AnsiStartsText(const ASubText, AText: string): Boolean; var P: PChar; L, L2: Integer; begin P := PChar(AText); L := Length(ASubText); L2 := Length(AText); if L > L2 then Result := False else Result := CompareString(LOCALE_USER_DEFAULT, NORM_IGNORECASE, P, L, PChar(ASubText), L) = 2; end; {$ENDIF} {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.PostDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag : Boolean): Boolean; var Proc : TMethod; OK : Boolean; Disp : THttpDispatchElement; SObj : TUrlHandler; I, J : Integer; PathBuf : String; Status : Boolean; begin for I := 0 to FPostHandler.Count - 1 do begin Disp := FPostHandler.Disp[I]; { V8.48 } PathBuf := Disp.Path; { V8.48 } J := Length(PathBuf); if PathBuf[J] = '*' then begin SetLength(PathBuf, J - 1); Status := AnsiStartsText(PathBuf, ClientCnx.Path); end else Status := (CompareText(PathBuf, ClientCnx.Path) = 0); { V8.48 if HostTag specified, match it } {$IFDEF USE_SSL} if Status and (ClientCnx.HostTag <> '') and (Disp.HostTag <> '') then begin if (Disp.HostTag <> ClientCnx.HostTag) then Status := False; end; {$ENDIF} if Status then begin Result := TRUE; if ExecFlag then begin Disp := FPostHandler.Disp[I]; Flags := Disp.FLags; OK := TRUE; if Disp.Proc <> nil then begin Proc.Code := Disp.Proc; Proc.Data := ClientCnx; ClientCnx.BeforePostHandler(TMyHttpHandler(Proc), OK); if OK and (Proc.Code <> nil) then TMyHttpHandler(Proc)(Flags); end else if Disp.SObjClass <> nil then begin SObj := Disp.SObjClass.Create(Self); try SObj.FClient := ClientCnx; SObj.FFlags := Disp.FLags; SObj.FMsg_WM_FINISH := FMsg_WM_FINISH; SObj.FWndHandle := FHandle; SObj.FMethod := httpMethodPost; ClientCnx.OnDestroying := SObj.ClientDestroying; ClientCnx.BeforeObjPostHandler(SObj, OK); if OK then begin SObj.Execute; Flags := SObj.FFlags; end else begin Flags := SObj.FFlags; FreeAndNil(SObj); end; except on E:Exception do begin FreeAndNil(SObj); if Assigned (FOnVirtualExceptionEvent) then { V7.05 } FOnVirtualExceptionEvent (Self, E, httpMethodPost, ClientCnx.Path); end; end; end; end else begin { V9.1 abort request now if content too large } if (FMaxUploadMB > 0) and ((ClientCnx.RequestContentLength div IcsMBYTE) > FMaxUploadMB) then begin Flags := hg403; Exit; end; { V9.1 create stream, FileStream for very large content, otherwise MemoryStream } if Assigned(ClientCnx.PostedDataStream) then { V9.4 Yves Vermeersch } ClientCnx.PostedDataStream.Free; ClientCnx.MaxPostMB := FMaxStreamMB; if (FMaxStreamMB > 0) and ((ClientCnx.RequestContentLength div IcsMBYTE) > FMaxStreamMB) then begin if FUploadDir = '' then FUploadDir := IcsGetTempPath; FUploadDir := IncludeTrailingPathDelimiter(FUploadDir); ClientCnx.PostTempName := FUploadDir + 'ics-httpserv' + IntToStr(Random(999999999)) + '.tmp'; ClientCnx.PostedDataStream := TIcsBufferedFileStream.Create(ClientCnx.PostTempName, fmCreate OR fmShareDenyNone, MAX_BUFSIZE); end else begin ClientCnx.PostedDataStream := TMemoryStream.Create; TMemoryStream(ClientCnx.PostedDataStream).SetSize(ClientCnx.RequestContentLength); // ReallocMem(ClientCnx.PostedData, ClientCnx.RequestContentLength + 1); { V9.1 gone } end; { V9.1 content PostData pointer will be set if accessed, ditto TBytes and String version } ClientCnx.PostedDataLen := 0; ClientCnx.FPostedDataPtr := Nil; { V9.1 } SetLength(ClientCnx.FPostedDataTB, 0); { V9.1 } ClientCnx.FPostedDataStr := ''; { V9.1 } ClientCnx.FLineMode := FALSE; Flags := hgAcceptData; end; Exit; end; end; Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.PutDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag: Boolean = False): Boolean; { V9.1 added Exec } var I, J : Integer; PathBuf : String; Status : Boolean; Proc : TMethod; OK : Boolean; Disp : THttpDispatchElement; SObj : TUrlHandler; begin for I := 0 to FPutHandler.Count - 1 do begin Disp := FPutHandler.Disp[I]; PathBuf := Disp.Path; J := Length(PathBuf); if PathBuf[J] = '*' then begin SetLength(PathBuf, J - 1); Status := AnsiStartsText(PathBuf, ClientCnx.Path); end else Status := (CompareText(PathBuf, ClientCnx.Path) = 0); { if HostTag specified, match it } {$IFDEF USE_SSL} if Status and (ClientCnx.HostTag <> '') and (Disp.HostTag <> '') then begin if (Disp.HostTag <> ClientCnx.HostTag) then Status := False; end; {$ENDIF} if Status then begin Result := TRUE; if ExecFlag then begin { V9.1 support upload using PUT } Disp := FPutHandler.Disp[I]; Flags := Disp.FLags; OK := TRUE; if Disp.Proc <> nil then begin Proc.Code := Disp.Proc; Proc.Data := ClientCnx; ClientCnx.BeforePutHandler(TMyHttpHandler(Proc), OK); if OK and (Proc.Code <> nil) then TMyHttpHandler(Proc)(FLags); end else if Disp.SObjClass <> nil then begin SObj := Disp.SobjClass.Create(Self); try SObj.FClient := ClientCnx; SObj.FFlags := Disp.FLags; SObj.FMsg_WM_FINISH := FMsg_WM_FINISH; SObj.FWndHandle := FHandle; SObj.FMethod := httpMethodPut; ClientCnx.OnDestroying := SObj.ClientDestroying; ClientCnx.BeforeObjPutHandler(SObj, OK); if OK then begin SObj.Execute; Flags := SObj.FFlags; end else begin Flags := SObj.FFlags; FreeAndNil(SObj); end; except on E:Exception do begin FreeAndNil(SObj); if Assigned (FOnVirtualExceptionEvent) then FOnVirtualExceptionEvent (Self, E, httpMethodPut, ClientCnx.Path); end; end; end; end else begin { V9.1 support upload using PUT } { V9.1 abort request now if content too large } if (FMaxUploadMB > 0) and ((ClientCnx.RequestContentLength div IcsMBYTE) > FMaxUploadMB) then begin Flags := hg403; Exit; end; { V9.1 create stream, FileStream for very large content, otherwise MemoryStream } if Assigned(ClientCnx.PostedDataStream) then { V9.4 Yves Vermeersch } ClientCnx.PostedDataStream.Free; ClientCnx.MaxPostMB := FMaxStreamMB; if (FMaxStreamMB > 0) and ((ClientCnx.RequestContentLength div IcsMBYTE) > FMaxStreamMB) then begin if FUploadDir = '' then FUploadDir := IcsGetTempPath; FUploadDir := IncludeTrailingPathDelimiter(FUploadDir); ClientCnx.PostTempName := FUploadDir + 'ics-httpserv' + IntToStr(Random(999999999)) + '.tmp'; ClientCnx.PostedDataStream := TIcsBufferedFileStream.Create(ClientCnx.PostTempName, fmCreate OR fmShareDenyNone, MAX_BUFSIZE); end else begin ClientCnx.PostedDataStream := TMemoryStream.Create; TMemoryStream(ClientCnx.PostedDataStream).SetSize(ClientCnx.RequestContentLength); end; { V9.1 content PostData pointer will be set if accessed, ditto TBytes and String version } ClientCnx.PostedDataLen := 0; ClientCnx.FPostedDataPtr := Nil; { V9.1 } SetLength(ClientCnx.FPostedDataTB, 0); { V9.1 } ClientCnx.FPostedDataStr := ''; { V9.1 } ClientCnx.FLineMode := FALSE; Flags := hgAcceptData; end; Exit; end; end; Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.GetDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag: Boolean = True): Boolean; { V9.5 added Exec } var I, J : Integer; PathBuf : String; Status : Boolean; Proc : TMethod; OK : Boolean; Disp : THttpDispatchElement; SObj : TUrlHandler; begin for I := 0 to FGetHandler.Count - 1 do begin Disp := FGetHandler.Disp[I]; { V8.48 } PathBuf := Disp.Path; { V8.48 } J := Length(PathBuf); if PathBuf[J] = '*' then begin SetLength(PathBuf, J - 1); Status := AnsiStartsText(PathBuf, ClientCnx.Path); end else Status := (CompareText(PathBuf, ClientCnx.Path) = 0); { V8.48 if HostTag specified, match it } {$IFDEF USE_SSL} if Status and (ClientCnx.HostTag <> '') and (Disp.HostTag <> '') then begin if (Disp.HostTag <> ClientCnx.HostTag) then Status := False; end; {$ENDIF} if Status then begin Result := TRUE; if ExecFlag then begin { V9.5 support upload using GET } Disp := FGetHandler.Disp[I]; Flags := Disp.FLags; OK := TRUE; if Disp.Proc <> nil then begin Proc.Code := Disp.Proc; Proc.Data := ClientCnx; ClientCnx.BeforeGetHandler(TMyHttpHandler(Proc), OK); if OK and (Proc.Code <> nil) then TMyHttpHandler(Proc)(FLags); end else if Disp.SObjClass <> nil then begin SObj := Disp.SobjClass.Create(Self); try SObj.FClient := ClientCnx; SObj.FFlags := Disp.FLags; SObj.FMsg_WM_FINISH := FMsg_WM_FINISH; SObj.FWndHandle := FHandle; SObj.FMethod := httpMethodGet; ClientCnx.OnDestroying := SObj.ClientDestroying; ClientCnx.BeforeObjGetHandler(SObj, OK); if OK then begin SObj.Execute; Flags := SObj.FFlags; end else begin Flags := SObj.FFlags; FreeAndNil(SObj); end; except on E:Exception do begin FreeAndNil(SObj); if Assigned (FOnVirtualExceptionEvent) then { V7.05 } FOnVirtualExceptionEvent (Self, E, httpMethodGet, ClientCnx.Path); end; end; end; end else begin { V9.5 support small upload using GET } { abort request now if content too large for stream } if (FMaxStreamMB > 0) and ((ClientCnx.RequestContentLength div IcsMBYTE) > FMaxStreamMB) then begin Flags := hg403; Exit; end; ClientCnx.PostedDataStream := TMemoryStream.Create; TMemoryStream(ClientCnx.PostedDataStream).SetSize(ClientCnx.RequestContentLength); { content PostData pointer will be set if accessed, ditto TBytes and String version } ClientCnx.PostedDataLen := 0; ClientCnx.FPostedDataPtr := Nil; SetLength(ClientCnx.FPostedDataTB, 0); ClientCnx.FPostedDataStr := ''; ClientCnx.FLineMode := FALSE; Flags := hgAcceptData; end; Exit; end; end; Result := FALSE; ClientCnx.NoGetHandler(Result); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.GetDispatchNormalDocument(ClientCnx : THttpConnection; var Flags : THttpGetFlag) : Boolean; var I : Integer; Elem : THttpAllowedElement; begin for I := 0 to FGetAllowedPath.Count - 1 do begin Elem := FGetAllowedPath.Elem[I]; { V8.48 if HostTag specified, match it } {$IFDEF USE_SSL} if (ClientCnx.HostTag <> '') and (Elem.HostTag <> '') then begin if (Elem.HostTag <> ClientCnx.HostTag) then Continue; end; {$ENDIF} case Elem.Flags of afBeginBy: begin if AnsiStartsText(Elem.Path, ClientCnx.Path) then begin Flags := hgSendDoc; Result := TRUE; Exit; end; end; afExactMatch: begin if CompareText(Elem.Path, ClientCnx.Path) = 0 then begin Flags := hgSendDoc; Result := TRUE; Exit; end; end; afDirList: begin if CompareText(Elem.Path, ClientCnx.Path) = 0 then begin Flags := hgSendDirList; Result := TRUE; Exit; end; end; end; end; Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.DeleteDispatchVirtualDocument(ClientCnx : THttpAppSrvConnection; var Flags : THttpGetFlag; ExecFlag: Boolean = True): Boolean; { V9.1 added Exec } var I, J : Integer; PathBuf : String; Status : Boolean; Proc : TMethod; OK : Boolean; Disp : THttpDispatchElement; SObj : TUrlHandler; begin for I := 0 to FDeleteHandler.Count - 1 do begin Disp := FDeleteHandler.Disp[I]; PathBuf := Disp.Path; J := Length(PathBuf); if PathBuf[J] = '*' then begin SetLength(PathBuf, J - 1); Status := AnsiStartsText(PathBuf, ClientCnx.Path); end else Status := (CompareText(PathBuf, ClientCnx.Path) = 0); { if HostTag specified, match it } {$IFDEF USE_SSL} if Status and (ClientCnx.HostTag <> '') and (Disp.HostTag <> '') then begin if (Disp.HostTag <> ClientCnx.HostTag) then Status := False; end; {$ENDIF} if Status then begin Result := TRUE; if ExecFlag then begin { V9.5 support upload using DELETE } Disp := FDeleteHandler.Disp[I]; Flags := Disp.FLags; OK := TRUE; if Disp.Proc <> nil then begin Proc.Code := Disp.Proc; Proc.Data := ClientCnx; ClientCnx.BeforeDeleteHandler(TMyHttpHandler(Proc), OK); if OK and (Proc.Code <> nil) then TMyHttpHandler(Proc)(FLags); end else if Disp.SObjClass <> nil then begin SObj := Disp.SobjClass.Create(Self); try SObj.FClient := ClientCnx; SObj.FFlags := Disp.FLags; SObj.FMsg_WM_FINISH := FMsg_WM_FINISH; SObj.FWndHandle := FHandle; SObj.FMethod := httpMethodDelete; ClientCnx.OnDestroying := SObj.ClientDestroying; ClientCnx.BeforeObjDeleteHandler(SObj, OK); if OK then begin SObj.Execute; Flags := SObj.FFlags; end else begin Flags := SObj.FFlags; FreeAndNil(SObj); end; except on E:Exception do begin FreeAndNil(SObj); if Assigned (FOnVirtualExceptionEvent) then FOnVirtualExceptionEvent (Self, E, httpMethodDelete, ClientCnx.Path); end; end; end; end else begin { V9.5 support small upload using DELETE } { abort request now if content too large for stream } if (FMaxStreamMB > 0) and ((ClientCnx.RequestContentLength div IcsMBYTE) > FMaxStreamMB) then begin Flags := hg403; Exit; end; ClientCnx.PostedDataStream := TMemoryStream.Create; TMemoryStream(ClientCnx.PostedDataStream).SetSize(ClientCnx.RequestContentLength); { content PostData pointer will be set if accessed, ditto TBytes and String version } ClientCnx.PostedDataLen := 0; ClientCnx.FPostedDataPtr := Nil; SetLength(ClientCnx.FPostedDataTB, 0); ClientCnx.FPostedDataStr := ''; ClientCnx.FLineMode := FALSE; Flags := hgAcceptData; end; Exit; end; end; Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerGetDocument(Sender : TObject; var Flags : THttpGetFlag); var NoUpload: Boolean; ClientCnx: THttpAppSrvConnection; begin inherited TriggerGetDocument(Sender, Flags); if Flags in [hgWillSendMySelf, hg404, hg403, hg401, hgAcceptData, hgSendDirList] then { V7.03 don't ignore Flags } Exit ; // Handle all virtual documents. Returns TRUE if document handled. ClientCnx := Sender as THttpAppSrvConnection; NoUpload := (ClientCnx.RequestContentLength = 0); { V9.5 see if GET has content length header } if GetDispatchVirtualDocument(ClientCnx, Flags, NoUpload) then Exit; // Handle all normal (static) documents. Returns TRUE if document handled. if GetDispatchNormalDocument(ClientCnx, Flags) then Exit; // Reject anything else Flags := hg404; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerHeadDocument(Sender: TObject;var Flags: THttpGetFlag); begin inherited TriggerHeadDocument(Sender, Flags); if Flags in [hgWillSendMySelf, hg404, hg403, hg401, hgAcceptData, hgSendDirList] then Exit ; // Handle all virtual documents. Returns TRUE if document handled. if GetDispatchVirtualDocument(Sender as THttpAppSrvConnection, Flags) then Exit; // Handle all normal (static) documents. Returns TRUE if document handled. if GetDispatchNormalDocument(Sender as THttpConnection, Flags) then Exit; // Reject anything else Flags := hg404; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerPostDocument( Sender : TObject; var Flags : THttpGetFlag); begin inherited TriggerPostDocument(Sender, Flags); if Flags in [hgWillSendMySelf, hg404, hg403, hg401] then { V9.2 } Exit ; // Handle all virtual documents. Returns TRUE if document handled. if PostDispatchVirtualDocument(Sender as THttpAppSrvConnection, Flags, FALSE) then // no upload data Exit; // Reject anything else - static documents not allowed for POST since they can not accept data Flags := hg404; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerDeleteDocument( { V8.67 } Sender : TObject; var Flags : THttpGetFlag); begin inherited TriggerDeleteDocument(Sender, Flags); if Flags in [hgWillSendMySelf, hg404, hg403, hg401] then Exit ; // Handle all virtual documents. Returns TRUE if document handled. if DeleteDispatchVirtualDocument(Sender as THttpAppSrvConnection, Flags) then Exit; // Reject anything else - static documents not allowed Flags := hg404; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerPutDocument( { V8.67 } Sender : TObject; var Flags : THttpGetFlag); begin inherited TriggerPutDocument(Sender, Flags); if Flags in [hgWillSendMySelf, hg404, hg403, hg401] then { V9.2 } Exit ; // Handle all virtual documents. Returns TRUE if document handled. if PutDispatchVirtualDocument(Sender as THttpAppSrvConnection, Flags, FALSE) then // no upload data Exit; // Reject anything else - static documents not allowed Flags := hg404; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} destructor THttpHandlerList.Destroy; var I : Integer; begin for I := Count - 1 downto 0 do begin if Assigned(Objects[I]) then begin try Objects[I].Free; except { V8.64 ignore errors } end; Objects[I] := nil; end; Self.Delete(I); end; inherited Destroy; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpHandlerList.GetDisp(NItem: Integer): THttpDispatchElement; begin Result := Objects[NItem] as THttpDispatchElement; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.AddGetAllowedPath( const Path : String; Flags : THttpAllowedFlag; HostTag : String = ''); { V8.48 } var Item : THttpAllowedElement; Index : Integer; Key : String; begin Key := {$IFDEF POSIX}Path{$ELSE}IcsUpperCase(Path){$ENDIF} + '|' + HostTag; Index := FGetAllowedPath.IndexOf(Key); { V8.48 } if Index >= 0 then begin // Update the element if the path already exists Item := THttpAllowedElement(FGetAllowedPath.Objects[Index]); Item.Flags := Flags; end else begin // Create a new element if path doesn't exist yet Item := THttpAllowedElement.Create; Item.Path := Path; Item.HostTag := HostTag; { V8.48 } Item.Flags := Flags; FGetAllowedPath.AddObject(Key, Item); end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} destructor THttpAllowedPath.Destroy; var I : Integer; begin for I := Count - 1 downto 0 do begin if Assigned(Objects[I]) then begin Objects[I].Free; Objects[I] := nil; end; Self.Delete(I); end; inherited Destroy; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAllowedPath.GetElem(NItem: Integer): THttpAllowedElement; begin Result := Objects[NItem] as THttpAllowedElement; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerPostedData( Sender : TObject; ErrCode : WORD); var Len : Integer; Remains : Int64; { V9.1 } ClientCnx : THttpAppSrvConnection; Dummy : THttpGetFlag; begin ClientCnx := Sender as THttpAppSrvConnection; if NOT Assigned(ClientCnx.FRxBuffer) then SetLength(ClientCnx.FRxBuffer, MAX_BUFSIZE); { V9.1 new buffer } { How much data do we have to receive ? } Remains := ClientCnx.RequestContentLength - ClientCnx.PostedDataLen; if Remains <= 0 then begin { We got all our data. Junk anything else ! } ClientCnx.ReceiveTB(ClientCnx.FRxBuffer, MAX_BUFSIZE); { V9.1 new buffer } ClientCnx.PostedDataReceived; { V9.2 } Exit; end; { Receive as much data as we need to receive. But warning: we may } { receive much less data. Data will be split into several packets we } { have to assemble in our buffer. } // Len := ClientCnx.Receive(ClientCnx.PostedData + ClientCnx.PostedDataLen, Remains); { V9.1 read local buffer and write stream, might be TFileStream } while (Remains > 0) do begin Len := ClientCnx.ReceiveTB(ClientCnx.FRxBuffer, MAX_BUFSIZE); { Sometimes, winsock doesn't wants to givve any data... } if Len <= 0 then Break; ClientCnx.PostedDataStream.Write(ClientCnx.FRxBuffer, Len); { Add received length to our count } Inc(ClientCnx.PostedDataLen, Len); Remains := Remains - Len; { Add a nul terminating byte (handy to handle data as a string) } // ClientCnx.PostedData[ClientCnx.PostedDataLen] := #0; { V9.1 not a string } end; { When we received the whole thing, we can process it } if ClientCnx.PostedDataLen = ClientCnx.RequestContentLength then begin ClientCnx.PostedDataStream.Position := 0; { back to start } { First we must tell the component that we've got all the data } ClientCnx.PostedDataReceived; // Execute the request if (ClientCnx.RequestMethod = httpMethodPost) then begin if PostDispatchVirtualDocument(ClientCnx, Dummy, TRUE) then Exit; end; if (ClientCnx.RequestMethod = httpMethodPut) then begin { V9.1 handle PUT uploads } if PutDispatchVirtualDocument(ClientCnx, Dummy, TRUE) then Exit; end; if (ClientCnx.RequestMethod = httpMethodGet) then begin { V9.5 handle GET uploads } if GetDispatchVirtualDocument(ClientCnx, Dummy, TRUE) then Exit; end; ClientCnx.Answer404; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} destructor THttpAppSrvConnection.Destroy; begin if Assigned(FOnDestroying) then FOnDestroying(Self); { if Assigned(PostedData) then begin FreeMem(PostedData); PostedData := nil; PostedDataLen := 0; end; } if Assigned(PostedDataStream) then begin { V9.1 } PostedDataStream.Free; PostedDataStream := Nil; end; if (PostTempName <> '') and FileExists(PostTempName) then { V9.1 } IcsDeleteFile(PostTempName, True); PostTempName := ''; inherited Destroy; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} // CreateSession is intented to create a new session and return a cookie with // the session ID. Usually CreateSession is called to provide third argument // to AnswerPage when login user/pass are correct. See CancelSession for the // case where user/pass is invalid. function THttpAppSrvConnection.CreateSession( const Params : String; // Used to create the SessionID Expiration : TDateTime; // Cookie expiration SessionData : TWebSessionData) : String; // Optional session data begin WSession := WSessions.CreateSession(Params, WSessionID); WSession.SessionData := SessionData; WSessions.ReleaseSession(@WSession); if Expiration <> 0 then { 26/08/04 } Expiration := Expiration + Now; Result := NO_CACHE + MakeCookie(WSessionCookie, WSessionID, Expiration, '/') end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} // CancelSession is intended to delete an existing session and create an // expired cookie to be sent back to the client. CancelSession is usually // called to provide third argument to AnswerPage when login user/pass are // not correct. See CreateSession for the case where user/pass are correct. function THttpAppSrvConnection.CancelSession : String; begin GetCookieValue(RequestCookies, WSessionCookie, WSessionID); WSessions.DeleteSession(WSessionID); WSession := nil; Result := NO_CACHE + MakeCookie(WSessionCookie, '0', EncodeDate(2000, 1, 1), '/'); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} // Extract session ID information from cookie // Validate session ID again session list // Return TRUE is valid session found // ValidateSession is normally called from the login processor to delete any // existing session before creating a new one. function THttpAppSrvConnection.ValidateSession : Boolean; begin GetCookieValue(FRequestCookies, WSessionCookie, WSessionID); WSession := WSessions.FindSession(WSessionID); // FindSession will check if session is expired and return nil if so Result := Assigned(WSession); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} // Same as ValidateSession except it will send a reply when session is // invalid. Usually the reply is a page telling telling the user to logon. // CheckSession is normally called in the very beginning of processing for // all pages that must be protected by a valid session. function THttpAppSrvConnection.CheckSession( var Flags : THttpGetFlag; const NegativeAnswerHtml : String): Boolean; begin Result := ValidateSession; if (not Result) and (NegativeAnswerHtml <> '') then AnswerPage(Flags, '', NO_CACHE, NegativeAnswerHtml, nil, []); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} // Same as ValidateSession except it will send a reply when session is // invalid. Usually the reply is a page telling telling the user to logon. // CheckSession is normally called in the very beginning of processing for // all pages that must be protected by a valid session. function THttpAppSrvConnection.CheckSession( var Flags : THttpGetFlag; const Status : String; { if empty, default to '200 OK' } const Header : String; { Do not use Content-Length nor Content-Type } const NegativeAnswerHtml : String; UserData : TObject; Tags : array of const) : Boolean; begin Result := ValidateSession; if (not Result) and (NegativeAnswerHtml <> '') then AnswerPage(Flags, Status, Header, NegativeAnswerHtml, UserData, Tags); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.TriggerClientConnect(Client: TObject; ErrCode: WORD); begin (Client as THttpAppSrvConnection).WSessions := FWSessions; (Client as THttpAppSrvConnection).WSessionCookie := 'IcsWebCookie' + Port; (Client as THttpAppSrvConnection).AppServer := Self; inherited TriggerClientConnect(Client, ErrCode); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrvConnection.GetHostName: String; begin Result := AnsiToUnicode(WSocketResolveIp(AnsiString(PeerAddr))); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { V9.1 get posted data as TBytes from string } { if content larger then 50MB only get that much data } function THttpAppSrvConnection.GetPostedDataTB: TBytes; var MaxLen: Int64; begin if NOT Assigned(FPostedDataTB) then SetLength(FPostedDataTB, 0); if (Length(FPostedDataTB) = 0) then begin MaxLen := PostedDataLen; if (MaxPostMB = 0) then // should be set to MaxStreamMB MaxPostMB := 10; if (MaxLen > (MaxPostMB * IcsMBYTE)) then MaxLen := MaxPostMB * IcsMBYTE; SetLength(FPostedDataTB, MaxLen + 1); if PostedDataLen = 0 then SetLength(FPostedDataTB, 0) else begin PostedDataStream.Position := 0; PostedDataStream.Read(FPostedDataTB[0], MaxLen); PostedDataStream.Position := 0; end; FPostedDataTB[MaxLen] := 0; // trailing null for AnsiString casting SetLength(FPostedDataTB, MaxLen); end; Result := FPostedDataTB; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { V9.1 get posted data as TBytes } { beware fails if content length over MaxStreamSize since we have a filestream } function THttpAppSrvConnection.GetPostedData: PAnsiChar; { V9.1 } begin if (FPostedDataPtr = Nil) and (PostedDataLen > 0) then begin GetPostedDataTB; FPostedDataPtr := @FPostedDataTB[0]; end; Result := FPostedDataPtr; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { V9.1 get posted data as String, keeping embedded nulls } { works with Ansi or Unicode strings, but no unicode conversion } function THttpAppSrvConnection.GetPostedDataStr: String; begin if (FPostedDataStr = '') and (PostedDataLen > 0) and Assigned(PostedData) then begin IcsMoveTBytesToString(GetPostedDataTB, 0, FPostedDataStr, 1, PostedDataLen); end; Result := FPostedDataStr; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.SaveSessionsToFile(const FileName: String); begin if Assigned(FWSessions) then FWSessions.SaveToFile(FileName); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.LoadSessionsFromFile(const FileName: String); begin if Assigned(FWSessions) then FWSessions.LoadFromFile(FileName); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.ClearSessions; begin if Assigned(FWSessions) then FWSessions.Clear; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.GetSessions(nIndex: Integer): TIcsWebSession; begin if not Assigned(FWSessions) then Result := nil else begin if (nIndex < 0) or (nIndex >= FWSessions.Count) then raise ERangeError.Create('THttpAppSrv.Sessions[' + IntToStr(nIndex) + ']: Index out of range'); Result := FWSessions.Sessions[nIndex]; end; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.GetSessionsCount: Integer; begin if not Assigned(FWSessions) then Result := 0 else Result := FWSessions.Count; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.GetSessionTimeout: Integer; begin if not Assigned(FWSessions) then Result := 0 else Result := FWSessions.MaxAge; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.SetSessionTimeout(const Value: Integer); begin if Assigned(FWSessions) then FWSessions.MaxAge := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function THttpAppSrv.GetMaxSessions: Integer; begin if not Assigned(FWSessions) then Result := 0 else Result := FWSessions.MaxSessions; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.SetMaxSessions(const Value: Integer); begin if Assigned(FWSessions) then FWSessions.MaxSessions := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} // DeleteSessionHandler is called when FTimeList delete a session, for example // when a session has expired or when the component is destroyed while sessions // are still active procedure THttpAppSrv.DeleteSessionHandler( Sender : TObject; Session : TIcsWebSession); begin if Assigned(FOnDeleteSession) then FOnDeleteSession(Self, Session); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrv.SessionTimerHandler(Sender : TObject); begin if Assigned(FWSessions) then FWSessions.RemoveAged; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforeGetHandler( Proc : TMyHttpHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforeObjGetHandler( SObj : TUrlHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforePostHandler( Proc : TMyHttpHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforeObjPostHandler( SObj : TUrlHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.NoGetHandler(var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforeDeleteHandler( { V8.67 } Proc : TMyHttpHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforeObjDeleteHandler( { V8.67 } SObj : TUrlHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforePutHandler( { V8.67 } Proc : TMyHttpHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure THttpAppSrvConnection.BeforeObjPutHandler( { V8.67 } SObj : TUrlHandler; var OK : Boolean); begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.Execute; begin // Nothing to do here, just to allow overriden method end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.Finish; begin // We need to destroy the server object, but we can't do it safely from // one of his methods. Delaying the detroy until all queued events are // processed is better. This is why we use an intermediate message. if (FWndHandle <> 0) and (FMsg_WM_FINISH > 0) then PostMessage(FWndHandle, FMsg_WM_FINISH, 0, LPARAM(Self)); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.ClientDestroying(Sender : TObject); begin if FClient = Sender then FClient := nil; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.GetDocStream: TStream; begin if Assigned(Client) then Result := Client.DocStream else Result := nil; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.GetOnGetRowData: THttpGetRowDataEvent; begin if Assigned(Client) then Result := Client.OnGetRowData else Result := nil; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.SetOnGetRowData(const Value: THttpGetRowDataEvent); begin if Assigned(Client) then Client.OnGetRowData := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.SetDocStream(const Value: TStream); begin if Assigned(Client) then Client.DocStream := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.GetWSession: TIcsWebSession; begin if Assigned(Client) then Result := Client.WSession else Result := nil; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.GetParams: String; begin if Assigned(Client) then Result := Client.Params else Result := ''; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.SetParams(const Value: String); begin if Assigned(Client) then Client.Params := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.AnswerPage( const Status, Header, HtmlFile: String; UserData: TObject; Tags: array of const; {$IFDEF COMPILER12_UP} FileCodepage : LongWord = CP_ACP; DstCodepage : LongWord = CP_ACP; {$ENDIF} LastModified : TDateTime = 0); { V8.67 } begin if Assigned(Client) then Client.AnswerPage(FFlags, Status, Header, HtmlFile, UserData, Tags, {$IFDEF COMPILER12_UP} FileCodepage, DstCodepage, {$ENDIF} LastModified); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.AnswerPage( const Status : String; // if empty, default to '200 OK' const Header : String; // Do not use Content-Length nor Content-Type const ResName : String; // Resource name const ResType : PChar; // Resource type UserData : TObject; Tags : array of const; {$IFDEF COMPILER12_UP} ResCodepage : LongWord = CP_ACP; DstCodepage : LongWord = CP_ACP; {$ENDIF} LastModified : TDateTime = 0); { V8.67 } begin if Assigned(Client) then Client.AnswerPage(FFlags, Status, Header, ResName, ResType, UserData, Tags, {$IFDEF COMPILER12_UP} ResCodepage, DstCodepage, {$ENDIF} LastModified); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.AnswerStream(const Status, ContType, Header: String; LastModified : TDateTime = 0); { V8.67 } begin if Assigned(Client) then Client.AnswerStream(FFlags, Status, ContType, Header, LastModified); { V8.67 } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.AnswerString( const Status, ContType, Header, Body: String; {$IFDEF COMPILER12_UP} BodyCodepage : LongWord = CP_ACP; {$ENDIF} LastModified : TDateTime = 0); { V8.67 } begin if Assigned(Client) then {$IFDEF COMPILER12_UP} Client.AnswerStringEx(FFlags, Status, ContType, Header, Body, BodyCodepage, LastModified); {$ELSE} Client.AnswerString(FFlags, Status, ContType, Header, Body, LastModified); { V8.67 } {$ENDIF} end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.CheckSession(const NegativeAnswerHtml: String): Boolean; begin if Assigned(Client) then Result := Client.CheckSession(FFlags, NegativeAnswerHtml) else Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.CheckSession( const Status, Header, NegativeAnswerHtml: String; UserData: TObject; Tags: array of const): Boolean; begin if Assigned(Client) then Result := Client.CheckSession(FFlags, Status, Header, NegativeAnswerHtml, UserData, Tags) else Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.CreateSession( const Params: String; Expiration: TDateTime; SessionData: TWebSessionData): String; begin if Assigned(Client) then Result := Client.CreateSession(Params, Expiration, SessionData) else Result := NO_CACHE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.DeleteSession; begin if Assigned(Client) then Client.WSessions.DeleteSession(Client.WSessionID); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} destructor TUrlHandler.Destroy; var T1 : TNotifyEvent; T2 : TNotifyEvent; begin if Assigned(FClient) then begin { V8.03 } // Clear client's connection event handler if it points to us T1 := FClient.OnDestroying; { V8.03 } T2 := ClientDestroying; { V8.03 } if @T1 = @T2 then { V8.03 } FClient.OnDestroying := nil; { V8.03 } end; { V8.03 } inherited Destroy; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TUrlHandler.Display(const AMsg: String); begin if Assigned(FClient) and Assigned(FClient.AppServer) then FClient.AppServer.TriggerDisplay(Self, AMsg); { V9.6 } end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TUrlHandler.ValidateSession: Boolean; begin if Assigned(Client) then Result := Client.ValidateSession else Result := FALSE; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} { TArrayOfConstBuilder } procedure TArrayOfConstBuilder.Add(const Value: String); var L : Integer; P : PChar; begin GetMem(P, SizeOf(Char) * (Length(Value) + 1)); StrCopy(P, PChar(Value)); L := Length(FArray); SetLength(FArray, L + 1); {$IF SizeOf(Char) = 2} FArray[L].VType := vtUnicodeString; FArray[L].VUnicodeString := P; {$ELSE} FArray[L].VType := vtPChar; FArray[L].VPChar := P; {$IFEND} end; procedure TArrayOfConstBuilder.Add(const Value: Integer); begin Add(IntToStr(Value)); end; procedure TArrayOfConstBuilder.Add(const Value1, Value2: String); begin Add(Value1); Add(Value2); end; procedure TArrayOfConstBuilder.Add(const Value1: String; const Value2: Integer); begin Add(Value1); Add(Value2); end; destructor TArrayOfConstBuilder.Destroy; var I : Integer; P : PChar; begin for I := 0 to Length(FArray) - 1 do begin {$IF SizeOf(Char) = 2} if FArray[I].VType = vtUnicodeString then begin P := FArray[I].VUnicodeString; if Assigned(P) then begin FreeMem(P); FArray[I].VUnicodeString := nil; end; end; {$ELSE} if FArray[I].VType = vtPChar then begin P := FArray[I].VPChar; if Assigned(P) then begin FreeMem(P); FArray[I].VPChar := nil; end; end; {$IFEND} end; inherited Destroy; end; {$IFDEF USE_SSL} {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure IcsLoadTHttpAppSrvFromIni(MyIniFile: TCustomIniFile; HttpAppSrv: THttpAppSrv; const Section: String = 'HttpAppSrv'); begin if NOT Assigned (MyIniFile) then raise ESocketException.Create('Must open and assign INI file first'); if NOT Assigned (HttpAppSrv) then raise ESocketException.Create('Must assign HttpAppSrv first'); with HttpAppSrv do begin MaxClients := MyIniFile.ReadInteger(Section, 'MaxClients', MaxClients); DocDir := IcsTrim(MyIniFile.ReadString(Section, 'DocDir', DocDir)); TemplateDir := IcsTrim(MyIniFile.ReadString(Section, 'TemplateDir', TemplateDir)); DefaultDoc := IcsTrim(MyIniFile.ReadString(Section, 'DefaultDoc', DefaultDoc)); KeepAliveTimeSec := MyIniFile.ReadInteger(Section, 'KeepAliveTimeSec', KeepAliveTimeSec); KeepAliveTimeXferSec := MyIniFile.ReadInteger(Section, 'KeepAliveTimeXferSec',KeepAliveTimeXferSec); MaxRequestsKeepAlive := MyIniFile.ReadInteger(Section, 'MaxRequestsKeepAlive', MaxRequestsKeepAlive); SizeCompressMin := MyIniFile.ReadInteger(Section, 'SizeCompressMin', SizeCompressMin); SizeCompressMax := MyIniFile.ReadInteger(Section, 'SizeCompressMax', SizeCompressMax); PersistentHeader := IcsTrim(MyIniFile.ReadString(Section, 'PersistentHeader', PersistentHeader)); MaxBlkSize := MyIniFile.ReadInteger(Section, 'MaxBlkSize', MaxBlkSize); BandwidthLimit := MyIniFile.ReadInteger(Section, 'BandwidthLimit', BandwidthLimit); BandwidthSampling := MyIniFile.ReadInteger(Section, 'BandwidthSampling', BandwidthSampling); ServerHeader := IcsTrim(MyIniFile.ReadString(Section, 'ServerHeader', ServerHeader)); // RootCA := IcsTrim(MyIniFile.ReadString(Section, 'RootCA', '')); {$IFDEF OpenSSL_Deprecated} { V9.5 } // DHParams := IcsTrim(MyIniFile.ReadString(Section, 'DHParams', '')); {$ENDIF OpenSSL_Deprecated} { V9.5 } SessionTimeout := MyIniFile.ReadInteger(Section, 'SessionTimeout', SessionTimeout); MaxSessions := MyIniFile.ReadInteger(Section, 'MaxSessions', MaxSessions); SslCliCertMethod := TSslCliCertMethod(GetEnumValue (TypeInfo (TSslCliCertMethod), IcsTrim(MyIniFile.ReadString(section, 'SslCliCertMethod', 'sslCliCertNone')))); { V8.57 } if SslCliCertMethod > High(TSslCliCertMethod) then SslCliCertMethod := sslCliCertNone; { V8.59 sanity test } SslCertAutoOrder := IcsCheckTrueFalse(MyIniFile.ReadString (section, 'SslCertAutoOrder', 'False')); { V8.57 } CertExpireDays := MyIniFile.ReadInteger(Section, 'CertExpireDays', CertExpireDays); { V8.57 } IcsStrToSet(TypeInfo (THttpOption), MyIniFile.ReadString (section, 'Options', '[]'), FOptions, SizeOf(Options)); { V8.57 } // ie Options=[hoContentEncoding,hoAllowDirList,hoSendServerHdr,hoAllowPut] ListenBacklog := MyIniFile.ReadInteger(Section, 'ListenBacklog', ListenBacklog); { V8.57 } MaxUploadMB := MyIniFile.ReadInteger(Section, 'MaxUploadMB', 205); { V9.1 200M } MaxStreamMB := MyIniFile.ReadInteger(Section, 'MaxStreamMB', 51); { V9.1 50M } NoSSL := IcsCheckTrueFalse(MyIniFile.ReadString (section, 'NoSSL', 'False')); { V9.1 } AttachmentTypes := IcsTrim(MyIniFile.ReadString(Section, 'AttachmentTypes', AttachmentTypes)); { V9.5 } IcsStrToSet(TypeInfo (TWSDebugOptions), MyIniFile.ReadString (section, 'WSDebugOptions', '[]'), FWSDebugOptions, SizeOf(FWSDebugOptions)); { V9.6 } if FWSDebugOptions = [] then FWSDebugOptions := DefWSDebugServer; { V9.6 } end; { V9.5 new certificate ordering defaults in SocketServer } {$IFDEF AUTO_X509_CERTS} with HttpAppSrv.WSocketServer as TSslWSocketServer do begin SrvSupplierTitle := Trim(MyIniFile.ReadString(section, 'SrvSupplierTitle', '')); SrvAcmeSupplier := TAcmeSupplier(GetEnumValue (TypeInfo (TAcmeSupplier), IcsTrim(MyIniFile.ReadString(section, 'SrvAcmeSupplier', 'AcmeLetsEncrypt')))); if (SrvAcmeSupplier > High(TAcmeSupplier)) or (SrvAcmeSupplier < Low(TAcmeSupplier)) then SrvAcmeSupplier := AcmeLetsEncrypt; SrvAcmeCertProfile := IcsTrim(MyIniFile.ReadString(section, 'SrvAcmeCertProfile', '')); SrvAcmeCertValidity := MyIniFile.ReadInteger(section, 'SrvAcmeCertValidity', 90); SrvCertChallenge := TChallengeType(GetEnumValue (TypeInfo (TChallengeType), IcsTrim(MyIniFile.ReadString(section, 'SrvCertChallenge', 'ChallNone')))); if SrvCertChallenge > High(TChallengeType) then SrvCertChallenge := ChallNone; SrvCertPKeyType := TSslPrivKeyType(GetEnumValue (TypeInfo (TSslPrivKeyType), IcsTrim(MyIniFile.ReadString(section, 'SrvCertPKeyType', 'PrivKeyRsa2048')))); if SrvCertPKeyType > High(TSslPrivKeyType) then SrvCertPKeyType := PrivKeyRsa2048; SrvCertSignDigest := TEvpDigest(GetEnumValue (TypeInfo (TEvpDigest), IcsTrim(MyIniFile.ReadString(section, 'SrvCertSignDigest', 'Digest_sha256')))); if SrvCertSignDigest > High(TEvpDigest) then SrvCertSignDigest := Digest_sha256; end; {$ENDIF} end; {$ENDIF} {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} end.