/// classes implementing TCP/UDP/HTTP client and server protocol // - this unit is a part of the freeware Synopse mORMot framework, // licensed under a MPL/GPL/LGPL tri-license; version 1.18 unit SynCrtSock; { This file is part of Synopse framework. Synopse framework. Copyright (C) 2022 Arnaud Bouchez Synopse Informatique - https://synopse.info *** BEGIN LICENSE BLOCK ***** Version: MPL 1.1/GPL 2.0/LGPL 2.1 The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at http://www.mozilla.org/MPL Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for the specific language governing rights and limitations under the License. The Original Code is Synopse mORMot framework. The Initial Developer of the Original Code is Arnaud Bouchez. Portions created by the Initial Developer are Copyright (C) 2022 the Initial Developer. All Rights Reserved. Contributor(s): - Alfred Glaenzer (alf) - Cybexr - Darian Miller - EMartin - Eric Grange - Eugene Ilyin - EvaF - f-vicente - macc2010 - Maciej Izak (hnb) - Marius Maximus - Mr Yang (ysair) - Pavel Mashlyakovskii (mpv) - Willo vd Merwe Alternatively, the contents of this file may be used under the terms of either the GNU General Public License Version 2 or later (the "GPL"), or the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), in which case the provisions of the GPL or the LGPL are applicable instead of those above. If you wish to allow use of your version of this file only under the terms of either the GPL or the LGPL, and not to allow others to use your version of this file under the terms of the MPL, indicate your decision by deleting the provisions above and replace them with the notice and other provisions required by the GPL or the LGPL. If you do not delete the provisions above, a recipient may use your version of this file under the terms of any one of the MPL, the GPL or the LGPL. ***** END LICENSE BLOCK ***** } {$I Synopse.inc} // define HASINLINE ONLYUSEHTTPSOCKET USELIBCURL SYNCRTDEBUGLOW {.$define SYNCRTDEBUGLOW} // internal use: enable some low-level log messages for HTTP socket debugging interface uses SysUtils, // put first to use SynFPCLinux/SynKylix GetTickCount64 {$ifndef LVCL} Contnrs, SyncObjs, // for TEvent (in Classes.pas for LVCL) {$endif LVCL} {$ifdef SYNCRTDEBUGLOW} SynCommons, SynLog, {$endif SYNCRTDEBUGLOW} {$ifdef USELIBCURL} SynCurl, {$endif USELIBCURL} {$ifdef FPC} dynlibs, {$endif FPC} {$ifdef MSWINDOWS} Windows, SynWinSock, {$ifdef USEWININET} WinInet, {$endif USEWININET} {$ifndef DELPHI5OROLDER} Types, {$endif DELPHI5OROLDER} {$else MSWINDOWS} {$undef USEWININET} {$ifdef FPC} SynFPCSock, SynFPCLinux, BaseUnix, // for fpgetrlimit/fpsetrlimit {$ifdef LINUXNOTBSD} Linux, {$endif LINUXNOTBSD} {$else} {$ifndef DELPHI5OROLDER} Types, {$endif DELPHI5OROLDER} {$endif FPC} {$ifdef KYLIX3} KernelIoctl, // for IoctlSocket/ioctl FION* constants LibC, SynFPCSock, // shared with Kylix SynKylix, {$endif KYLIX3} {$endif MSWINDOWS} Classes; const /// the full text of the current Synopse mORMot framework version // - match the value defined in SynCommons.pas and SynopseCommit.inc // - we don't supply full version number with build revision, to reduce // potential attack surface XPOWEREDPROGRAM = 'mORMot 1.18'; /// the running Operating System XPOWEREDOS = {$ifdef MSWINDOWS} 'Windows' {$else} {$ifdef LINUXNOTBSD} 'Linux' {$else} 'Posix' {$endif LINUXNOTBSD} {$endif MSWINDOWS}; /// internal HTTP content-type for efficient static file sending // - detected e.g. by http.sys' THttpApiServer.Request or via the NGINX // X-Accel-Redirect header's THttpServer.Process (see // THttpServer.NginxSendFileFrom) for direct sending with no local bufferring // - the OutCustomHeader should contain the proper 'Content-type: ....' // corresponding to the file (e.g. by calling GetMimeContentType() function // from SynCommons supplyings the file name) // - should match HTML_CONTENT_STATICFILE constant defined in mORMot.pas unit HTTP_RESP_STATICFILE = '!STATICFILE'; /// used to notify e.g. the THttpServerRequest not to wait for any response // from the client // - is not to be used in normal HTTP process, but may be used e.g. by // TWebSocketProtocolRest.ProcessFrame() to avoid to wait for an incoming // response from the other endpoint // - should match NORESPONSE_CONTENT_TYPE constant defined in mORMot.pas unit HTTP_RESP_NORESPONSE = '!NORESPONSE'; var /// THttpRequest timeout default value for DNS resolution // - leaving to 0 will let system default value be used HTTP_DEFAULT_RESOLVETIMEOUT: integer = 0; /// THttpRequest timeout default value for remote connection // - default is 60 seconds // - used e.g. by THttpRequest, TSQLHttpClientRequest and TSQLHttpClientGeneric HTTP_DEFAULT_CONNECTTIMEOUT: integer = 60000; /// THttpRequest timeout default value for data sending // - default is 30 seconds // - used e.g. by THttpRequest, TSQLHttpClientRequest and TSQLHttpClientGeneric // - you can override this value by setting the corresponding parameter in // THttpRequest.Create() constructor HTTP_DEFAULT_SENDTIMEOUT: integer = 30000; /// THttpRequest timeout default value for data receiving // - default is 30 seconds // - used e.g. by THttpRequest, TSQLHttpClientRequest and TSQLHttpClientGeneric // - you can override this value by setting the corresponding parameter in // THttpRequest.Create() constructor HTTP_DEFAULT_RECEIVETIMEOUT: integer = 30000; type {$ifdef HASCODEPAGE} // FPC may expect a CP, e.g. to compare two string constants SockString = type RawByteString; {$else} /// define a 8-bit raw storage string type, used for data buffer management SockString = type AnsiString; {$endif} /// points to a 8-bit raw storage variable, used for data buffer management PSockString = ^SockString; /// defines a dynamic array of SockString TSockStringDynArray = array of SockString; {$ifdef HASVARUSTRING} SockUnicode = UnicodeString; {$else} /// define the fastest 16-bit Unicode string type of the compiler SockUnicode = WideString; {$endif} {$ifdef DELPHI5OROLDER} // not defined in Delphi 5 or older PPointer = ^Pointer; TTextLineBreakStyle = (tlbsLF, tlbsCRLF); UTF8String = AnsiString; UTF8Encode = AnsiString; {$endif} {$ifndef FPC} /// FPC 64-bit compatibility integer type {$ifdef CPU64} PtrInt = NativeInt; PtrUInt = NativeUInt; {$else} PtrInt = integer; PtrUInt = cardinal; {$endif} PPtrInt = ^PtrInt; PPtrUInt = ^PtrUInt; {$endif FPC} {$M+} /// exception thrown by the classes of this unit ECrtSocket = class(Exception) protected fLastError: integer; public /// will concat the message with the WSAGetLastError information constructor Create(const Msg: string); overload; /// will concat the message with the supplied WSAGetLastError information constructor Create(const Msg: string; Error: integer); overload; /// will concat the message with the supplied WSAGetLastError information constructor CreateFmt(const Msg: string; const Args: array of const; Error: integer); overload; published /// the associated WSAGetLastError value property LastError: integer read fLastError; end; {$M-} TCrtSocketClass = class of TCrtSocket; /// the available available network transport layer // - either TCP/IP, UDP/IP or Unix sockets TCrtSocketLayer = (cslTCP, cslUDP, cslUNIX); /// identify the incoming data availability in TCrtSocket.SockReceivePending TCrtSocketPending = (cspSocketError, cspNoData, cspDataAvailable); PTextFile = ^TextFile; {$M+} /// Fast low-level Socket implementation // - direct access to the OS (Windows, Linux) network layer API // - use Open constructor to create a client to be connected to a server // - use Bind constructor to initialize a server // - use SockIn and SockOut (after CreateSock*) to read/readln or write/writeln // as with standard Delphi text files (see SendEmail implementation) // - even if you do not use read(SockIn^), you may call CreateSockIn then // read the (binary) content via SockInRead/SockInPending methods, which would // benefit of the SockIn^ input buffer to maximize reading speed // - to write data, CreateSockOut and write(SockOut^) is not mandatory: you // rather may use SockSend() overloaded methods, followed by a SockFlush call // - in fact, you can decide whatever to use none, one or both SockIn/SockOut // - since this class rely on its internal optimized buffering system, // TCP_NODELAY is set to disable the Nagle algorithm // - our classes are (much) faster than the Indy or Synapse implementation TCrtSocket = class protected fSock: TSocket; fServer: SockString; fPort: SockString; fSockIn: PTextFile; fSockOut: PTextFile; fTimeOut: PtrInt; fBytesIn: Int64; fBytesOut: Int64; fSocketLayer: TCrtSocketLayer; fSockInEofError: integer; fTLS, fWasBind: boolean; // updated by every SockSend() call fSndBuf: SockString; fSndBufLen: integer; // set by AcceptRequest() from TVarSin fRemoteIP: SockString; // updated during UDP connection, accessed via PeerAddress/PeerPort fPeerAddr: TSockAddr; {$ifdef MSWINDOWS} fSecure: TSChannelClient; {$endif MSWINDOWS} procedure SetInt32OptionByIndex(OptName, OptVal: integer); virtual; public /// common initialization of all constructors // - do not call directly, but use Open / Bind constructors instead constructor Create(aTimeOut: PtrInt=10000); reintroduce; virtual; /// connect to aServer:aPort // - you may ask for a TLS secured client connection (only available under // Windows by now, using the SChannel API) constructor Open(const aServer, aPort: SockString; aLayer: TCrtSocketLayer=cslTCP; aTimeOut: cardinal=10000; aTLS: boolean=false); /// bind to an address // - aAddr='1234' - bind to a port on all interfaces, the same as '0.0.0.0:1234' // - aAddr='IP:port' - bind to specified interface only, e.g. '1.2.3.4:1234' // - aAddr='unix:/path/to/file' - bind to unix domain socket, e.g. 'unix:/run/mormot.sock' // - aAddr='' - bind to systemd descriptor on linux. See // http://0pointer.de/blog/projects/socket-activation.html constructor Bind(const aAddr: SockString; aLayer: TCrtSocketLayer=cslTCP; aTimeOut: integer=10000); /// low-level internal method called by Open() and Bind() constructors // - raise an ECrtSocket exception on error // - you may ask for a TLS secured client connection (only available under // Windows by now, using the SChannel API) procedure OpenBind(const aServer, aPort: SockString; doBind: boolean; aSock: integer=-1; aLayer: TCrtSocketLayer=cslTCP; aTLS: boolean=false); /// initialize the instance with the supplied accepted socket // - is called from a bound TCP Server, just after Accept() procedure AcceptRequest(aClientSock: TSocket; aClientSin: PVarSin); /// initialize SockIn for receiving with read[ln](SockIn^,...) // - data is buffered, filled as the data is available // - read(char) or readln() is indeed very fast // - multithread applications would also use this SockIn pseudo-text file // - by default, expect CR+LF as line feed (i.e. the HTTP way) procedure CreateSockIn(LineBreak: TTextLineBreakStyle=tlbsCRLF; InputBufferSize: Integer=1024); /// initialize SockOut for sending with write[ln](SockOut^,....) // - data is sent (flushed) after each writeln() - it's a compiler feature // - use rather SockSend() + SockSendFlush to send headers at once e.g. // since writeln(SockOut^,..) flush buffer each time procedure CreateSockOut(OutputBufferSize: Integer=1024); /// finalize SockIn receiving buffer // - you may call this method when you are sure that you don't need the // input buffering feature on this connection any more (e.g. after having // parsed the HTTP header, then rely on direct socket comunication) procedure CloseSockIn; /// finalize SockOut receiving buffer // - you may call this method when you are sure that you don't need the // output buffering feature on this connection any more (e.g. after having // parsed the HTTP header, then rely on direct socket comunication) procedure CloseSockOut; /// close and shutdown the connection (called from Destroy) procedure Close; /// close the opened socket, and corresponding SockIn/SockOut destructor Destroy; override; /// read Length bytes from SockIn buffer + Sock if necessary // - if SockIn is available, it first gets data from SockIn^.Buffer, // then directly receive data from socket if UseOnlySockIn=false // - if UseOnlySockIn=true, it will return the data available in SockIn^, // and returns the number of bytes // - can be used also without SockIn: it will call directly SockRecv() // in such case (assuming UseOnlySockin=false) function SockInRead(Content: PAnsiChar; Length: integer; UseOnlySockIn: boolean=false): integer; /// returns the number of bytes in SockIn buffer or pending in Sock // - if SockIn is available, it first check from any data in SockIn^.Buffer, // then call InputSock to try to receive any pending data if the buffer is void // - if aPendingAlsoInSocket is TRUE, returns the bytes available in both the buffer // and the socket (sometimes needed, e.g. to process a whole block at once) // - will wait up to the specified aTimeOutMS value (in milliseconds) for // incoming data - may wait a little less time on Windows due to a select bug // - returns -1 in case of a socket error (e.g. broken/closed connection); // you can raise a ECrtSocket exception to propagate the error function SockInPending(aTimeOutMS: integer; aPendingAlsoInSocket: boolean=false): integer; /// check the connection status of the socket function SockConnected: boolean; /// simulate writeln() with direct use of Send(Sock, ..) - includes trailing #13#10 // - useful on multi-treaded environnement (as in THttpServer.Process) // - no temp buffer is used // - handle SockString, ShortString, Char, Integer parameters // - raise ECrtSocket exception on socket error procedure SockSend(const Values: array of const); overload; /// simulate writeln() with a single line - includes trailing #13#10 procedure SockSend(const Line: SockString=''); overload; /// append P^ data into SndBuf (used by SockSend(), e.g.) - no trailing #13#10 // - call SockSendFlush to send it through the network via SndLow() procedure SockSend(P: pointer; Len: integer); overload; /// flush all pending data to be sent, optionally with some body content // - raise ECrtSocket on error procedure SockSendFlush(const aBody: SockString=''); virtual; /// flush all pending data to be sent // - returning true on success function TrySockSendFlush: boolean; /// how many bytes could be added by SockSend() in the internal buffer function SockSendRemainingSize: integer; /// fill the Buffer with Length bytes // - use TimeOut milliseconds wait for incoming data // - bypass the SockIn^ buffers // - raise ECrtSocket exception on socket error procedure SockRecv(Buffer: pointer; Length: integer); /// check if there are some pending bytes in the input sockets API buffer // - returns cspSocketError if the connection is broken or closed // - warning: on Windows, may wait a little less than TimeOutMS (select bug) function SockReceivePending(TimeOutMS: integer): TCrtSocketPending; /// returns the socket input stream as a string function SockReceiveString: SockString; /// fill the Buffer with Length bytes // - use TimeOut milliseconds wait for incoming data // - bypass the SockIn^ buffers // - return false on any fatal socket error, true on success // - call Close if the socket is identified as shutdown from the other side // - you may optionally set StopBeforeLength=true, then the read bytes count // are set in Length, even if not all expected data has been received - in // this case, Close method won't be called function TrySockRecv(Buffer: pointer; var Length: integer; StopBeforeLength: boolean=false): boolean; /// call readln(SockIn^,Line) or simulate it with direct use of Recv(Sock, ..) // - char are read one by one if needed // - use TimeOut milliseconds wait for incoming data // - raise ECrtSocket exception on socket error // - by default, will handle #10 or #13#10 as line delimiter (as normal text // files), but you can delimit lines using #13 if CROnly is TRUE procedure SockRecvLn(out Line: SockString; CROnly: boolean=false); overload; /// call readln(SockIn^) or simulate it with direct use of Recv(Sock, ..) // - char are read one by one // - use TimeOut milliseconds wait for incoming data // - raise ECrtSocket exception on socket error // - line content is ignored procedure SockRecvLn; overload; /// direct send data through network // - raise a ECrtSocket exception on any error // - bypass the SockSend() or SockOut^ buffers procedure SndLow(P: pointer; Len: integer); /// direct send data through network // - return false on any error, true on success // - bypass the SndBuf or SockOut^ buffers function TrySndLow(P: pointer; Len: integer): boolean; /// returns the low-level error number // - i.e. returns WSAGetLastError function LastLowSocketError: Integer; /// direct send data through network // - raise a ECrtSocket exception on any error // - bypass the SndBuf or SockOut^ buffers // - raw Data is sent directly to OS: no LF/CRLF is appened to the block procedure Write(const Data: SockString); /// direct accept an new incoming connection on a bound socket // - instance should have been setup as a server via a previous Bind() call // - returns nil on error or a ResultClass instance on success // - if ResultClass is nil, will return a plain TCrtSocket, but you may // specify e.g. THttpServerSocket if you expect incoming HTTP requests function AcceptIncoming(ResultClass: TCrtSocketClass=nil): TCrtSocket; /// remote IP address after AcceptRequest() call over TCP // - is either the raw connection IP to the current server socket, or // a custom header value set by a local proxy as retrieved by inherited // THttpServerSocket.GetRequest, searching the header named in // THttpServerGeneric.RemoteIPHeader (e.g. 'X-Real-IP' for nginx) property RemoteIP: SockString read fRemoteIP write fRemoteIP; /// remote IP address of the last packet received (SocketLayer=slUDP only) function PeerAddress: SockString; /// remote IP port of the last packet received (SocketLayer=slUDP only) function PeerPort: integer; /// set the TCP_NODELAY option for the connection // - default 1 (true) will disable the Nagle buffering algorithm; it should // only be set for applications that send frequent small bursts of information // without getting an immediate response, where timely delivery of data // is required - so it expects buffering before calling Write() or SndLow() // - you can set 0 (false) here to enable the Nagle algorithm, if needed // - see http://www.unixguide.net/network/socketfaq/2.16.shtml property TCPNoDelay: Integer index TCP_NODELAY write SetInt32OptionByIndex; /// set the SO_SNDTIMEO option for the connection // - i.e. the timeout, in milliseconds, for blocking send calls // - see http://msdn.microsoft.com/en-us/library/windows/desktop/ms740476 property SendTimeout: Integer index SO_SNDTIMEO write SetInt32OptionByIndex; /// set the SO_RCVTIMEO option for the connection // - i.e. the timeout, in milliseconds, for blocking receive calls // - see http://msdn.microsoft.com/en-us/library/windows/desktop/ms740476 property ReceiveTimeout: Integer index SO_RCVTIMEO write SetInt32OptionByIndex; /// set the SO_KEEPALIVE option for the connection // - 1 (true) will enable keep-alive packets for the connection // - see http://msdn.microsoft.com/en-us/library/windows/desktop/ee470551 property KeepAlive: Integer index SO_KEEPALIVE write SetInt32OptionByIndex; /// set the SO_LINGER option for the connection, to control its shutdown // - by default (or Linger<0), Close will return immediately to the caller, // and any pending data will be delivered if possible // - Linger > 0 represents the time in seconds for the timeout period // to be applied at Close; under Linux, will also set SO_REUSEADDR; under // Darwin, set SO_NOSIGPIPE // - Linger = 0 causes the connection to be aborted and any pending data // is immediately discarded at Close property Linger: Integer index SO_LINGER write SetInt32OptionByIndex; /// after CreateSockIn, use Readln(SockIn^,s) to read a line from the opened socket property SockIn: PTextFile read fSockIn; /// after CreateSockOut, use Writeln(SockOut^,s) to send a line to the opened socket property SockOut: PTextFile read fSockOut; published /// low-level socket handle, initialized after Open() with socket property Sock: TSocket read fSock write fSock; /// low-level socket type, initialized after Open() with socket property SocketLayer: TCrtSocketLayer read fSocketLayer; /// IP address, initialized after Open() with Server name property Server: SockString read fServer; /// IP port, initialized after Open() with port number property Port: SockString read fPort; /// if higher than 0, read loop will wait for incoming data till // TimeOut milliseconds (default value is 10000) - used also in SockSend() property TimeOut: PtrInt read fTimeOut; /// total bytes received property BytesIn: Int64 read fBytesIn; /// total bytes sent property BytesOut: Int64 read fBytesOut; end; {$M-} /// event used to compress or uncompress some data during HTTP protocol // - should always return the protocol name for ACCEPT-ENCODING: header // e.g. 'gzip' or 'deflate' for standard HTTP format, but you can add // your own (like 'synlzo' or 'synlz') // - the data is compressed (if Compress=TRUE) or uncompressed (if // Compress=FALSE) in the Data variable (i.e. it is modified in-place) // - to be used with THttpSocket.RegisterCompress method // - DataRawByteStringtype should be a generic AnsiString/RawByteString, which // should be in practice a SockString or a RawByteString THttpSocketCompress = function(var DataRawByteString; Compress: boolean): AnsiString; /// used to maintain a list of known compression algorithms THttpSocketCompressRec = record /// the compression name, as in ACCEPT-ENCODING: header (gzip,deflate,synlz) Name: SockString; /// the function handling compression and decompression Func: THttpSocketCompress; /// the size in bytes after which compress will take place // - will be 1024 e.g. for 'zip' or 'deflate' // - could be 0 e.g. when encrypting the content, meaning "always compress" CompressMinSize: integer; end; /// list of known compression algorithms THttpSocketCompressRecDynArray = array of THttpSocketCompressRec; /// identify some items in a list of known compression algorithms // - filled from ACCEPT-ENCODING: header value THttpSocketCompressSet = set of 0..31; /// parent of THttpClientSocket and THttpServerSocket classes // - contain properties for implementing HTTP/1.1 using the Socket API // - handle chunking of body content // - can optionaly compress and uncompress on the fly the data, with // standard gzip/deflate or custom (synlzo/synlz) protocols THttpSocket = class(TCrtSocket) protected /// used by RegisterCompress method fCompress: THttpSocketCompressRecDynArray; /// set by RegisterCompress method fCompressAcceptEncoding: SockString; /// GetHeader set index of protocol in fCompress[], from ACCEPT-ENCODING: fCompressAcceptHeader: THttpSocketCompressSet; /// same as HeaderGetValue('CONTENT-ENCODING'), but retrieved during Request // and mapped into the fCompress[] array fContentCompress: integer; /// to call GetBody only once fBodyRetrieved: boolean; /// compress the data, adding corresponding headers via SockSend() // - always add a 'Content-Length: ' header entry (even if length=0) // - e.g. 'Content-Encoding: synlz' header if compressed using synlz // - and if Data is not '', will add 'Content-Type: ' header procedure CompressDataAndWriteHeaders(const OutContentType: SockString; var OutContent: SockString); public /// TCP/IP prefix to mask HTTP protocol // - if not set, will create full HTTP/1.0 or HTTP/1.1 compliant content // - in order to make the TCP/IP stream not HTTP compliant, you can specify // a prefix which will be put before the first header line: in this case, // the TCP/IP stream won't be recognized as HTTP, and will be ignored by // most AntiVirus programs, and increase security - but you won't be able // to use an Internet Browser nor AJAX application for remote access any more TCPPrefix: SockString; /// will contain the first header line: // - 'GET /path HTTP/1.1' for a GET request with THttpServer, e.g. // - 'HTTP/1.0 200 OK' for a GET response after Get() e.g. Command: SockString; /// will contain all header lines after a Request // - use HeaderGetValue() to get one HTTP header item value by name Headers: SockString; /// will contain the data retrieved from the server, after the Request Content: SockString; /// same as HeaderGetValue('CONTENT-LENGTH'), but retrieved during Request // - is overridden with real Content length during HTTP body retrieval ContentLength: integer; /// same as HeaderGetValue('SERVER-INTERNALSTATE'), but retrieved during Request // - proprietary header, used with our RESTful ORM access ServerInternalState: integer; /// same as HeaderGetValue('CONTENT-TYPE'), but retrieved during Request ContentType: SockString; /// same as HeaderGetValue('UPGRADE'), but retrieved during Request Upgrade: SockString; /// same as HeaderGetValue('X-POWERED-BY'), but retrieved during Request XPoweredBy: SockString; /// map the presence of some HTTP headers, but retrieved during Request HeaderFlags: set of(transferChuked, connectionClose, connectionUpgrade, connectionKeepAlive, hasRemoteIP); /// retrieve the HTTP headers into Headers[] and fill most properties below // - only relevant headers are retrieved, unless HeadersUnFiltered is set procedure GetHeader(HeadersUnFiltered: boolean=false); /// retrieve the HTTP body (after uncompression if necessary) into Content procedure GetBody; /// add an header 'name: value' entry procedure HeaderAdd(const aValue: SockString); /// set all Header values at once, from CRLF delimited text procedure HeaderSetText(const aText: SockString; const aForcedContentType: SockString=''); /// get all Header values at once, as CRLF delimited text // - you can optionally specify a value to be added as 'RemoteIP: ' header function HeaderGetText(const aRemoteIP: SockString=''): SockString; /// HeaderGetValue('CONTENT-TYPE')='text/html', e.g. // - supplied aUpperName should be already uppercased function HeaderGetValue(const aUpperName: SockString): SockString; /// will register a compression algorithm // - used e.g. to compress on the fly the data, with standard gzip/deflate // or custom (synlzo/synlz) protocols // - returns true on success, false if this function or this // ACCEPT-ENCODING: header was already registered // - you can specify a minimal size (in bytes) before which the content won't // be compressed (1024 by default, corresponding to a MTU of 1500 bytes) // - the first registered algorithm will be the prefered one for compression function RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer=1024): boolean; end; THttpServer = class; /// results of THttpServerSocket.GetRequest virtual method // - return grError if the socket was not connected any more, or grException // if any exception occured during the process // - grOversizedPayload is returned when MaximumAllowedContentLength is reached // - grRejected is returned when OnBeforeBody returned not 200 // - grTimeout is returned when HeaderRetrieveAbortDelay is reached // - grHeaderReceived is returned for GetRequest({withbody=}false) // - grBodyReceived is returned for GetRequest({withbody=}true) // - grOwned indicates that this connection is now handled by another thread, // e.g. asynchronous WebSockets THttpServerSocketGetRequestResult = ( grError, grException, grOversizedPayload, grRejected, grTimeout, grHeaderReceived, grBodyReceived, grOwned); /// a genuine identifier for a given client connection on server side // - maps http.sys ID, or is a genuine 31-bit value from increasing sequence THttpServerConnectionID = Int64; /// a dynamic array of client connection identifiers, e.g. for broadcasting THttpServerConnectionIDDynArray = array of THttpServerConnectionID; /// Socket API based HTTP/1.1 server class used by THttpServer Threads THttpServerSocket = class(THttpSocket) protected fMethod: SockString; fURL: SockString; fKeepAliveClient: boolean; fRemoteConnectionID: THttpServerConnectionID; fServer: THttpServer; public /// create the socket according to a server // - will register the THttpSocketCompress functions from the server // - once created, caller should call AcceptRequest() to accept the socket constructor Create(aServer: THttpServer); reintroduce; /// main object function called after aClientSock := Accept + Create: // - get Command, Method, URL, Headers and Body (if withBody is TRUE) // - get sent data in Content (if withBody=true and ContentLength<>0) // - returned enumeration will indicates the processing state function GetRequest(withBody: boolean; headerMaxTix: Int64): THttpServerSocketGetRequestResult; virtual; /// contains the method ('GET','POST'.. e.g.) after GetRequest() property Method: SockString read fMethod; /// contains the URL ('/' e.g.) after GetRequest() property URL: SockString read fURL; /// true if the client is HTTP/1.1 and 'Connection: Close' is not set // - default HTTP/1.1 behavior is "keep alive", unless 'Connection: Close' // is specified, cf. RFC 2068 page 108: "HTTP/1.1 applications that do not // support persistent connections MUST include the "close" connection option // in every message" property KeepAliveClient: boolean read fKeepAliveClient write fKeepAliveClient; /// the recognized connection ID, after a call to GetRequest() // - identifies either the raw connection on the current server, or is // a custom header value set by a local proxy, e.g. // THttpServerGeneric.RemoteConnIDHeader='X-Conn-ID' for nginx property RemoteConnectionID: THttpServerConnectionID read fRemoteConnectionID; end; /// Socket API based REST and HTTP/1.1 compatible client class // - this component is HTTP/1.1 compatible, according to RFC 2068 document // - the REST commands (GET/POST/PUT/DELETE) are directly available // - open connection with the server with inherited Open(server,port) function // - if KeepAlive>0, the connection is not broken: a further request (within // KeepAlive milliseconds) will use the existing connection if available, // or recreate a new one if the former is outdated or reset by server // (will retry only once); this is faster, uses less resources (especialy // under Windows), and is the recommended way to implement a HTTP/1.1 server // - on any error (timeout, connection closed) will retry once to get the value // - don't forget to use Free procedure when you are finished THttpClientSocket = class(THttpSocket) protected fUserAgent: SockString; fProcessName: SockString; procedure RequestSendHeader(const url, method: SockString); virtual; public /// common initialization of all constructors // - this overridden method will set the UserAgent with some default value // - you can customize the default client timeouts by setting appropriate // aTimeout parameters (in ms) if you left the 0 default parameters, // it would use global HTTP_DEFAULT_RECEIVETIMEOUT variable values constructor Create(aTimeOut: PtrInt=0); override; /// low-level HTTP/1.1 request // - called by all Get/Head/Post/Put/Delete REST methods // - after an Open(server,port), return 200,202,204 if OK, http status error otherwise // - retry is false by caller, and will be recursively called with true to retry once function Request(const url, method: SockString; KeepAlive: cardinal; const header, Data, DataType: SockString; retry: boolean): integer; virtual; /// after an Open(server,port), return 200 if OK, http status error otherwise // - get the page data in Content function Get(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; /// after an Open(server,port), return 200 if OK, http status error otherwise // - get the page data in Content // - if AuthToken<>'', will add an header with 'Authorization: Bearer '+AuthToken function GetAuth(const url, AuthToken: SockString; KeepAlive: cardinal=0): integer; /// after an Open(server,port), return 200 if OK, http status error otherwise - only // header is read from server: Content is always '', but Headers are set function Head(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; /// after an Open(server,port), return 200,201,204 if OK, http status error otherwise function Post(const url, Data, DataType: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; /// after an Open(server,port), return 200,201,204 if OK, http status error otherwise function Put(const url, Data, DataType: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; /// after an Open(server,port), return 200,202,204 if OK, http status error otherwise function Delete(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer; /// by default, the client is identified as IE 5.5, which is very // friendly welcome by most servers :( // - you can specify a custom value here property UserAgent: SockString read fUserAgent write fUserAgent; /// the associated process name property ProcessName: SockString read fProcessName write fProcessName; end; /// class-reference type (metaclass) of a HTTP client socket access // - may be either THttpClientSocket or THttpClientWebSockets (from // SynBidirSock unit) THttpClientSocketClass = class of THttpClientSocket; {$ifndef LVCL} /// event prototype used e.g. by THttpServerGeneric.OnHttpThreadStart TNotifyThreadEvent = procedure(Sender: TThread) of object; {$endif} {$M+} TSynThreadPool = class; /// a simple TThread with a "Terminate" event run in the thread context // - the TThread.OnTerminate event is run within Synchronize() so did not // match our expectations to be able to release the resources in the thread // context which created them (e.g. for COM objects, or some DB drivers) // - used internally by THttpServerGeneric.NotifyThreadStart() - you should // not have to use the protected fOnThreadTerminate event handler // - also define a Start method for compatibility with older versions of Delphi TSynThread = class(TThread) protected // ensure fOnThreadTerminate is called only if NotifyThreadStart has been done fStartNotified: TObject; {$ifndef LVCL} // already available in LVCL // we defined an fOnThreadTerminate event which would be run in the terminated // thread context (whereas TThread.OnTerminate is called in the main thread) // -> see THttpServerGeneric.OnHttpThreadTerminate event property fOnThreadTerminate: TNotifyThreadEvent; procedure DoTerminate; override; {$endif} public /// initialize the server instance, in non suspended state constructor Create(CreateSuspended: boolean); reintroduce; virtual; {$ifndef HASTTHREADSTART} /// method to be called when the thread was created as suspended // - Resume is deprecated in the newest RTL, since some OS - e.g. Linux - // do not implement this pause/resume feature // - we define here this method for older versions of Delphi procedure Start; {$endif} /// safe version of Sleep() which won't break the thread process // - returns TRUE if the thread was Terminated // - returns FALSE if successfully waited up to MS milliseconds function SleepOrTerminated(MS: cardinal): boolean; /// defined as public since may be used to terminate the processing methods property Terminated; end; {$M-} /// HTTP response Thread as used by THttpServer Socket API based class // - Execute procedure get the request and calculate the answer, using // the thread for a single client connection, until it is closed // - you don't have to overload the protected THttpServerResp Execute method: // override THttpServer.Request() function or, if you need a lower-level access // (change the protocol, e.g.) THttpServer.Process() method itself THttpServerResp = class(TSynThread) protected fServer: THttpServer; fServerSock: THttpServerSocket; fClientSock: TSocket; fClientSin: TVarSin; fConnectionID: THttpServerConnectionID; /// main thread loop: read request from socket, send back answer procedure Execute; override; public /// initialize the response thread for the corresponding incoming socket // - this version will get the request directly from an incoming socket constructor Create(aSock: TSocket; const aSin: TVarSin; aServer: THttpServer); reintroduce; overload; /// initialize the response thread for the corresponding incoming socket // - this version will handle KeepAlive, for such an incoming request constructor Create(aServerSock: THttpServerSocket; aServer: THttpServer); reintroduce; overload; virtual; /// the associated socket to communicate with the client property ServerSock: THttpServerSocket read fServerSock; /// the associated main HTTP server instance property Server: THttpServer read fServer; /// the unique identifier of this connection property ConnectionID: THttpServerConnectionID read fConnectionID; end; /// metaclass of HTTP response Thread THttpServerRespClass = class of THttpServerResp; {$ifdef MSWINDOWS} // I/O completion ports API is the best option under Windows // under Linux/POSIX, we fallback to a classical event-driven pool {$define USE_WINIOCP} {$endif MSWINDOWS} /// defines the sub-threads used by TSynThreadPool TSynThreadPoolWorkThread = class(TSynThread) protected fOwner: TSynThreadPool; fNotifyThreadStartName: AnsiString; fThreadNumber: integer; {$ifndef USE_WINIOCP} fProcessingContext: pointer; fEvent: TEvent; {$endif USE_WINIOCP} procedure NotifyThreadStart(Sender: TSynThread); procedure DoTask(Context: pointer); // exception-safe call of fOwner.Task() public /// initialize the thread constructor Create(Owner: TSynThreadPool); reintroduce; /// finalize the thread destructor Destroy; override; /// will loop for any pending task, and execute fOwner.Task() procedure Execute; override; end; TSynThreadPoolWorkThreads = array of TSynThreadPoolWorkThread; {$M+} /// a simple Thread Pool, used e.g. for fast handling HTTP requests // - implemented over I/O Completion Ports under Windows, or a classical // Event-driven approach under Linux/POSIX TSynThreadPool = class protected fWorkThread: TSynThreadPoolWorkThreads; fWorkThreadCount: integer; fRunningThreads: integer; fExceptionsCount: integer; fOnThreadTerminate: TNotifyThreadEvent; fOnThreadStart: TNotifyThreadEvent; fTerminated: boolean; fContentionAbortCount: cardinal; fContentionTime: Int64; fContentionCount: cardinal; fContentionAbortDelay: integer; {$ifdef USE_WINIOCP} fRequestQueue: THandle; // IOCSP has its own internal queue {$else} fQueuePendingContext: boolean; fPendingContext: array of pointer; fPendingContextCount: integer; fSafe: TRTLCriticalSection; function GetPendingContextCount: integer; function PopPendingContext: pointer; function QueueLength: integer; virtual; {$endif USE_WINIOCP} /// end thread on IO error function NeedStopOnIOError: boolean; virtual; /// process to be executed after notification procedure Task(aCaller: TSynThread; aContext: Pointer); virtual; abstract; procedure TaskAbort(aContext: Pointer); virtual; public /// initialize a thread pool with the supplied number of threads // - abstract Task() virtual method will be called by one of the threads // - up to 256 threads can be associated to a Thread Pool // - can optionaly accept aOverlapHandle - a handle previously // opened for overlapped I/O (IOCP) under Windows // - aQueuePendingContext=true will store the pending context into // an internal queue, so that Push() always returns true constructor Create(NumberOfThreads: Integer=32; {$ifdef USE_WINIOCP}aOverlapHandle: THandle=INVALID_HANDLE_VALUE {$else}aQueuePendingContext: boolean=false{$endif}); /// shut down the Thread pool, releasing all associated threads destructor Destroy; override; /// let a task (specified as a pointer) be processed by the Thread Pool // - returns false if there is no idle thread available in the pool and // Create(aQueuePendingContext=false) was used (caller should retry later); // if aQueuePendingContext was true in Create, or IOCP is used, the supplied // context will be added to an internal list and handled when possible // - if aWaitOnContention is default false, returns immediately when the // queue is full; set aWaitOnContention=true to wait up to // ContentionAbortDelay ms and retry to queue the task function Push(aContext: pointer; aWaitOnContention: boolean=false): boolean; {$ifndef USE_WINIOCP} /// may be called after Push() returned false to see if queue was actually full // - returns false if QueuePendingContext is false function QueueIsFull: boolean; /// parameter as supplied to Create constructor property QueuePendingContext: boolean read fQueuePendingContext; {$endif USE_WINIOCP} /// low-level access to the threads defined in this thread pool property WorkThread: TSynThreadPoolWorkThreads read fWorkThread; published /// how many threads have been defined in this thread pool property WorkThreadCount: integer read fWorkThreadCount; /// how many threads are currently running in this thread pool property RunningThreads: integer read fRunningThreads; /// how many tasks were rejected due to thread pool contention // - if this number is high, consider setting a higher number of threads, // or profile and tune the Task method property ContentionAbortCount: cardinal read fContentionAbortCount; /// milliseconds delay to reject a connection due to contention // - default is 5000, i.e. 5 seconds wait for some room to be available // in the IOCP or aQueuePendingContext internal list // - during this delay, no new connection is available (i.e. Accept is not // called), so that a load balancer could detect the contention and switch // to another instance in the pool, or a direct client may eventually have // its connection rejected, so won't start sending data property ContentionAbortDelay: integer read fContentionAbortDelay write fContentionAbortDelay; /// total milliseconds spent waiting for an available slot in the queue // - contention won't fail immediately, but will retry until ContentionAbortDelay // - any high number here requires code refactoring of the Task method property ContentionTime: Int64 read fContentionTime; /// how many times the pool waited for an available slot in the queue // - contention won't fail immediately, but will retry until ContentionAbortDelay // - any high number here may better increase the threads count // - use this property and ContentionTime to compute the average contention time property ContentionCount: cardinal read fContentionCount; {$ifndef USE_WINIOCP} /// how many input tasks are currently waiting to be affected to threads property PendingContextCount: integer read GetPendingContextCount; {$endif} end; {$M-} /// a simple Thread Pool, used for fast handling HTTP requests of a THttpServer // - will handle multi-connection with less overhead than creating a thread // for each incoming request // - will create a THttpServerResp response thread, if the incoming request is // identified as HTTP/1.1 keep alive, or HTTP body length is bigger than 1 MB TSynThreadPoolTHttpServer = class(TSynThreadPool) protected fServer: THttpServer; {$ifndef USE_WINIOCP} function QueueLength: integer; override; {$endif} // here aContext is a THttpServerSocket instance procedure Task(aCaller: TSynThread; aContext: Pointer); override; procedure TaskAbort(aContext: Pointer); override; public /// initialize a thread pool with the supplied number of threads // - Task() overridden method processs the HTTP request set by Push() // - up to 256 threads can be associated to a Thread Pool constructor Create(Server: THttpServer; NumberOfThreads: Integer=32); reintroduce; end; {$M+} // to have existing RTTI for published properties THttpServerGeneric = class; {$M-} /// the server-side available authentication schemes // - as used by THttpServerRequest.AuthenticationStatus // - hraNone..hraKerberos will match low-level HTTP_REQUEST_AUTH_TYPE enum as // defined in HTTP 2.0 API and THttpServerRequestAuthentication = ( hraNone, hraFailed, hraBasic, hraDigest, hraNtlm, hraNegotiate, hraKerberos); /// a generic input/output structure used for HTTP server requests // - URL/Method/InHeaders/InContent properties are input parameters // - OutContent/OutContentType/OutCustomHeader are output parameters THttpServerRequest = class protected fRemoteIP, fURL, fMethod, fInHeaders, fInContent, fInContentType, fAuthenticatedUser, fOutContent, fOutContentType, fOutCustomHeaders: SockString; fServer: THttpServerGeneric; fRequestID: integer; fConnectionID: THttpServerConnectionID; fConnectionThread: TSynThread; fUseSSL: boolean; fAuthenticationStatus: THttpServerRequestAuthentication; {$ifdef MSWINDOWS} fHttpApiRequest: Pointer; fFullURL: SockUnicode; {$endif} public /// low-level property which may be used during requests processing Status: integer; /// initialize the context, associated to a HTTP server instance constructor Create(aServer: THttpServerGeneric; aConnectionID: THttpServerConnectionID; aConnectionThread: TSynThread); virtual; /// prepare an incoming request // - will set input parameters URL/Method/InHeaders/InContent/InContentType // - will reset output parameters procedure Prepare(const aURL,aMethod,aInHeaders,aInContent,aInContentType, aRemoteIP: SockString; aUseSSL: boolean=false); /// append some lines to the InHeaders input parameter procedure AddInHeader(additionalHeader: SockString); {$ifdef MSWINDOWS} /// input parameter containing the caller Full URL property FullURL: SockUnicode read fFullURL; {$endif} /// input parameter containing the caller URI property URL: SockString read fURL; /// input parameter containing the caller method (GET/POST...) property Method: SockString read fMethod; /// input parameter containing the caller message headers property InHeaders: SockString read fInHeaders; /// input parameter containing the caller message body // - e.g. some GET/POST/PUT JSON data can be specified here property InContent: SockString read fInContent; // input parameter defining the caller message body content type property InContentType: SockString read fInContentType; /// output parameter to be set to the response message body property OutContent: SockString read fOutContent write fOutContent; /// output parameter to define the reponse message body content type // - if OutContentType is HTTP_RESP_STATICFILE (i.e. '!STATICFILE', defined // as STATICFILE_CONTENT_TYPE in mORMot.pas), then OutContent is the UTF-8 // file name of a file which must be sent to the client via http.sys or // NGINX's X-Accel-Redirect header (faster than local buffering/sending) // - if OutContentType is HTTP_RESP_NORESPONSE (i.e. '!NORESPONSE', defined // as NORESPONSE_CONTENT_TYPE in mORMot.pas), then the actual transmission // protocol may not wait for any answer - used e.g. for WebSockets property OutContentType: SockString read fOutContentType write fOutContentType; /// output parameter to be sent back as the response message header // - e.g. to set Content-Type/Location property OutCustomHeaders: SockString read fOutCustomHeaders write fOutCustomHeaders; /// the associated server instance // - may be a THttpServer or a THttpApiServer class property Server: THttpServerGeneric read fServer; /// the client remote IP, as specified to Prepare() property RemoteIP: SockString read fRemoteIP write fRemoteIP; /// a 31-bit sequential number identifying this instance on the server property RequestID: integer read fRequestID; /// the ID of the connection which called this execution context // - e.g. SynBidirSock's TWebSocketProcess.NotifyCallback method would use // this property to specify the client connection to be notified // - is set as an Int64 to match http.sys ID type, but will be an // increasing 31-bit integer sequence for (web)socket-based servers property ConnectionID: THttpServerConnectionID read fConnectionID; /// the thread which owns the connection of this execution context // - depending on the HTTP server used, may not follow ConnectionID property ConnectionThread: TSynThread read fConnectionThread; /// is TRUE if the caller is connected via HTTPS // - only set for THttpApiServer class yet property UseSSL: boolean read fUseSSL; /// contains the THttpServer-side authentication status // - e.g. when using http.sys authentication with HTTP API 2.0 property AuthenticationStatus: THttpServerRequestAuthentication read fAuthenticationStatus; /// contains the THttpServer-side authenticated user name, UTF-8 encoded // - e.g. when using http.sys authentication with HTTP API 2.0, the // domain user name is retrieved from the supplied AccessToken // - could also be set by the THttpServerGeneric.Request() method, after // proper authentication, so that it would be logged as expected property AuthenticatedUser: SockString read fAuthenticatedUser; {$ifdef MSWINDOWS} /// for THttpApiServer, points to a PHTTP_REQUEST structure // - not used by now for other servers property HttpApiRequest: Pointer read fHttpApiRequest; {$endif} end; /// event handler used by THttpServerGeneric.OnRequest property // - Ctxt defines both input and output parameters // - result of the function is the HTTP error code (200 if OK, e.g.) // - OutCustomHeader will handle Content-Type/Location // - if OutContentType is HTTP_RESP_STATICFILE (i.e. '!STATICFILE' aka // STATICFILE_CONTENT_TYPE in mORMot.pas), then OutContent is the UTF-8 file // name of a file which must be sent directly to the client via http.sys or // NGINX's X-Accel-Redirect; the OutCustomHeader should contain the // proper 'Content-type: ....' value TOnHttpServerRequest = function(Ctxt: THttpServerRequest): cardinal of object; /// event handler used by THttpServerGeneric.OnAfterResponse property // - Ctxt defines both input and output parameters // - Code defines the HTTP response code the (200 if OK, e.g.) TOnHttpServerAfterResponse = procedure(Ctxt: THttpServerRequest; const Code: cardinal) of object; /// event handler used by THttpServerGeneric.OnBeforeBody property // - if defined, is called just before the body is retrieved from the client // - supplied parameters reflect the current input state // - should return STATUS_SUCCESS=200 to continue the process, or an HTTP // error code (e.g. STATUS_FORBIDDEN or STATUS_PAYLOADTOOLARGE) to reject // the request TOnHttpServerBeforeBody = function(const aURL,aMethod,aInHeaders, aInContentType,aRemoteIP: SockString; aContentLength: integer; aUseSSL: boolean): cardinal of object; {$M+} /// abstract class to implement a server thread // - do not use this class, but rather the THttpServer, THttpApiServer // or TAsynchFrameServer (as defined in SynBidirSock) TServerGeneric = class(TSynThread) protected fProcessName: SockString; fOnHttpThreadStart: TNotifyThreadEvent; procedure SetOnTerminate(const Event: TNotifyThreadEvent); virtual; procedure NotifyThreadStart(Sender: TSynThread); public /// initialize the server instance, in non suspended state constructor Create(CreateSuspended: boolean; OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); reintroduce; virtual; end; /// abstract class to implement a HTTP server // - do not use this class, but rather the THttpServer or THttpApiServer THttpServerGeneric = class(TServerGeneric) protected fShutdownInProgress: boolean; /// optional event handlers for process interception fOnRequest: TOnHttpServerRequest; fOnBeforeBody: TOnHttpServerBeforeBody; fOnBeforeRequest: TOnHttpServerRequest; fOnAfterRequest: TOnHttpServerRequest; fOnAfterResponse: TOnHttpServerAfterResponse; fMaximumAllowedContentLength: cardinal; /// list of all registered compression algorithms fCompress: THttpSocketCompressRecDynArray; /// set by RegisterCompress method fCompressAcceptEncoding: SockString; fServerName: SockString; fCurrentConnectionID: integer; // 31-bit NextConnectionID sequence fCurrentRequestID: integer; fCanNotifyCallback: boolean; fRemoteIPHeader, fRemoteIPHeaderUpper: SockString; fRemoteConnIDHeader, fRemoteConnIDHeaderUpper: SockString; function GetAPIVersion: string; virtual; abstract; procedure SetServerName(const aName: SockString); virtual; procedure SetOnRequest(const aRequest: TOnHttpServerRequest); virtual; procedure SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); virtual; procedure SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); virtual; procedure SetOnAfterRequest(const aEvent: TOnHttpServerRequest); virtual; procedure SetOnAfterResponse(const aEvent: TOnHttpServerAfterResponse); virtual; procedure SetMaximumAllowedContentLength(aMax: cardinal); virtual; procedure SetRemoteIPHeader(const aHeader: SockString); virtual; procedure SetRemoteConnIDHeader(const aHeader: SockString); virtual; function GetHTTPQueueLength: Cardinal; virtual; abstract; procedure SetHTTPQueueLength(aValue: Cardinal); virtual; abstract; function DoBeforeRequest(Ctxt: THttpServerRequest): cardinal; function DoAfterRequest(Ctxt: THttpServerRequest): cardinal; procedure DoAfterResponse(Ctxt: THttpServerRequest; const Code: cardinal); virtual; function NextConnectionID: integer; // 31-bit internal sequence public /// initialize the server instance, in non suspended state constructor Create(CreateSuspended: boolean; OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); reintroduce; virtual; /// override this function to customize your http server // - InURL/InMethod/InContent properties are input parameters // - OutContent/OutContentType/OutCustomHeader are output parameters // - result of the function is the HTTP error code (200 if OK, e.g.), // - OutCustomHeader is available to handle Content-Type/Location // - if OutContentType is HTTP_RESP_STATICFILE (i.e. '!STATICFILE' or // STATICFILE_CONTENT_TYPE defined in mORMot.pas), then OutContent is the // UTF-8 file name of a file which must be sent to the client via http.sys or // NGINX's X-Accel-Redirect (much faster than manual buffering/sending); // the OutCustomHeader should contain the proper 'Content-type: ....' // - default implementation is to call the OnRequest event (if existing), // and will return STATUS_NOTFOUND if OnRequest was not set // - warning: this process must be thread-safe (can be called by several // threads simultaneously, but with a given Ctxt instance for each) function Request(Ctxt: THttpServerRequest): cardinal; virtual; /// server can send a request back to the client, when the connection has // been upgraded e.g. to WebSockets // - InURL/InMethod/InContent properties are input parameters (InContentType // is ignored) // - OutContent/OutContentType/OutCustomHeader are output parameters // - CallingThread should be set to the client's Ctxt.CallingThread // value, so that the method could know which connnection is to be used - // it will return STATUS_NOTFOUND (404) if the connection is unknown // - result of the function is the HTTP error code (200 if OK, e.g.) // - warning: this void implementation will raise an ECrtSocket exception - // inherited classes should override it, e.g. as in TWebSocketServerRest function Callback(Ctxt: THttpServerRequest; aNonBlocking: boolean): cardinal; virtual; /// will register a compression algorithm // - used e.g. to compress on the fly the data, with standard gzip/deflate // or custom (synlzo/synlz) protocols // - you can specify a minimal size (in bytes) before which the content won't // be compressed (1024 by default, corresponding to a MTU of 1500 bytes) // - the first registered algorithm will be the prefered one for compression procedure RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer=1024); virtual; /// you can call this method to prepare the HTTP server for shutting down procedure Shutdown; /// event handler called by the default implementation of the // virtual Request method // - warning: this process must be thread-safe (can be called by several // threads simultaneously) property OnRequest: TOnHttpServerRequest read fOnRequest write SetOnRequest; /// event handler called just before the body is retrieved from the client // - should return STATUS_SUCCESS=200 to continue the process, or an HTTP // error code to reject the request immediatly, and close the connection property OnBeforeBody: TOnHttpServerBeforeBody read fOnBeforeBody write SetOnBeforeBody; /// event handler called after HTTP body has been retrieved, before OnProcess // - may be used e.g. to return a STATUS_ACCEPTED (202) status to client and // continue a long-term job inside the OnProcess handler in the same thread; // or to modify incoming information before passing it to main businnes logic, // (header preprocessor, body encoding etc...) // - if the handler returns > 0 server will send a response immediately, // unless return code is STATUS_ACCEPTED (202), then OnRequest will be called // - warning: this handler must be thread-safe (can be called by several // threads simultaneously) property OnBeforeRequest: TOnHttpServerRequest read fOnBeforeRequest write SetOnBeforeRequest; /// event handler called after request is processed but before response // is sent back to client // - main purpose is to apply post-processor, not part of request logic // - if handler returns value > 0 it will override the OnProcess response code // - warning: this handler must be thread-safe (can be called by several // threads simultaneously) property OnAfterRequest: TOnHttpServerRequest read fOnAfterRequest write SetOnAfterRequest; /// event handler called after response is sent back to client // - main purpose is to apply post-response analysis, logging, etc. // - warning: this handler must be thread-safe (can be called by several // threads simultaneously) property OnAfterResponse: TOnHttpServerAfterResponse read fOnAfterResponse write SetOnAfterResponse; /// event handler called after each working Thread is just initiated // - called in the thread context at first place in THttpServerGeneric.Execute property OnHttpThreadStart: TNotifyThreadEvent read fOnHttpThreadStart write fOnHttpThreadStart; /// event handler called when a working Thread is terminating // - called in the corresponding thread context // - the TThread.OnTerminate event will be called within a Synchronize() // wrapper, so it won't fit our purpose // - to be used e.g. to call CoUnInitialize from thread in which CoInitialize // was made, for instance via a method defined as such: // ! procedure TMyServer.OnHttpThreadTerminate(Sender: TObject); // ! begin // TSQLDBConnectionPropertiesThreadSafe // ! fMyConnectionProps.EndCurrentThread; // ! end; // - is used e.g. by TSQLRest.EndCurrentThread for proper multi-threading property OnHttpThreadTerminate: TNotifyThreadEvent read fOnThreadTerminate write SetOnTerminate; /// reject any incoming request with a body size bigger than this value // - default to 0, meaning any input size is allowed // - returns STATUS_PAYLOADTOOLARGE = 413 error if "Content-Length" incoming // header overflow the supplied number of bytes property MaximumAllowedContentLength: cardinal read fMaximumAllowedContentLength write SetMaximumAllowedContentLength; /// defines request/response internal queue length // - default value if 1000, which sounds fine for most use cases // - for THttpApiServer, will return 0 if the system does not support HTTP // API 2.0 (i.e. under Windows XP or Server 2003) // - for THttpServer, will shutdown any incoming accepted socket if the // internal TSynThreadPool.PendingContextCount+ThreadCount exceeds this limit; // each pending connection is a THttpServerSocket instance in the queue // - increase this value if you don't have any load-balancing in place, and // in case of e.g. many 503 HTTP answers or if many "QueueFull" messages // appear in HTTP.sys log files (normally in // C:\Windows\System32\LogFiles\HTTPERR\httperr*.log) - may appear with // thousands of concurrent clients accessing at once the same server - // see @http://msdn.microsoft.com/en-us/library/windows/desktop/aa364501 // - you can use this property with a reverse-proxy as load balancer, e.g. // with nginx configured as such: // $ location / { // $ proxy_pass http://balancing_upstream; // $ proxy_next_upstream error timeout invalid_header http_500 http_503; // $ proxy_connect_timeout 2; // $ proxy_set_header Host $host; // $ proxy_set_header X-Real-IP $remote_addr; // $ proxy_set_header X-Forwarded-For $proxy_add_x_forwarded_for; // $ proxy_set_header X-Conn-ID $connection // $ } // see https://synopse.info/forum/viewtopic.php?pid=28174#p28174 property HTTPQueueLength: cardinal read GetHTTPQueueLength write SetHTTPQueueLength; /// TRUE if the inherited class is able to handle callbacks // - only TWebSocketServer has this ability by now property CanNotifyCallback: boolean read fCanNotifyCallback; /// the value of a custom HTTP header containing the real client IP // - by default, the RemoteIP information will be retrieved from the socket // layer - but if the server runs behind some proxy service, you should // define here the HTTP header name which indicates the true remote client // IP value, mostly as 'X-Real-IP' or 'X-Forwarded-For' property RemoteIPHeader: SockString read fRemoteIPHeader write SetRemoteIPHeader; /// the value of a custom HTTP header containing the real client connection ID // - by default, Ctxt.ConnectionID information will be retrieved from our // socket layer - but if the server runs behind some proxy service, you should // define here the HTTP header name which indicates the real remote connection, // for example as 'X-Conn-ID', setting in nginx config: // $ proxy_set_header X-Conn-ID $connection property RemoteConnIDHeader: SockString read fRemoteConnIDHeader write SetRemoteConnIDHeader; published /// returns the API version used by the inherited implementation property APIVersion: string read GetAPIVersion; /// the Server name, UTF-8 encoded, e.g. 'mORMot/1.18 (Linux)' // - will be served as "Server: ..." HTTP header // - for THttpApiServer, when called from the main instance, will propagate // the change to all cloned instances, and included in any HTTP API 2.0 log property ServerName: SockString read fServerName write SetServerName; /// the associated process name property ProcessName: SockString read fProcessName write fProcessName; end; {$ifndef UNICODE} ULONGLONG = Int64; {$endif} {$ifdef MSWINDOWS} HTTP_OPAQUE_ID = ULONGLONG; HTTP_REQUEST_ID = HTTP_OPAQUE_ID; HTTP_URL_GROUP_ID = HTTP_OPAQUE_ID; HTTP_SERVER_SESSION_ID = HTTP_OPAQUE_ID; /// http.sys API 2.0 logging file supported layouts // - match low-level HTTP_LOGGING_TYPE as defined in HTTP 2.0 API THttpApiLoggingType = ( hltW3C, hltIIS, hltNCSA, hltRaw); /// http.sys API 2.0 logging file rollover types // - match low-level HTTP_LOGGING_ROLLOVER_TYPE as defined in HTTP 2.0 API THttpApiLoggingRollOver = ( hlrSize, hlrDaily, hlrWeekly, hlrMonthly, hlrHourly); /// http.sys API 2.0 logging option flags // - used to alter the default logging behavior // - hlfLocalTimeRollover would force the log file rollovers by local time, // instead of the default GMT time // - hlfUseUTF8Conversion will use UTF-8 instead of default local code page // - only one of hlfLogErrorsOnly and hlfLogSuccessOnly flag could be set // at a time: if neither of them are present, both errors and success will // be logged, otherwise mutually exclusive flags could be set to force only // errors or success logging // - match low-level HTTP_LOGGING_FLAG_* constants as defined in HTTP 2.0 API THttpApiLoggingFlags = set of ( hlfLocalTimeRollover, hlfUseUTF8Conversion, hlfLogErrorsOnly, hlfLogSuccessOnly); /// http.sys API 2.0 fields used for W3C logging // - match low-level HTTP_LOG_FIELD_* constants as defined in HTTP 2.0 API THttpApiLogFields = set of ( hlfDate, hlfTime, hlfClientIP, hlfUserName, hlfSiteName, hlfComputerName, hlfServerIP, hlfMethod, hlfURIStem, hlfURIQuery, hlfStatus, hlfWIN32Status, hlfBytesSent, hlfBytesRecv, hlfTimeTaken, hlfServerPort, hlfUserAgent, hlfCookie, hlfReferer, hlfVersion, hlfHost, hlfSubStatus); /// http.sys API 2.0 fields used for server-side authentication // - as used by THttpApiServer.SetAuthenticationSchemes/AuthenticationSchemes // - match low-level HTTP_AUTH_ENABLE_* constants as defined in HTTP 2.0 API THttpApiRequestAuthentications = set of ( haBasic, haDigest, haNtlm, haNegotiate, haKerberos); THttpApiServer = class; THttpApiServers = array of THttpApiServer; /// HTTP server using fast http.sys kernel-mode server // - The HTTP Server API enables applications to communicate over HTTP without // using Microsoft Internet Information Server (IIS). Applications can register // to receive HTTP requests for particular URLs, receive HTTP requests, and send // HTTP responses. The HTTP Server API includes SSL support so that applications // can exchange data over secure HTTP connections without IIS. It is also // designed to work with I/O completion ports. // - The HTTP Server API is supported on Windows Server 2003 operating systems // and on Windows XP with Service Pack 2 (SP2). Be aware that Microsoft IIS 5 // running on Windows XP with SP2 is not able to share port 80 with other HTTP // applications running simultaneously. THttpApiServer = class(THttpServerGeneric) protected /// the internal request queue fReqQueue: THandle; /// contain list of THttpApiServer cloned instances fClones: THttpApiServers; // if cloned, fOwner contains the main THttpApiServer instance fOwner: THttpApiServer; /// list of all registered URL fRegisteredUnicodeUrl: array of SockUnicode; fServerSessionID: HTTP_SERVER_SESSION_ID; fUrlGroupID: HTTP_URL_GROUP_ID; fLogData: pointer; fLogDataStorage: array of byte; fLoggingServiceName: SockString; fAuthenticationSchemes: THttpApiRequestAuthentications; fReceiveBufferSize: cardinal; procedure SetReceiveBufferSize(Value: cardinal); function GetRegisteredUrl: SockUnicode; function GetCloned: boolean; function GetHTTPQueueLength: Cardinal; override; procedure SetHTTPQueueLength(aValue: Cardinal); override; function GetMaxBandwidth: Cardinal; procedure SetMaxBandwidth(aValue: Cardinal); function GetMaxConnections: Cardinal; procedure SetMaxConnections(aValue: Cardinal); procedure SetOnTerminate(const Event: TNotifyThreadEvent); override; function GetAPIVersion: string; override; function GetLogging: boolean; procedure SetServerName(const aName: SockString); override; procedure SetOnRequest(const aRequest: TOnHttpServerRequest); override; procedure SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); override; procedure SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); override; procedure SetOnAfterRequest(const aEvent: TOnHttpServerRequest); override; procedure SetOnAfterResponse(const aEvent: TOnHttpServerAfterResponse); override; procedure SetMaximumAllowedContentLength(aMax: cardinal); override; procedure SetRemoteIPHeader(const aHeader: SockString); override; procedure SetRemoteConnIDHeader(const aHeader: SockString); override; procedure SetLoggingServiceName(const aName: SockString); /// server main loop - don't change directly // - will call the Request public virtual method with the appropriate // parameters to retrive the content procedure Execute; override; /// retrieve flags for SendHttpResponse // - if response content type is not HTTP_RESP_STATICFILE function GetSendResponseFlags(Ctxt: THttpServerRequest): integer; virtual; /// create a clone constructor CreateClone(From: THttpApiServer); virtual; /// free resources (for not cloned server) procedure DestroyMainThread; virtual; public /// initialize the HTTP Service // - will raise an exception if http.sys is not available e.g. before // Windows XP SP2) or if the request queue creation failed // - if you override this contructor, put the AddUrl() methods within, // and you can set CreateSuspended to FALSE // - if you will call AddUrl() methods later, set CreateSuspended to TRUE, // then call explicitely the Resume method, after all AddUrl() calls, in // order to start the server constructor Create(CreateSuspended: boolean; QueueName: SockUnicode=''; OnStart: TNotifyThreadEvent=nil; OnStop: TNotifyThreadEvent=nil; const ProcessName: SockString=''); reintroduce; /// release all associated memory and handles destructor Destroy; override; /// will clone this thread into multiple other threads // - could speed up the process on multi-core CPU // - will work only if the OnProcess property was set (this is the case // e.g. in TSQLHttpServer.Create() constructor) // - maximum value is 256 - higher should not be worth it procedure Clone(ChildThreadCount: integer); /// register the URLs to Listen On // - e.g. AddUrl('root','888') // - aDomainName could be either a fully qualified case-insensitive domain // name, an IPv4 or IPv6 literal string, or a wildcard ('+' will bound // to all domain names for the specified port, '*' will accept the request // when no other listening hostnames match the request for that port) // - return 0 (NO_ERROR) on success, an error code if failed: under Vista // and Seven, you could have ERROR_ACCESS_DENIED if the process is not // running with enough rights (by default, UAC requires administrator rights // for adding an URL to http.sys registration list) - solution is to call // the THttpApiServer.AddUrlAuthorize class method during program setup // - if this method is not used within an overridden constructor, default // Create must have be called with CreateSuspended = TRUE and then call the // Resume method after all Url have been added // - if aRegisterURI is TRUE, the URI will be registered (need adminitrator // rights) - default is FALSE, as defined by Windows security policy function AddUrl(const aRoot, aPort: SockString; Https: boolean=false; const aDomainName: SockString='*'; aRegisterURI: boolean=false; aContext: Int64=0): integer; /// un-register the URLs to Listen On // - this method expect the same parameters as specified to AddUrl() // - return 0 (NO_ERROR) on success, an error code if failed (e.g. // -1 if the corresponding parameters do not match any previous AddUrl) function RemoveUrl(const aRoot, aPort: SockString; Https: boolean=false; const aDomainName: SockString='*'): integer; /// will authorize a specified URL prefix // - will allow to call AddUrl() later for any user on the computer // - if aRoot is left '', it will authorize any root for this port // - must be called with Administrator rights: this class function is to be // used in a Setup program for instance, especially under Vista or Seven, // to reserve the Url for the server // - add a new record to the http.sys URL reservation store // - return '' on success, an error message otherwise // - will first delete any matching rule for this URL prefix // - if OnlyDelete is true, will delete but won't add the new authorization; // in this case, any error message at deletion will be returned class function AddUrlAuthorize(const aRoot, aPort: SockString; Https: boolean=false; const aDomainName: SockString='*'; OnlyDelete: boolean=false): string; /// will register a compression algorithm // - overridden method which will handle any cloned instances procedure RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer=1024); override; /// access to the internal THttpApiServer list cloned by this main instance // - as created by Clone() method property Clones: THttpApiServers read fClones; public { HTTP API 2.0 methods and properties } /// can be used to check if the HTTP API 2.0 is available function HasAPI2: boolean; /// enable HTTP API 2.0 advanced timeout settings // - all those settings are set for the current URL group // - will raise an EHttpApiServer exception if the old HTTP API 1.x is used // so you should better test the availability of the method first: // ! if aServer.HasAPI2 then // ! SetTimeOutLimits(....); // - aEntityBody is the time, in seconds, allowed for the request entity // body to arrive - default value is 2 minutes // - aDrainEntityBody is the time, in seconds, allowed for the HTTP Server // API to drain the entity body on a Keep-Alive connection - default value // is 2 minutes // - aRequestQueue is the time, in seconds, allowed for the request to // remain in the request queue before the application picks it up - default // value is 2 minutes // - aIdleConnection is the time, in seconds, allowed for an idle connection; // is similar to THttpServer.ServerKeepAliveTimeOut - default value is // 2 minutes // - aHeaderWait is the time, in seconds, allowed for the HTTP Server API // to parse the request header - default value is 2 minutes // - aMinSendRate is the minimum send rate, in bytes-per-second, for the // response - default value is 150 bytes-per-second // - any value set to 0 will set the HTTP Server API default value procedure SetTimeOutLimits(aEntityBody, aDrainEntityBody, aRequestQueue, aIdleConnection, aHeaderWait, aMinSendRate: cardinal); /// enable HTTP API 2.0 logging // - will raise an EHttpApiServer exception if the old HTTP API 1.x is used // so you should better test the availability of the method first: // ! if aServer.HasAPI2 then // ! LogStart(....); // - this method won't do anything on the cloned instances, but the main // instance logging state will be replicated to all cloned instances // - you can select the output folder and the expected logging layout // - aSoftwareName will set the optional W3C-only software name string // - aRolloverSize will be used only when aRolloverType is hlrSize procedure LogStart(const aLogFolder: TFileName; aType: THttpApiLoggingType=hltW3C; const aSoftwareName: TFileName=''; aRolloverType: THttpApiLoggingRollOver=hlrDaily; aRolloverSize: cardinal=0; aLogFields: THttpApiLogFields=[hlfDate..hlfSubStatus]; aFlags: THttpApiLoggingFlags=[hlfUseUTF8Conversion]); /// disable HTTP API 2.0 logging // - this method won't do anything on the cloned instances, but the main // instance logging state will be replicated to all cloned instances procedure LogStop; /// enable HTTP API 2.0 server-side authentication // - once enabled, the client sends an unauthenticated request: it is up to // the server application to generate the initial 401 challenge with proper // WWW-Authenticate headers; any further authentication steps will be // perform in kernel mode, until the authentication handshake is finalized; // later on, the application can check the AuthenticationStatus property // of THttpServerRequest and its associated AuthenticatedUser value // see https://msdn.microsoft.com/en-us/library/windows/desktop/aa364452 // - will raise an EHttpApiServer exception if the old HTTP API 1.x is used // so you should better test the availability of the method first: // ! if aServer.HasAPI2 then // ! SetAuthenticationSchemes(....); // - this method will work on the current group, for all instances // - see HTTPAPI_AUTH_ENABLE_ALL constant to set all available schemes // - optional Realm parameters can be used when haBasic scheme is defined // - optional DomainName and Realm parameters can be used for haDigest procedure SetAuthenticationSchemes(schemes: THttpApiRequestAuthentications; const DomainName: SockUnicode=''; const Realm: SockUnicode=''); /// read-only access to HTTP API 2.0 server-side enabled authentication schemes property AuthenticationSchemes: THttpApiRequestAuthentications read fAuthenticationSchemes; /// read-only access to check if the HTTP API 2.0 logging is enabled // - use LogStart/LogStop methods to change this property value property Logging: boolean read GetLogging; /// the current HTTP API 2.0 logging Service name // - should be UTF-8 encoded, if LogStart(aFlags=[hlfUseUTF8Conversion]) // - this value is dedicated to one instance, so the main instance won't // propagate the change to all cloned instances property LoggingServiceName: SockString read fLoggingServiceName write SetLoggingServiceName; /// read-only access to the low-level HTTP API 2.0 Session ID property ServerSessionID: HTTP_SERVER_SESSION_ID read fServerSessionID; /// read-only access to the low-level HTTP API 2.0 URI Group ID property UrlGroupID: HTTP_URL_GROUP_ID read fUrlGroupID; /// how many bytes are retrieved in a single call to ReceiveRequestEntityBody // - set by default to 1048576, i.e. 1 MB - practical limit is around 20 MB // - you may customize this value if you encounter HTTP error STATUS_NOTACCEPTABLE // (406) from client, corresponding to an ERROR_NO_SYSTEM_RESOURCES (1450) // exception on server side, when uploading huge data content property ReceiveBufferSize: cardinal read fReceiveBufferSize write SetReceiveBufferSize; published /// TRUE if this instance is in fact a cloned instance for the thread pool property Cloned: boolean read GetCloned; /// return the list of registered URL on this server instance property RegisteredUrl: SockUnicode read GetRegisteredUrl; /// the maximum allowed bandwidth rate in bytes per second (via HTTP API 2.0) // - Setting this value to 0 allows an unlimited bandwidth // - by default Windows not limit bandwidth (actually limited to 4 Gbit/sec). // - will return 0 if the system does not support HTTP API 2.0 (i.e. // under Windows XP or Server 2003) property MaxBandwidth: Cardinal read GetMaxBandwidth write SetMaxBandwidth; /// the maximum number of HTTP connections allowed (via HTTP API 2.0) // - Setting this value to 0 allows an unlimited number of connections // - by default Windows does not limit number of allowed connections // - will return 0 if the system does not support HTTP API 2.0 (i.e. // under Windows XP or Server 2003) property MaxConnections: Cardinal read GetMaxConnections write SetMaxConnections; end; /// low-level API reference to a WebSocket session WEB_SOCKET_HANDLE = Pointer; /// WebSocket close status as defined by http://tools.ietf.org/html/rfc6455#section-7.4 WEB_SOCKET_CLOSE_STATUS = Word; /// the bit values used to construct the WebSocket frame header for httpapi.dll // - not equals to WINHTTP_WEB_SOCKET_BUFFER_TYPE from winhttp.dll WEB_SOCKET_BUFFER_TYPE = ULONG; TSynThreadPoolHttpApiWebSocketServer = class; TSynWebSocketGuard = class; THttpApiWebSocketServer = class; THttpApiWebSocketServerProtocol = class; /// current state of a THttpApiWebSocketConnection TWebSocketState = (wsConnecting, wsOpen, wsClosing, wsClosedByClient, wsClosedByServer, wsClosedByGuard, wsClosedByShutdown); /// structure representing a single WebSocket connection {$ifdef UNICODE} THttpApiWebSocketConnection = record {$else} THttpApiWebSocketConnection = object {$endif} private fOverlapped: TOverlapped; fState: TWebSocketState; fProtocol: THttpApiWebSocketServerProtocol; fOpaqueHTTPRequestId: HTTP_REQUEST_ID; fWSHandle: WEB_SOCKET_HANDLE; fLastActionContext: Pointer; fLastReceiveTickCount: Int64; fPrivateData: pointer; fBuffer: SockString; fCloseStatus: WEB_SOCKET_CLOSE_STATUS; fIndex: integer; function ProcessActions(ActionQueue: Cardinal): boolean; function ReadData(const WebsocketBufferData): integer; procedure WriteData(const WebsocketBufferData); procedure BeforeRead; procedure DoOnMessage(aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG); procedure DoOnConnect; procedure DoOnDisconnect(); procedure InternalSend(aBufferType: WEB_SOCKET_BUFFER_TYPE; WebsocketBufferData: pointer); procedure Ping; procedure Disconnect; procedure CheckIsActive; // call onAccept Method of protocol, and if protocol not accept connection or // can not be accepted from other reasons return false else return true function TryAcceptConnection(aProtocol: THttpApiWebSocketServerProtocol; Ctxt: THttpServerRequest; aNeedHeader: boolean): boolean; public /// Index of connection in protocol's connection list property Index: integer read fIndex; /// Protocol of connection property Protocol: THttpApiWebSocketServerProtocol read fProtocol; /// Custom user data property PrivateData: pointer read fPrivateData write fPrivateData; /// Access to the current state of this connection property State: TWebSocketState read fState; /// Send data to client procedure Send(aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG); /// Close connection procedure Close(aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG); end; PHttpApiWebSocketConnection = ^THttpApiWebSocketConnection; THttpApiWebSocketConnectionVector = array[0..MaxInt div SizeOf(PHttpApiWebSocketConnection) - 1] of PHttpApiWebSocketConnection; PHttpApiWebSocketConnectionVector = ^THttpApiWebSocketConnectionVector; /// Event handlers for WebSocket THttpApiWebSocketServerOnAcceptEvent = function(Ctxt: THttpServerRequest; var Conn: THttpApiWebSocketConnection): Boolean of object; THttpApiWebSocketServerOnMessageEvent = procedure(const Conn: THttpApiWebSocketConnection; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG) of object; THttpApiWebSocketServerOnConnectEvent = procedure(const Conn: THttpApiWebSocketConnection) of object; THttpApiWebSocketServerOnDisconnectEvent = procedure(const Conn: THttpApiWebSocketConnection; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG) of object; /// Protocol Handler of websocket endpoints events // - maintains a list of all WebSockets clients for a given protocol THttpApiWebSocketServerProtocol = class private fName: SockString; fManualFragmentManagement: Boolean; fOnAccept: THttpApiWebSocketServerOnAcceptEvent; fOnMessage: THttpApiWebSocketServerOnMessageEvent; fOnFragment: THttpApiWebSocketServerOnMessageEvent; fOnConnect: THttpApiWebSocketServerOnConnectEvent; fOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; fConnections: PHttpApiWebSocketConnectionVector; fConnectionsCapacity: Integer; //Count of used connections. Some of them can be nil(if not used more) fConnectionsCount: Integer; fFirstEmptyConnectionIndex: Integer; fServer: THttpApiWebSocketServer; fSafe: TRTLCriticalSection; fPendingForClose: {$ifdef FPC}TFPList{$else}TList{$endif}; fIndex: integer; function AddConnection(aConn: PHttpApiWebSocketConnection): Integer; procedure RemoveConnection(index: integer); procedure doShutdown; public /// initialize the WebSockets process // - if aManualFragmentManagement is true, onMessage will appear only for whole // received messages, otherwise OnFragment handler must be passed (for video // broadcast, for example) constructor Create(const aName: SockString; aManualFragmentManagement: Boolean; aServer: THttpApiWebSocketServer; aOnAccept: THttpApiWebSocketServerOnAcceptEvent; aOnMessage: THttpApiWebSocketServerOnMessageEvent; aOnConnect: THttpApiWebSocketServerOnConnectEvent; aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; aOnFragment: THttpApiWebSocketServerOnMessageEvent=nil); /// finalize the process destructor Destroy; override; /// text identifier property Name: SockString read fName; /// identify the endpoint instance property Index: integer read fIndex; /// OnFragment event will be called for each fragment property ManualFragmentManagement: Boolean read fManualFragmentManagement; /// event triggerred when a WebSockets client is initiated property OnAccept: THttpApiWebSocketServerOnAcceptEvent read fOnAccept; /// event triggerred when a WebSockets message is received property OnMessage: THttpApiWebSocketServerOnMessageEvent read fOnMessage; /// event triggerred when a WebSockets client is connected property OnConnect: THttpApiWebSocketServerOnConnectEvent read fOnConnect; /// event triggerred when a WebSockets client is gracefully disconnected property OnDisconnect: THttpApiWebSocketServerOnDisconnectEvent read fOnDisconnect; /// event triggerred when a non complete frame is received // - required if ManualFragmentManagement is true property OnFragment: THttpApiWebSocketServerOnMessageEvent read fOnFragment; /// Send message to the WebSocket connection identified by its index function Send(index: Integer; aBufferType: ULONG; aBuffer: Pointer; aBufferSize: ULONG): boolean; /// Send message to all connections of this protocol function Broadcast(aBufferType: ULONG; aBuffer: Pointer; aBufferSize: ULONG): boolean; /// Close WebSocket connection identified by its index function Close(index: Integer; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG): boolean; end; THttpApiWebSocketServerProtocolDynArray = array of THttpApiWebSocketServerProtocol; PHttpApiWebSocketServerProtocolDynArray = ^THttpApiWebSocketServerProtocolDynArray; /// HTTP & WebSocket server using fast http.sys kernel-mode server // - can be used like simple THttpApiServer // - when AddUrlWebSocket is called WebSocket support are added // in this case WebSocket will receiving the frames in asynchronous THttpApiWebSocketServer = class(THttpApiServer) private fThreadPoolServer: TSynThreadPoolHttpApiWebSocketServer; fGuard: TSynWebSocketGuard; fLastConnection: PHttpApiWebSocketConnection; fPingTimeout: integer; fRegisteredProtocols: PHttpApiWebSocketServerProtocolDynArray; fOnWSThreadStart: TNotifyThreadEvent; fOnWSThreadTerminate: TNotifyThreadEvent; fSendOverlaped: TOverlapped; fServiceOverlaped: TOverlapped; fOnServiceMessage: TThreadMethod; procedure SetOnWSThreadTerminate(const Value: TNotifyThreadEvent); function GetProtocol(index: integer): THttpApiWebSocketServerProtocol; function getProtocolsCount: Integer; procedure SetOnWSThreadStart(const Value: TNotifyThreadEvent); protected function UpgradeToWebSocket(Ctxt: THttpServerRequest): cardinal; procedure DoAfterResponse(Ctxt: THttpServerRequest; const Code: cardinal); override; function GetSendResponseFlags(Ctxt: THttpServerRequest): Integer; override; constructor CreateClone(From: THttpApiServer); override; procedure DestroyMainThread; override; public /// initialize the HTTPAPI based Server with WebSocket support // - will raise an exception if http.sys or websocket.dll is not available // (e.g. before Windows 8) or if the request queue creation failed // - for aPingTimeout explanation see PingTimeout property documentation constructor Create(CreateSuspended: Boolean; aSocketThreadsCount: integer=1; aPingTimeout: integer=0; QueueName: SockUnicode=''; aOnWSThreadStart: TNotifyThreadEvent=nil; aOnWSThreadTerminate: TNotifyThreadEvent=nil); reintroduce; /// prepare the process for a given THttpApiWebSocketServerProtocol procedure RegisterProtocol(const aName: SockString; aManualFragmentManagement: Boolean; aOnAccept: THttpApiWebSocketServerOnAcceptEvent; aOnMessage: THttpApiWebSocketServerOnMessageEvent; aOnConnect: THttpApiWebSocketServerOnConnectEvent; aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; aOnFragment: THttpApiWebSocketServerOnMessageEvent=nil); /// register the URLs to Listen on using WebSocket // - aProtocols is an array of a recond with callbacks, server call during // WebSocket activity function AddUrlWebSocket(const aRoot, aPort: SockString; Https: boolean=false; const aDomainName: SockString='*'; aRegisterURI: boolean=false): integer; function Request(Ctxt: THttpServerRequest): cardinal; override; /// Ping timeout in seconds. 0 mean no ping. // - if connection not receive messages longer than this timeout // TSynWebSocketGuard will send ping frame // - if connection not receive any messages longer than double of // this timeout it will be closed property PingTimeout: integer read fPingTimeout; /// access to the associated endpoints property Protocols[index: integer]: THttpApiWebSocketServerProtocol read GetProtocol; /// access to the associated endpoints count property ProtocolsCount: Integer read getProtocolsCount; /// event called when the processing thread starts property OnWSThreadStart: TNotifyThreadEvent read FOnWSThreadStart write SetOnWSThreadStart; /// event called when the processing thread termintes property OnWSThreadTerminate: TNotifyThreadEvent read FOnWSThreadTerminate write SetOnWSThreadTerminate; /// can be called from any thread // - will send a "service" message to a WebSocketServer to wake up a WebSocket thread // - When a webSocket thread receives such a message it will call onServiceMessage in the thread context procedure SendServiceMessage; /// event called when a service message is raised property OnServiceMessage: TThreadMethod read fOnServiceMessage write fOnServiceMessage; end; /// a Thread Pool, used for fast handling WebSocket requests TSynThreadPoolHttpApiWebSocketServer = class(TSynThreadPool) protected fServer: THttpApiWebSocketServer; procedure OnThreadStart(Sender: TThread); procedure OnThreadTerminate(Sender: TThread); function NeedStopOnIOError: Boolean; override; // aContext is a PHttpApiWebSocketConnection, or fServer.fServiceOverlaped // (SendServiceMessage) or fServer.fSendOverlaped (WriteData) procedure Task(aCaller: TSynThread; aContext: Pointer); override; public /// initialize the thread pool constructor Create(Server: THttpApiWebSocketServer; NumberOfThreads: Integer=1); reintroduce; end; /// Thread for closing WebSocket connections which not response more than PingTimeout interval TSynWebSocketGuard = class(TThread) protected fServer: THttpApiWebSocketServer; fSmallWait, fWaitCount: integer; procedure Execute; override; public /// initialize the thread constructor Create(Server: THttpApiWebSocketServer); reintroduce; end; {$endif MSWINDOWS} /// meta-class of the THttpServerSocket process // - used to override THttpServerSocket.GetRequest for instance THttpServerSocketClass = class of THttpServerSocket; /// event handler used by THttpServer.Process to send a local file // when HTTP_RESP_STATICFILE content-type is returned by the service // - can be defined e.g. to use NGINX X-Accel-Redirect header // - should return true if the Context has been modified to serve the file, or // false so that the file will be manually read and sent from memory // - any exception during process will be returned as a STATUS_NOTFOUND page TOnHttpServerSendFile = function(Context: THttpServerRequest; const LocalFileName: TFileName): boolean of object; /// main HTTP server Thread using the standard Sockets API (e.g. WinSock) // - bind to a port and listen to incoming requests // - assign this requests to THttpServerResp threads from a ThreadPool // - it implements a HTTP/1.1 compatible server, according to RFC 2068 specifications // - if the client is also HTTP/1.1 compatible, KeepAlive connection is handled: // multiple requests will use the existing connection and thread; // this is faster and uses less resources, especialy under Windows // - a Thread Pool is used internaly to speed up HTTP/1.0 connections - a // typical use, under Linux, is to run this class behind a NGINX frontend, // configured as https reverse proxy, leaving default "proxy_http_version 1.0" // and "proxy_request_buffering on" options for best performance, and // setting KeepAliveTimeOut=0 in the THttpServer.Create constructor // - under windows, will trigger the firewall UAC popup at first run // - don't forget to use Free method when you are finished THttpServer = class(THttpServerGeneric) protected /// used to protect Process() call fProcessCS: TRTLCriticalSection; fHeaderRetrieveAbortDelay: integer; fThreadPool: TSynThreadPoolTHttpServer; fInternalHttpServerRespList: {$ifdef FPC}TFPList{$else}TList{$endif}; fServerConnectionCount: integer; fServerConnectionActive: integer; fServerKeepAliveTimeOut: cardinal; fSockPort, fTCPPrefix: SockString; fSock: TCrtSocket; fThreadRespClass: THttpServerRespClass; fOnSendFile: TOnHttpServerSendFile; fNginxSendFileFrom: array of TFileName; fHTTPQueueLength: cardinal; fExecuteState: (esNotStarted, esBinding, esRunning, esFinished); fStats: array[THttpServerSocketGetRequestResult] of integer; fSocketClass: THttpServerSocketClass; fHeadersNotFiltered: boolean; fExecuteMessage: string; function GetStat(one: THttpServerSocketGetRequestResult): integer; function GetHTTPQueueLength: Cardinal; override; procedure SetHTTPQueueLength(aValue: Cardinal); override; procedure InternalHttpServerRespListAdd(resp: THttpServerResp); procedure InternalHttpServerRespListRemove(resp: THttpServerResp); function OnNginxAllowSend(Context: THttpServerRequest; const LocalFileName: TFileName): boolean; // this overridden version will return e.g. 'Winsock 2.514' function GetAPIVersion: string; override; /// server main loop - don't change directly procedure Execute; override; /// this method is called on every new client connection, i.e. every time // a THttpServerResp thread is created with a new incoming socket procedure OnConnect; virtual; /// this method is called on every client disconnection to update stats procedure OnDisconnect; virtual; /// override this function in order to low-level process the request; // default process is to get headers, and call public function Request procedure Process(ClientSock: THttpServerSocket; ConnectionID: THttpServerConnectionID; ConnectionThread: TSynThread); virtual; public /// create a Server Thread, ready to be bound and listening on a port // - this constructor will raise a EHttpServer exception if binding failed // - expects the port to be specified as string, e.g. '1234'; you can // optionally specify a server address to bind to, e.g. '1.2.3.4:1234' // - can listed on UDS in case port is specified with 'unix:' prefix, e.g. // 'unix:/run/myapp.sock' // - on Linux in case aPort is empty string will check if external fd // is passed by systemd and use it (so called systemd socked activation) // - you can specify a number of threads to be initialized to handle // incoming connections. Default is 32, which may be sufficient for most // cases, maximum is 256. If you set 0, the thread pool will be disabled // and one thread will be created for any incoming connection // - you can also tune (or disable with 0) HTTP/1.1 keep alive delay and // how incoming request Headers[] are pushed to the processing method // - this constructor won't actually do the port binding, which occurs in // the background thread: caller should therefore call WaitStarted after // THttpServer.Create() constructor Create(const aPort: SockString; OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString; ServerThreadPoolCount: integer=32; KeepAliveTimeOut: integer=30000; HeadersUnFiltered: boolean=false; CreateSuspended: boolean = false); reintroduce; virtual; /// ensure the HTTP server thread is actually bound to the specified port // - TCrtSocket.Bind() occurs in the background in the Execute method: you // should call and check this method result just after THttpServer.Create // - initial THttpServer design was to call Bind() within Create, which // works fine on Delphi + Windows, but fails with a EThreadError on FPC/Linux // - raise a ECrtSocket if binding failed within the specified period (if // port is free, it would be almost immediate) // - calling this method is optional, but if the background thread didn't // actually bind the port, the server will be stopped and unresponsive with // no explicit error message, until it is terminated procedure WaitStarted(Seconds: integer = 30); virtual; /// enable NGINX X-Accel internal redirection for HTTP_RESP_STATICFILE // - will define internally a matching OnSendFile event handler // - generating "X-Accel-Redirect: " header, trimming any supplied left // case-sensitive file name prefix, e.g. with NginxSendFileFrom('/var/www'): // $ # Will serve /var/www/protected_files/myfile.tar.gz // $ # When passed URI /protected_files/myfile.tar.gz // $ location /protected_files { // $ internal; // $ root /var/www; // $ } // - call this method several times to register several folders procedure NginxSendFileFrom(const FileNameLeftTrim: TFileName); /// release all memory and handlers destructor Destroy; override; /// by default, only relevant headers are added to internal headers list // - for instance, Content-Length, Content-Type and Content-Encoding are // stored as fields in this THttpSocket, but not included in its Headers[] // - set this property to true to include all incoming headers property HeadersNotFiltered: boolean read fHeadersNotFiltered; /// access to the main server low-level Socket // - it's a raw TCrtSocket, which only need a socket to be bound, listening // and accept incoming request // - THttpServerSocket are created on the fly for every request, then // a THttpServerResp thread is created for handling this THttpServerSocket property Sock: TCrtSocket read fSock; /// custom event handler used to send a local file for HTTP_RESP_STATICFILE // - see also NginxSendFileFrom() method property OnSendFile: TOnHttpServerSendFile read fOnSendFile write fOnSendFile; published /// will contain the current number of connections to the server property ServerConnectionActive: integer read fServerConnectionActive write fServerConnectionActive; /// will contain the total number of connections to the server // - it's the global count since the server started property ServerConnectionCount: integer read fServerConnectionCount write fServerConnectionCount; /// time, in milliseconds, for the HTTP/1.1 connections to be kept alive // - default is 30000 ms, i.e. 30 seconds // - setting 0 here (or in KeepAliveTimeOut constructor parameter) will // disable keep-alive, and fallback to HTTP.1/0 for all incoming requests // (may be a good idea e.g. behind a NGINX reverse proxy) // - see THttpApiServer.SetTimeOutLimits(aIdleConnection) parameter property ServerKeepAliveTimeOut: cardinal read fServerKeepAliveTimeOut write fServerKeepAliveTimeOut; /// the bound TCP port, as specified to Create() constructor // - TCrtSocket.Bind() occurs in the Execute method property SockPort: SockString read fSockPort; /// TCP/IP prefix to mask HTTP protocol // - if not set, will create full HTTP/1.0 or HTTP/1.1 compliant content // - in order to make the TCP/IP stream not HTTP compliant, you can specify // a prefix which will be put before the first header line: in this case, // the TCP/IP stream won't be recognized as HTTP, and will be ignored by // most AntiVirus programs, and increase security - but you won't be able // to use an Internet Browser nor AJAX application for remote access any more property TCPPrefix: SockString read fTCPPrefix write fTCPPrefix; /// the associated thread pool // - may be nil if ServerThreadPoolCount was 0 on constructor property ThreadPool: TSynThreadPoolTHttpServer read fThreadPool; /// milliseconds delay to reject a connection due to too long header retrieval // - default is 0, i.e. not checked (typically not needed behind a reverse proxy) property HeaderRetrieveAbortDelay: integer read fHeaderRetrieveAbortDelay write fHeaderRetrieveAbortDelay; /// how many invalid HTTP headers have been rejected property StatHeaderErrors: integer index grError read GetStat; /// how many invalid HTTP headers raised an exception property StatHeaderException: integer index grException read GetStat; /// how many HTTP requests pushed more than MaximumAllowedContentLength bytes property StatOversizedPayloads: integer index grOversizedPayload read GetStat; /// how many HTTP requests were rejected by the OnBeforeBody event handler property StatRejected: integer index grRejected read GetStat; /// how many HTTP requests were rejected after HeaderRetrieveAbortDelay timeout property StatHeaderTimeout: integer index grTimeout read GetStat; /// how many HTTP headers have been processed property StatHeaderProcessed: integer index grHeaderReceived read GetStat; /// how many HTTP bodies have been processed property StatBodyProcessed: integer index grBodyReceived read GetStat; /// how many HTTP connections were passed to an asynchronous handler // - e.g. for background WebSockets processing after proper upgrade property StatOwnedConnections: integer index grOwned read GetStat; end; {$M-} /// structure used to parse an URI into its components // - ready to be supplied e.g. to a THttpRequest sub-class // - used e.g. by class function THttpRequest.Get() // - will decode standard HTTP/HTTPS urls or Unix sockets URI like // 'http://unix:/path/to/socket.sock:/url/path' {$ifdef USERECORDWITHMETHODS}TURI = record {$else}TURI = object{$endif} public /// if the server is accessible via https:// and not plain http:// Https: boolean; /// either cslTcp for HTTP/HTTPS or cslUnix for Unix socket URI Layer: TCrtSocketLayer; /// if the server is accessible via something else than http:// or https:// // - e.g. 'ws' or 'wss' for ws:// or wss:// Scheme: SockString; /// the server name // - e.g. 'www.somewebsite.com' or 'path/to/socket.sock' Unix socket URI Server: SockString; /// the server port // - e.g. '80' Port: SockString; /// the resource address, including optional parameters // - e.g. '/category/name/10?param=1' Address: SockString; /// fill the members from a supplied URI // - recognize e.g. 'http://Server:Port/Address', 'https://Server/Address', // 'Server/Address' (as http), or 'http://unix:/Server:/Address' // - returns TRUE is at least the Server has been extracted, FALSE on error function From(aURI: SockString; const DefaultPort: SockString=''): boolean; /// compute the whole normalized URI // - e.g. 'https://Server:Port/Address' or 'http://unix:/Server:/Address' function URI: SockString; /// the server port, as integer value function PortInt: integer; /// compute the root resource Address, without any URI-encoded parameter // - e.g. '/category/name/10' function Root: SockString; /// reset all stored information procedure Clear; end; /// the supported authentication schemes which may be used by HTTP clients // - supported only by TWinHTTP class yet THttpRequestAuthentication = (wraNone,wraBasic,wraDigest,wraNegotiate); /// a record to set some extended options for HTTP clients // - allow easy propagation e.g. from a TSQLHttpClient* wrapper class to // the actual SynCrtSock's THttpRequest implementation class THttpRequestExtendedOptions = record /// let HTTPS be less paranoid about SSL certificates // - IgnoreSSLCertificateErrors is handled by TWinHttp and TCurlHTTP IgnoreSSLCertificateErrors: boolean; /// allow HTTP authentication to take place at connection // - Auth.Scheme and UserName/Password properties are handled // by the TWinHttp class only by now Auth: record UserName: SockUnicode; Password: SockUnicode; Scheme: THttpRequestAuthentication; end; /// allow to customize the User-Agent header UserAgent: SockString; end; {$M+} // to have existing RTTI for published properties /// abstract class to handle HTTP/1.1 request // - never instantiate this class, but inherited TWinHTTP, TWinINet or TCurlHTTP THttpRequest = class protected fServer: SockString; fProxyName: SockString; fProxyByPass: SockString; fPort: cardinal; fHttps: boolean; fLayer: TCrtSocketLayer; fKeepAlive: cardinal; fExtendedOptions: THttpRequestExtendedOptions; /// used by RegisterCompress method fCompress: THttpSocketCompressRecDynArray; /// set by RegisterCompress method fCompressAcceptEncoding: SockString; /// set index of protocol in fCompress[], from ACCEPT-ENCODING: header fCompressAcceptHeader: THttpSocketCompressSet; fTag: PtrInt; class function InternalREST(const url,method,data,header: SockString; aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString=nil; outStatus: PInteger=nil): SockString; // inherited class should override those abstract methods procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); virtual; abstract; procedure InternalCreateRequest(const aMethod,aURL: SockString); virtual; abstract; procedure InternalSendRequest(const aMethod,aData: SockString); virtual; abstract; function InternalRetrieveAnswer(var Header,Encoding,AcceptEncoding, Data: SockString): integer; virtual; abstract; procedure InternalCloseRequest; virtual; abstract; procedure InternalAddHeader(const hdr: SockString); virtual; abstract; public /// returns TRUE if the class is actually supported on this system class function IsAvailable: boolean; virtual; abstract; /// connect to http://aServer:aPort or https://aServer:aPort // - optional aProxyName may contain the name of the proxy server to use, // and aProxyByPass an optional semicolon delimited list of host names or // IP addresses, or both, that should not be routed through the proxy: // aProxyName/aProxyByPass will be recognized by TWinHTTP and TWinINet, // and aProxyName will set the CURLOPT_PROXY option to TCurlHttp // (see https://curl.haxx.se/libcurl/c/CURLOPT_PROXY.html as reference) // - you can customize the default client timeouts by setting appropriate // SendTimeout and ReceiveTimeout parameters (in ms) - note that after // creation of this instance, the connection is tied to the initial // parameters, so we won't publish any properties to change those // initial values once created - if you left the 0 default parameters, it // would use global HTTP_DEFAULT_CONNECTTIMEOUT, HTTP_DEFAULT_SENDTIMEOUT // and HTTP_DEFAULT_RECEIVETIMEOUT variable values // - *TimeOut parameters are currently ignored by TCurlHttp constructor Create(const aServer, aPort: SockString; aHttps: boolean; const aProxyName: SockString=''; const aProxyByPass: SockString=''; ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0; aLayer: TCrtSocketLayer=cslTCP); overload; virtual; /// connect to the supplied URI // - is just a wrapper around TURI and the overloaded Create() constructor constructor Create(const aURI: SockString; const aProxyName: SockString=''; const aProxyByPass: SockString=''; ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0; aIgnoreSSLCertificateErrors: boolean=false); overload; /// low-level HTTP/1.1 request // - after an Create(server,port), return 200,202,204 if OK, // http status error otherwise // - KeepAlive is in milliseconds, 0 for "Connection: Close" HTTP/1.0 requests function Request(const url, method: SockString; KeepAlive: cardinal; const InHeader, InData, InDataType: SockString; out OutHeader, OutData: SockString): integer; virtual; /// wrapper method to retrieve a resource via an HTTP GET // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), // server name and port, and resource name // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates // - it will internally create a THttpRequest inherited instance: do not use // THttpRequest.Get() but either TWinHTTP.Get(), TWinINet.Get() or // TCurlHTTP.Get() methods class function Get(const aURI: SockString; const aHeader: SockString=''; aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; outStatus: PInteger=nil): SockString; /// wrapper method to create a resource via an HTTP POST // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), // server name and port, and resource name // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates // - the supplied aData content is POSTed to the server, with an optional // aHeader content // - it will internally create a THttpRequest inherited instance: do not use // THttpRequest.Post() but either TWinHTTP.Post(), TWinINet.Post() or // TCurlHTTP.Post() methods class function Post(const aURI, aData: SockString; const aHeader: SockString=''; aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; outStatus: PInteger=nil): SockString; /// wrapper method to update a resource via an HTTP PUT // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), // server name and port, and resource name // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates // - the supplied aData content is PUT to the server, with an optional // aHeader content // - it will internally create a THttpRequest inherited instance: do not use // THttpRequest.Put() but either TWinHTTP.Put(), TWinINet.Put() or // TCurlHTTP.Put() methods class function Put(const aURI, aData: SockString; const aHeader: SockString=''; aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; outStatus: PInteger=nil): SockString; /// wrapper method to delete a resource via an HTTP DELETE // - will parse the supplied URI to check for the http protocol (HTTP/HTTPS), // server name and port, and resource name // - aIgnoreSSLCerticateErrors will ignore the error when using untrusted certificates // - it will internally create a THttpRequest inherited instance: do not use // THttpRequest.Delete() but either TWinHTTP.Delete(), TWinINet.Delete() or // TCurlHTTP.Delete() methods class function Delete(const aURI: SockString; const aHeader: SockString=''; aIgnoreSSLCertificateErrors: boolean=true; outHeaders: PSockString=nil; outStatus: PInteger=nil): SockString; /// will register a compression algorithm // - used e.g. to compress on the fly the data, with standard gzip/deflate // or custom (synlzo/synlz) protocols // - returns true on success, false if this function or this // ACCEPT-ENCODING: header was already registered // - you can specify a minimal size (in bytes) before which the content won't // be compressed (1024 by default, corresponding to a MTU of 1500 bytes) // - the first registered algorithm will be the prefered one for compression function RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer=1024): boolean; /// allows to ignore untrusted SSL certificates // - similar to adding a security exception for a domain in the browser property IgnoreSSLCertificateErrors: boolean read fExtendedOptions.IgnoreSSLCertificateErrors write fExtendedOptions.IgnoreSSLCertificateErrors; /// optional Authentication Scheme property AuthScheme: THttpRequestAuthentication read fExtendedOptions.Auth.Scheme write fExtendedOptions.Auth.Scheme; /// optional User Name for Authentication property AuthUserName: SockUnicode read fExtendedOptions.Auth.UserName write fExtendedOptions.Auth.UserName; /// optional Password for Authentication property AuthPassword: SockUnicode read fExtendedOptions.Auth.Password write fExtendedOptions.Auth.Password; /// custom HTTP "User Agent:" header value property UserAgent: SockString read fExtendedOptions.UserAgent write fExtendedOptions.UserAgent; /// internal structure used to store extended options // - will be replicated by IgnoreSSLCertificateErrors and Auth* properties property ExtendedOptions: THttpRequestExtendedOptions read fExtendedOptions write fExtendedOptions; /// some internal field, which may be used by end-user code property Tag: PtrInt read fTag write fTag; published /// the remote server host name, as stated specified to the class constructor property Server: SockString read fServer; /// the remote server port number, as specified to the class constructor property Port: cardinal read fPort; /// if the remote server uses HTTPS, as specified to the class constructor property Https: boolean read fHttps; /// the remote server optional proxy, as specified to the class constructor property ProxyName: SockString read fProxyName; /// the remote server optional proxy by-pass list, as specified to the class // constructor property ProxyByPass: SockString read fProxyByPass; end; {$M-} /// store the actual class of a HTTP/1.1 client instance // - may be used to define at runtime which API to be used (e.g. WinHTTP, // WinINet or LibCurl), following the Liskov substitution principle THttpRequestClass = class of THttpRequest; {$ifdef USEWININET} TWinHttpAPI = class; /// event callback to track download progress, e.g. in the UI // - used in TWinHttpAPI.OnProgress property // - CurrentSize is the current total number of downloaded bytes // - ContentLength is retrieved from HTTP headers, but may be 0 if not set TWinHttpProgress = procedure(Sender: TWinHttpAPI; CurrentSize, ContentLength: DWORD) of object; /// event callback to process the download by chunks, not in memory // - used in TWinHttpAPI.OnDownload property // - CurrentSize is the current total number of downloaded bytes // - ContentLength is retrieved from HTTP headers, but may be 0 if not set // - ChunkSize is the size of the latest downloaded chunk, available in // the untyped ChunkData memory buffer // - implementation should return TRUE to continue the download, or FALSE // to abort the download process TWinHttpDownload = function(Sender: TWinHttpAPI; CurrentSize, ContentLength, ChunkSize: DWORD; const ChunkData): boolean of object; /// event callback to track upload progress, e.g. in the UI // - used in TWinHttpAPI.OnUpload property // - CurrentSize is the current total number of uploaded bytes // - ContentLength is the size of content // - implementation should return TRUE to continue the upload, or FALSE // to abort the upload process TWinHttpUpload = function(Sender: TWinHttpAPI; CurrentSize, ContentLength: DWORD): boolean of object; /// a class to handle HTTP/1.1 request using either WinINet or WinHTTP API // - both APIs have a common logic, which is encapsulated by this parent class // - this abstract class defined some abstract methods which will be // implemented by TWinINet or TWinHttp with the proper API calls TWinHttpAPI = class(THttpRequest) protected fOnProgress: TWinHttpProgress; fOnDownload: TWinHttpDownload; fOnUpload : TWinHttpUpload; fOnDownloadChunkSize: cardinal; /// used for internal connection fSession, fConnection, fRequest: HINTERNET; /// do not add "Accept: */*" HTTP header by default fNoAllAccept: boolean; function InternalGetInfo(Info: DWORD): SockString; virtual; abstract; function InternalGetInfo32(Info: DWORD): DWORD; virtual; abstract; function InternalQueryDataAvailable: DWORD; virtual; abstract; function InternalReadData(var Data: SockString; Read: integer; Size: cardinal): cardinal; virtual; abstract; function InternalRetrieveAnswer( var Header, Encoding, AcceptEncoding, Data: SockString): integer; override; public /// returns TRUE if the class is actually supported on this system class function IsAvailable: boolean; override; /// do not add "Accept: */*" HTTP header by default property NoAllAccept: boolean read fNoAllAccept write fNoAllAccept; /// download would call this method to notify progress of incoming data property OnProgress: TWinHttpProgress read fOnProgress write fOnProgress; /// download would call this method instead of filling Data: SockString value // - may be used e.g. when downloading huge content, and saving directly // the incoming data on disk or database // - if this property is set, raw TCP/IP incoming data would be supplied: // compression and encoding won't be handled by the class property OnDownload: TWinHttpDownload read fOnDownload write fOnDownload; /// upload would call this method to notify progress of outgoing data // - and optionally abort sending the data by returning FALSE property OnUpload : TWinHttpUpload read fOnUpload write fOnUpload; /// how many bytes should be retrieved for each OnDownload event chunk // - if default 0 value is left, would use 65536, i.e. 64KB property OnDownloadChunkSize: cardinal read fOnDownloadChunkSize write fOnDownloadChunkSize; end; /// a class to handle HTTP/1.1 request using the WinINet API // - The Microsoft Windows Internet (WinINet) application programming interface // (API) enables applications to access standard Internet protocols, such as // FTP and HTTP/HTTPS, similar to what IE offers // - by design, the WinINet API should not be used from a service, since this // API may require end-user GUI interaction // - note: WinINet is MUCH slower than THttpClientSocket or TWinHttp: do not // use this, only if you find some configuration benefit on some old networks // (e.g. to diaplay the dialup popup window for a GUI client application) TWinINet = class(TWinHttpAPI) protected // those internal methods will raise an EWinINet exception on error procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); override; procedure InternalCreateRequest(const aMethod,aURL: SockString); override; procedure InternalCloseRequest; override; procedure InternalAddHeader(const hdr: SockString); override; procedure InternalSendRequest(const aMethod,aData: SockString); override; function InternalGetInfo(Info: DWORD): SockString; override; function InternalGetInfo32(Info: DWORD): DWORD; override; function InternalQueryDataAvailable: DWORD; override; function InternalReadData(var Data: SockString; Read: integer; Size: cardinal): cardinal; override; public /// relase the connection destructor Destroy; override; end; /// WinINet exception type EWinINet = class(ECrtSocket) public /// create a WinINet exception, with the error message as text constructor Create; end; /// a class to handle HTTP/1.1 request using the WinHTTP API // - has a common behavior as THttpClientSocket() but seems to be faster // over a network and is able to retrieve the current proxy settings // (if available) and handle secure https connection - so it seems to be the // class to use in your client programs // - WinHTTP does not share any proxy settings with Internet Explorer. // The WinHTTP proxy configuration is set by either // $ proxycfg.exe // on Windows XP and Windows Server 2003 or earlier, either // $ netsh.exe // on Windows Vista and Windows Server 2008 or later; for instance, // you can run either: // $ proxycfg -u // $ netsh winhttp import proxy source=ie // to use the current user's proxy settings for Internet Explorer (under 64-bit // Vista/Seven, to configure applications using the 32 bit WinHttp settings, // call netsh or proxycfg bits from %SystemRoot%\SysWOW64 folder explicitely) // - Microsoft Windows HTTP Services (WinHTTP) is targeted at middle-tier and // back-end server applications that require access to an HTTP client stack TWinHTTP = class(TWinHttpAPI) protected // you can override this method e.g. to disable/enable some protocols function InternalGetProtocols: cardinal; virtual; // those internal methods will raise an EOSError exception on error procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); override; procedure InternalCreateRequest(const aMethod,aURL: SockString); override; procedure InternalCloseRequest; override; procedure InternalAddHeader(const hdr: SockString); override; procedure InternalSendRequest(const aMethod,aData: SockString); override; function InternalGetInfo(Info: DWORD): SockString; override; function InternalGetInfo32(Info: DWORD): DWORD; override; function InternalQueryDataAvailable: DWORD; override; function InternalReadData(var Data: SockString; Read: integer; Size: cardinal): cardinal; override; public /// relase the connection destructor Destroy; override; end; /// WinHTTP exception type EWinHTTP = class(Exception); /// types of WebSocket buffers for winhttp.dll // it is the different thing than WEB_SOCKET_BUFFER_TYPE for httpapi.dll WINHTTP_WEB_SOCKET_BUFFER_TYPE = ULONG; /// A class to establish a client connection to a WebSocket server using Windows API // - used by TWinWebSocketClient class TWinHTTPUpgradeable = class(TWinHTTP) private fSocket: HINTERNET; protected function InternalRetrieveAnswer(var Header, Encoding, AcceptEncoding, Data: SockString): integer; override; procedure InternalSendRequest(const aMethod,aData: SockString); override; public /// initialize the instance constructor Create(const aServer, aPort: SockString; aHttps: boolean; const aProxyName: SockString=''; const aProxyByPass: SockString=''; ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0; aLayer: TCrtSocketLayer=cslTCP); override; end; /// WebSocket client implementation TWinHTTPWebSocketClient = class protected fSocket: HINTERNET; function CheckSocket: Boolean; public /// initialize the instance // - all parameters do match TWinHTTP.Create except url: address of WebSocketServer // for sending upgrade request constructor Create(const aServer, aPort: SockString; aHttps: boolean; const url: SockString; const aSubProtocol: SockString = ''; const aProxyName: SockString=''; const aProxyByPass: SockString=''; ConnectionTimeOut: DWORD=0; SendTimeout: DWORD=0; ReceiveTimeout: DWORD=0); /// Send buffer function Send(aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE; aBuffer: pointer; aBufferLength: DWORD): DWORD; /// Receive buffer function Receive(aBuffer: pointer; aBufferLength: DWORD; out aBytesRead: DWORD; out aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE): DWORD; /// Close current connection function CloseConnection(const aCloseReason: SockString): DWORD; destructor Destroy; override; end; {$endif USEWININET} {$ifdef USELIBCURL} type /// libcurl exception type ECurlHTTP = class(Exception); /// a class to handle HTTP/1.1 request using the libcurl library // - libcurl is a free and easy-to-use cross-platform URL transfer library, // able to directly connect via HTTP or HTTPS on most Linux systems // - under a 32 bit Linux system, the libcurl library (and its dependencies, // like OpenSSL) may not be installed - you can add it via your package // manager, e.g. on Ubuntu: // $ sudo apt-get install libcurl3 // - under a 64-bit Linux system, if compiled with Kylix, you should install // the 32-bit flavor of libcurl, e.g. on Ubuntu: // $ sudo apt-get install libcurl3:i386 // - will use in fact libcurl.so, so either libcurl.so.3 or libcurl.so.4, // depending on the default version available on the system TCurlHTTP = class(THttpRequest) protected fHandle: pointer; fRootURL: SockString; fIn: record Headers: pointer; DataOffset: integer; URL, Method, Data: SockString; end; fOut: record Header, Encoding, AcceptEncoding, Data: SockString; end; fSSL: record CertFile, CACertFile, KeyName, PassPhrase: SockString; end; procedure InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); override; procedure InternalCreateRequest(const aMethod,aURL: SockString); override; procedure InternalSendRequest(const aMethod,aData: SockString); override; function InternalRetrieveAnswer(var Header,Encoding,AcceptEncoding, Data: SockString): integer; override; procedure InternalCloseRequest; override; procedure InternalAddHeader(const hdr: SockString); override; function GetCACertFile: SockString; procedure SetCACertFile(const aCertFile: SockString); public /// returns TRUE if the class is actually supported on this system class function IsAvailable: boolean; override; /// release the connection destructor Destroy; override; /// allow to set a CA certification file without touching the client certification property CACertFile: SockString read GetCACertFile write SetCACertFile; /// set the client SSL certification details // - see CACertFile if you don't want to change the whole client cert info // - used e.g. as // ! UseClientCertificate('testcert.pem','cacert.pem','testkey.pem','pass'); procedure UseClientCertificate( const aCertFile, aCACertFile, aKeyName, aPassPhrase: SockString); end; {$endif USELIBCURL} /// simple wrapper around THttpClientSocket/THttpRequest instances // - this class will reuse the previous connection if possible, and select the // best connection class available on this platform for a given URI TSimpleHttpClient = class protected fHttp: THttpClientSocket; fHttps: THttpRequest; fProxy, fBody, fHeaders, fUserAgent: SockString; fOnlyUseClientSocket, fIgnoreSSLCertificateErrors: boolean; public /// initialize the instance constructor Create(aOnlyUseClientSocket: boolean=false); reintroduce; /// finalize the connection destructor Destroy; override; /// low-level entry point of this instance function RawRequest(const Uri: TURI; const Method, Header, Data, DataType: SockString; KeepAlive: cardinal): integer; overload; /// simple-to-use entry point of this instance // - use Body and Headers properties to retrieve the HTTP body and headers function Request(const uri: SockString; const method: SockString='GET'; const header: SockString = ''; const data: SockString = ''; const datatype: SockString = ''; keepalive: cardinal=10000): integer; overload; /// returns the HTTP body as returned by a previous call to Request() property Body: SockString read fBody; /// returns the HTTP headers as returned by a previous call to Request() property Headers: SockString read fHeaders; /// allows to customize the user-agent header property UserAgent: SockString read fUserAgent write fUserAgent; /// allows to customize HTTPS connection and allow weak certificates property IgnoreSSLCertificateErrors: boolean read fIgnoreSSLCertificateErrors write fIgnoreSSLCertificateErrors; /// alows to customize the connection using a proxy property Proxy: SockString read fProxy write fProxy; end; /// returns the best THttpRequest class, depending on the system it runs on // - e.g. TWinHTTP or TCurlHTTP // - consider using TSimpleHttpClient if you just need a simple connection function MainHttpClass: THttpRequestClass; /// low-level forcing of another THttpRequest class // - could be used if we found out that the current MainHttpClass failed (which // could easily happen with TCurlHTTP if the library is missing or deprecated) procedure ReplaceMainHttpClass(aClass: THttpRequestClass); /// create a TCrtSocket, returning nil on error // (useful to easily catch socket error exception ECrtSocket) function Open(const aServer, aPort: SockString; aTLS: boolean=false): TCrtSocket; /// create a THttpClientSocket, returning nil on error // - useful to easily catch socket error exception ECrtSocket function OpenHttp(const aServer, aPort: SockString; aTLS: boolean=false; aLayer: TCrtSocketLayer = cslTCP): THttpClientSocket; overload; /// create a THttpClientSocket, returning nil on error // - useful to easily catch socket error exception ECrtSocket function OpenHttp(const aURI: SockString; aAddress: PSockString=nil): THttpClientSocket; overload; /// retrieve the content of a web page, using the HTTP/1.1 protocol and GET method // - this method will use a low-level THttpClientSock socket: if you want // something able to use your computer proxy, take a look at TWinINet.Get() or // the overloaded HttpGet() methods function HttpGet(const server, port: SockString; const url: SockString; const inHeaders: SockString; outHeaders: PSockString=nil; aLayer: TCrtSocketLayer = cslTCP): SockString; overload; /// retrieve the content of a web page, using the HTTP/1.1 protocol and GET method // - this method will use a low-level THttpClientSock socket for plain http URI, // or TWinHTTP/TCurlHTTP for any https URI, or if forceNotSocket is set to true function HttpGet(const aURI: SockString; outHeaders: PSockString=nil; forceNotSocket: boolean=false; outStatus: PInteger=nil): SockString; overload; /// retrieve the content of a web page, using the HTTP/1.1 protocol and GET method // - this method will use a low-level THttpClientSock socket for plain http URI, // or TWinHTTP/TCurlHTTP for any https URI function HttpGet(const aURI: SockString; const inHeaders: SockString; outHeaders: PSockString=nil; forceNotSocket: boolean=false; outStatus: PInteger=nil): SockString; overload; /// retrieve the content of a web page, using HTTP/1.1 GET method and a token // - this method will use a low-level THttpClientSock socket and its GetAuth method // - if AuthToken<>'', will add an header with 'Authorization: Bearer '+AuthToken function HttpGetAuth(const aURI, aAuthToken: SockString; outHeaders: PSockString=nil; forceNotSocket: boolean=false; outStatus: PInteger=nil): SockString; /// send some data to a remote web server, using the HTTP/1.1 protocol and POST method function HttpPost(const server, port: SockString; const url, Data, DataType: SockString; outData: PSockString=nil; const auth: SockString=''): boolean; /// send some data to a remote web server, using the HTTP/1.1 protocol and PUT method function HttpPut(const server, port: SockString; const url, Data, DataType: SockString; outData: PSockString=nil; const auth: SockString=''): boolean; /// compute the 'Authorization: Bearer ####' HTTP header of a given token value function AuthorizationBearer(const AuthToken: SockString): SockString; /// compute the '1.2.3.4' text representation of a raw IP4 binary procedure IP4Text(const ip4addr; var result: SockString); overload; /// compute the text representation of a IP4/IP6 low-level connection procedure IPText(const sin: TVarSin; var result: SockString; localasvoid: boolean=false); var /// defines if a connection from the loopback should be reported as '' // (no Remote-IP - which is the default) or as '127.0.0.1' (force to false) // - used by both TCrtSock.AcceptRequest and THttpApiServer.Execute servers RemoteIPLocalHostAsVoidInServers: boolean = true; const /// the layout of TSMTPConnection.FromText method SMTP_DEFAULT = 'user:password@smtpserver:port'; type /// may be used to store a connection to a SMTP server // - see SendEmail() overloaded function {$ifdef USERECORDWITHMETHODS}TSMTPConnection = record {$else}TSMTPConnection = object{$endif} public /// the SMTP server IP or host name Host: SockString; /// the SMTP server port (25 by default) Port: SockString; /// the SMTP user login (if any) User: SockString; /// the SMTP user password (if any) Pass: SockString; /// fill the STMP server information from a single text field // - expects 'user:password@smtpserver:port' format // - if aText equals SMTP_DEFAULT ('user:password@smtpserver:port'), // does nothing function FromText(const aText: SockString): boolean; end; /// send an email using the SMTP protocol // - retry true on success // - the Subject is expected to be in plain 7 bit ASCII, so you could use // SendEmailSubject() to encode it as Unicode, if needed // - you can optionally set the encoding charset to be used for the Text body function SendEmail(const Server, From, CSVDest, Subject, Text: SockString; const Headers: SockString=''; const User: SockString=''; const Pass: SockString=''; const Port: SockString='25'; const TextCharSet: SockString = 'ISO-8859-1'; aTLS: boolean=false): boolean; overload; /// send an email using the SMTP protocol // - retry true on success // - the Subject is expected to be in plain 7 bit ASCII, so you could use // SendEmailSubject() to encode it as Unicode, if needed // - you can optionally set the encoding charset to be used for the Text body, // or even TextCharSet='JSON' to force application/json function SendEmail(const Server: TSMTPConnection; const From, CSVDest, Subject, Text: SockString; const Headers: SockString=''; const TextCharSet: SockString = 'ISO-8859-1'; aTLS: boolean=false): boolean; overload; /// convert a supplied subject text into an Unicode encoding // - will convert the text into UTF-8 and append '=?UTF-8?B?' // - for pre-Unicode versions of Delphi, Text is expected to be already UTF-8 // encoded - since Delphi 2010, it will be converted from UnicodeString function SendEmailSubject(const Text: string): SockString; const /// HTTP Status Code for "Success" STATUS_SUCCESS = 200; /// HTTP Status Code for "Created" STATUS_CREATED = 201; /// HTTP Status Code for "Accepted" STATUS_ACCEPTED = 202; /// HTTP Status Code for "No Content" STATUS_NOCONTENT = 204; /// HTTP Status Code for "Partial Content" STATUS_PARTIALCONTENT = 206; /// HTTP Status Code for "Not Modified" STATUS_NOTMODIFIED = 304; /// HTTP Status Code for "Bad Request" STATUS_BADREQUEST = 400; /// HTTP Status Code for "Unauthorized" STATUS_UNAUTHORIZED = 401; /// HTTP Status Code for "Forbidden" STATUS_FORBIDDEN = 403; /// HTTP Status Code for "Not Found" STATUS_NOTFOUND = 404; /// HTTP Status Code for "Not Acceptable" STATUS_NOTACCEPTABLE = 406; /// HTTP Status Code for "Payload Too Large" STATUS_PAYLOADTOOLARGE = 413; /// HTTP Status Code for "Internal Server Error" STATUS_SERVERERROR = 500; /// HTTP Status Code for "Not Implemented" STATUS_NOTIMPLEMENTED = 501; /// HTTP Status Code for "HTTP Version Not Supported" STATUS_HTTPVERSIONNONSUPPORTED = 505; {$ifdef MSWINDOWS} /// can be used with THttpApiServer.AuthenticationSchemes to enable all schemes HTTPAPI_AUTH_ENABLE_ALL = [hraBasic..hraKerberos]; /// the buffer contains the last, and possibly only, part of a UTF8 message WEB_SOCKET_UTF8_MESSAGE_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000000; /// the buffer contains part of a UTF8 message WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000001; /// the buffer contains the last, and possibly only, part of a binary message WEB_SOCKET_BINARY_MESSAGE_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000002; /// the buffer contains part of a binary message WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000003; /// the buffer contains a close message WEB_SOCKET_CLOSE_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000004; /// the buffer contains a ping or pong message // - when sending, this value means 'ping' // - when processing received data, this value means 'pong' WEB_SOCKET_PING_PONG_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000005; /// the buffer contains an unsolicited pong message WEB_SOCKET_UNSOLICITED_PONG_BUFFER_TYPE: WEB_SOCKET_BUFFER_TYPE = $80000006; // https://msdn.microsoft.com/en-us/library/windows/desktop/hh449347 WEB_SOCKET_MAX_CLOSE_REASON_LENGTH = 123; /// Close completed successfully WEB_SOCKET_SUCCESS_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1000; /// The endpoint is going away and thus closing the connection WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1001; /// Peer detected protocol error and it is closing the connection WEB_SOCKET_PROTOCOL_ERROR_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1002; /// The endpoint cannot receive this type of data WEB_SOCKET_INVALID_DATA_TYPE_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1003; /// No close status code was provided WEB_SOCKET_EMPTY_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1005; /// The connection was closed without sending or receiving a close frame WEB_SOCKET_ABORTED_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1006; /// Data within a message is not consistent with the type of the message WEB_SOCKET_INVALID_PAYLOAD_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1007; /// The message violates an endpoint's policy WEB_SOCKET_POLICY_VIOLATION_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1008; /// The message sent was too large to process WEB_SOCKET_MESSAGE_TOO_BIG_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1009; /// A client endpoint expected the server to negotiate one or more extensions, // but the server didn't return them in the response message of the WebSocket handshake WEB_SOCKET_UNSUPPORTED_EXTENSIONS_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1010; /// An unexpected condition prevented the server from fulfilling the request WEB_SOCKET_SERVER_ERROR_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1011; /// The TLS handshake could not be completed WEB_SOCKET_SECURE_HANDSHAKE_ERROR_CLOSE_STATUS : WEB_SOCKET_CLOSE_STATUS = 1015; {$endif MSWINDOWS} /// retrieve the HTTP reason text from a code // - e.g. StatusCodeToReason(200)='OK' // - see http://www.w3.org/Protocols/rfc2616/rfc2616-sec10.html // - mORMot.StatusCodeToErrorMsg() will call this function function StatusCodeToReason(Code: cardinal): SockString; /// retrieve the IP address from a computer name function ResolveName(const Name: SockString; Family: Integer=AF_INET; SockProtocol: Integer=IPPROTO_TCP; SockType: integer=SOCK_STREAM): SockString; /// Base64 encoding of a string // - used internally for STMP email sending // - consider using more efficient BinToBase64() from SynCommons.pas instead function SockBase64Encode(const s: SockString): SockString; /// Base64 decoding of a string // - consider using more efficient Base64ToBin() from SynCommons.pas instead function SockBase64Decode(const s: SockString): SockString; /// escaping of HTML codes like < > & " function HtmlEncode(const s: SockString): SockString; /// decode a HTTP chunk length function HttpChunkToHex32(p: PAnsiChar): integer; {$ifdef MSWINDOWS} /// remotly get the MAC address of a computer, from its IP Address // - only works under Win2K and later // - return the MAC address as a 12 hexa chars ('0050C204C80A' e.g.) function GetRemoteMacAddress(const IP: SockString): SockString; {$else} /// returns how many files could be opened at once on this POSIX system // - hard=true is for the maximum allowed limit, false for the current process // - returns -1 if the getrlimit() API call failed function GetFileOpenLimit(hard: boolean=false): integer; /// changes how many files could be opened at once on this POSIX system // - hard=true is for the maximum allowed limit (requires root priviledges), // false for the current process // - returns the new value set (may not match the expected max value on error) // - returns -1 if the getrlimit().setrlimit() API calls failed // - for instance, to set the limit of the current process to its highest value: // ! SetFileOpenLimit(GetFileOpenLimit(true)); function SetFileOpenLimit(max: integer; hard: boolean=false): integer; {$endif MSWINDOWS} type TIPAddress = (tiaAny, tiaPublic, tiaPrivate); /// enumerate all IP addresses of the current computer // - may be used to enumerate all adapters function GetIPAddresses(Kind: TIPAddress = tiaAny): TSockStringDynArray; /// returns all IP addresses of the current computer as a single CSV text // - may be used to enumerate all adapters function GetIPAddressesText(const Sep: SockString = ' '; PublicOnly: boolean = false): SockString; type /// interface name/address pairs as returned by GetMacAddresses TMacAddress = record /// contains e.g. 'eth0' on Linux name: SockString; /// contains e.g. '12:50:b6:1e:c6:aa' from /sys/class/net/eth0/adddress address: SockString; end; TMacAddressDynArray = array of TMacAddress; /// enumerate all Mac addresses of the current computer function GetMacAddresses: TMacAddressDynArray; /// enumerate all Mac addresses of the current computer as 'name1=addr1 name2=addr2' function GetMacAddressesText: SockString; /// low-level text description of Socket error code // - if Error is -1, will call WSAGetLastError to retrieve the last error code function SocketErrorMessage(Error: integer=-1): string; /// low-level direct creation of a TSocket handle for TCP, UDP or UNIX layers // - doBind=true will call Bind() to create a server socket instance // - doBind=false will call Connect() to create a client socket instance function CallServer(const Server, Port: SockString; doBind: boolean; aLayer: TCrtSocketLayer; ConnectTimeout: DWORD): TSocket; /// retrieve the text-converted remote IP address of a client socket function GetRemoteIP(aClientSock: TSocket): SockString; /// low-level direct shutdown of a given socket procedure DirectShutdown(sock: TSocket; rdwr: boolean=false); /// low-level change of a socket to be in non-blocking mode // - used e.g. by TPollAsynchSockets.Start function AsynchSocket(sock: TSocket): boolean; /// low-level direct call of the socket recv() function // - by-pass overriden blocking recv() e.g. in SynFPCSock, so will work if // the socket is in non-blocking mode, as with AsynchSocket/TPollAsynchSockets function AsynchRecv(sock: TSocket; buf: pointer; buflen: integer): integer; /// low-level direct call of the socket send() function // - by-pass overriden blocking send() e.g. in SynFPCSock, so will work if // the socket is in non-blocking mode, as with AsynchSocket/TPollAsynchSockets function AsynchSend(sock: TSocket; buf: pointer; buflen: integer): integer; { ************ socket polling optimized for multiple connections } type /// the events monitored by TPollSocketAbstract classes // - we don't make any difference between urgent or normal read/write events TPollSocketEvent = (pseRead, pseWrite, pseError, pseClosed); /// set of events monitored by TPollSocketAbstract classes TPollSocketEvents = set of TPollSocketEvent; /// some opaque value (which may be a pointer) associated with a polling event TPollSocketTag = type PtrInt; /// modifications notified by TPollSocketAbstract.WaitForModified TPollSocketResult = record /// the events which are notified events: TPollSocketEvents; /// opaque value as defined by TPollSocketAbstract.Subscribe tag: TPollSocketTag; end; /// all modifications returned by TPollSocketAbstract.WaitForModified TPollSocketResults = array of TPollSocketResult; {$M+} /// abstract parent class for efficient socket polling // - works like Linux epoll API in level-triggered (LT) mode // - implements libevent-like cross-platform features // - use PollSockClass global function to retrieve the best class depending // on the running Operating System TPollSocketAbstract = class protected fCount: integer; fMaxSockets: integer; public /// class function factory, returning a socket polling instance matching // at best the current operating system // - returns a TPollSocketSelect/TPollSocketPoll instance under Windows, // a TPollSocketEpoll instance under Linux, or a TPollSocketPoll on BSD // - just a wrapper around PollSockClass.Create class function New: TPollSocketAbstract; /// initialize the polling constructor Create; virtual; /// track status modifications on one specified TSocket // - you can specify which events are monitored - pseError and pseClosed // will always be notified // - tag parameter will be returned as TPollSocketResult - you may set // here the socket file descriptor value, or a transtyped class instance // - similar to epoll's EPOLL_CTL_ADD control interface function Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; virtual; abstract; /// stop status modifications tracking on one specified TSocket // - the socket should have been monitored by a previous call to Subscribe() // - on success, returns true and fill tag with the associated opaque value // - similar to epoll's EPOLL_CTL_DEL control interface function Unsubscribe(socket: TSocket): boolean; virtual; abstract; /// waits for status modifications of all tracked TSocket // - will wait up to timeoutMS milliseconds, 0 meaning immediate return // and -1 for infinite blocking // - returns -1 on error (e.g. no TSocket currently registered), or // the number of modifications stored in results[] (may be 0 if none) function WaitForModified(out results: TPollSocketResults; timeoutMS: integer): integer; virtual; abstract; published /// how many TSocket instances could be tracked, at most // - depends on the API used property MaxSockets: integer read fMaxSockets; /// how many TSocket instances are currently tracked property Count: integer read fCount; end; {$M-} /// meta-class of TPollSocketAbstract socket polling classes // - since TPollSocketAbstract.Create is declared as virtual, could be used // to specify the proper polling class to add // - see PollSockClass function and TPollSocketAbstract.New method TPollSocketClass = class of TPollSocketAbstract; /// returns the TPollSocketAbstract class best fitting with the current // Operating System // - as used by TPollSocketAbstract.New method function PollSocketClass: TPollSocketClass; type {$ifdef MSWINDOWS} /// socket polling via Windows' Select() API // - under Windows, Select() handles up to 64 TSocket, and is available // in Windows XP, whereas WSAPoll() is available only since Vista // - under Linux, select() is very limited, so poll/epoll APIs are to be used // - in practice, TPollSocketSelect is slighlty FASTER than TPollSocketPoll // when tracking a lot of connections (at least under Windows): WSAPoll() // seems to be just an emulation API - very disapointing :( TPollSocketSelect = class(TPollSocketAbstract) protected fHighestSocket: integer; fRead: TFDSet; fWrite: TFDSet; fTag: array[0..FD_SETSIZE-1] of record socket: TSocket; tag: TPollSocketTag; end; public /// initialize the polling via creating an epoll file descriptor constructor Create; override; /// track status modifications on one specified TSocket // - you can specify which events are monitored - pseError and pseClosed // will always be notified function Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; override; /// stop status modifications tracking on one specified TSocket // - the socket should have been monitored by a previous call to Subscribe() function Unsubscribe(socket: TSocket): boolean; override; /// waits for status modifications of all tracked TSocket // - will wait up to timeoutMS milliseconds, 0 meaning immediate return // and -1 for infinite blocking // - returns -1 on error (e.g. no TSocket currently registered), or // the number of modifications stored in results[] (may be 0 if none) function WaitForModified(out results: TPollSocketResults; timeoutMS: integer): integer; override; end; {$endif MSWINDOWS} /// socket polling via poll/WSAPoll API // - direct call of the Linux/POSIX poll() API, or Windows WSAPoll() API TPollSocketPoll = class(TPollSocketAbstract) protected fFD: TPollFDDynArray; // fd=-1 for ignored fields fTags: array of TPollSocketTag; fFDCount: integer; procedure FDVacuum; public /// initialize the polling using poll/WSAPoll API constructor Create; override; /// track status modifications on one specified TSocket // - you can specify which events are monitored - pseError and pseClosed // will always be notified function Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; override; /// stop status modifications tracking on one specified TSocket // - the socket should have been monitored by a previous call to Subscribe() function Unsubscribe(socket: TSocket): boolean; override; /// waits for status modifications of all tracked TSocket // - will wait up to timeoutMS milliseconds, 0 meaning immediate return // and -1 for infinite blocking // - returns -1 on error (e.g. no TSocket currently registered), or // the number of modifications stored in results[] (may be 0 if none) function WaitForModified(out results: TPollSocketResults; timeoutMS: integer): integer; override; end; {$ifdef LINUXNOTBSD} /// socket polling via Linux epoll optimized API // - not available under Windows or BSD/Darwin // - direct call of the epoll API in level-triggered (LT) mode // - only available on Linux - use TPollSocketPoll for using cross-plaform // poll/WSAPoll API TPollSocketEpoll = class(TPollSocketAbstract) protected fEPFD: integer; fResults: TEPollEventDynArray; public /// initialize the polling via creating an epoll file descriptor constructor Create; override; /// finalize the polling by closing the epoll file descriptor destructor Destroy; override; /// track status modifications on one specified TSocket // - you can specify which events are monitored - pseError and pseClosed // will always be notified // - directly calls epoll's EPOLL_CTL_ADD control interface function Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; override; /// stop status modifications tracking on one specified TSocket // - the socket should have been monitored by a previous call to Subscribe() // - directly calls epoll's EPOLL_CTL_DEL control interface function Unsubscribe(socket: TSocket): boolean; override; /// waits for status modifications of all tracked TSocket // - will wait up to timeoutMS milliseconds, 0 meaning immediate return // and -1 for infinite blocking // - returns -1 on error (e.g. no TSocket currently registered), or // the number of modifications stored in results[] (may be 0 if none) // - directly calls epool_wait() function function WaitForModified(out results: TPollSocketResults; timeoutMS: integer): integer; override; /// read-only access to the low-level epoll_create file descriptor property EPFD: integer read fEPFD; end; {$endif LINUXNOTBSD} type {$M+} /// implements efficient polling of multiple sockets // - will maintain a pool of TPollSocketAbstract instances, to monitor // incoming data or outgoing availability for a set of active connections // - call Subscribe/Unsubscribe to setup the monitored sockets // - call GetOne from any consumming threads to process new events TPollSockets = class protected fPollClass: TPollSocketClass; fPoll: array of TPollSocketAbstract; fPollIndex: integer; fPending: TPollSocketResults; fPendingIndex: integer; fTerminated: boolean; fCount: integer; fPollLock: TRTLCriticalSection; fPendingLock: TRTLCriticalSection; public /// initialize the sockets polling // - you can specify the TPollSocketAbsract class to be used, if the // default is not the one expected // - under Linux/POSIX, will set the open files maximum number for the // current process to match the system hard limit: if your system has a // low "ulimit -H -n" value, you may add the following line in your // /etc/limits.conf or /etc/security/limits.conf file: // $ * hard nofile 65535 constructor Create(aPollClass: TPollSocketClass=nil); /// finalize the sockets polling, and release all used memory destructor Destroy; override; /// track modifications on one specified TSocket and tag // - the supplied tag value - maybe a PtrInt(aObject) - will be part of // GetOne method results // - will create as many TPollSocketAbstract instances as needed, depending // on the MaxSockets capability of the actual implementation class // - this method is thread-safe function Subscribe(socket: TSocket; tag: TPollSocketTag; events: TPollSocketEvents): boolean; virtual; /// stop status modifications tracking on one specified TSocket and tag // - the socket should have been monitored by a previous call to Subscribe() // - this method is thread-safe function Unsubscribe(socket: TSocket; tag: TPollSocketTag): boolean; virtual; /// retrieve the next pending notification, or let the poll wait for new // - if there is no pending notification, will poll and wait up to // timeoutMS milliseconds for pending data // - returns true and set notif.events/tag with the corresponding notification // - returns false if no pending event was handled within the timeoutMS period // - this method is thread-safe, and could be called from several threads function GetOne(timeoutMS: integer; out notif: TPollSocketResult): boolean; virtual; /// retrieve the next pending notification // - returns true and set notif.events/tag with the corresponding notification // - returns false if no pending event is available // - this method is thread-safe, and could be called from several threads function GetOneWithinPending(out notif: TPollSocketResult): boolean; /// notify any GetOne waiting method to stop its polling loop procedure Terminate; /// the actual polling class used to track socket state changes property PollClass: TPollSocketClass read fPollClass; /// set to true by the Terminate method property Terminated: boolean read fTerminated; published /// how many sockets are currently tracked property Count: integer read fCount; end; {$M-} /// store information of one TPollAsynchSockets connection {$ifdef USERECORDWITHMETHODS}TPollSocketsSlot = record {$else}TPollSocketsSlot = object{$endif} /// the associated TCP connection // - equals 0 after TPollAsynchSockets.Stop socket: TSocket; /// Lock/Unlock R/W thread acquisition (lighter than a TRTLCriticalSection) lockcounter: array[boolean] of integer; /// the last error reported by WSAGetLastError before the connection ends lastWSAError: integer; /// the current read data buffer of this slot readbuf: SockString; /// the current write data buffer of this slot writebuf: SockString; /// acquire an exclusive R/W access to this connection // - returns true if slot has been acquired // - returns false if it is used by another thread // - warning: this method is not re-entrant function Lock(writer: boolean): boolean; /// try to acquire an exclusive R/W access to this connection // - returns true if slot has been acquired // - returns false if it is used by another thread, after the timeoutMS period // - warning: this method is not re-entrant function TryLock(writer: boolean; timeoutMS: cardinal): boolean; /// release exclusive R/W access to this connection procedure UnLock(writer: boolean); end; /// points to thread-safe information of one TPollAsynchSockets connection PPollSocketsSlot = ^TPollSocketsSlot; /// possible options for TPollAsynchSockets process // - by default, TPollAsynchSockets.Write will first try to send the data // using Send() in non-blocking mode, unless paoWritePollOnly is defined, // and fWrite will be used to poll output state and send it asynchronously TPollAsynchSocketsOptions = set of (paoWritePollOnly); /// let TPollAsynchSockets.OnRead shutdown the socket if needed TPollAsynchSocketOnRead = (sorContinue, sorClose); {$M+} /// read/write buffer-oriented process of multiple non-blocking connections // - to be used e.g. for stream protocols (e.g. WebSockets or IoT communication) // - assigned sockets will be set in non-blocking mode, so that polling will // work as expected: you should then never use direclty the socket (e.g. via // blocking TCrtSocket), but rely on this class for asynchronous process: // OnRead() overriden method will receive all incoming data from input buffer, // and Write() should be called to add some data to asynchronous output buffer // - connections are identified as TObject instances, which should hold a // TPollSocketsSlot record as private values for the polling process // - ProcessRead/ProcessWrite methods are to be run for actual communication: // either you call those methods from multiple threads, or you run them in // loop from a single thread, then define a TSynThreadPool for running any // blocking process (e.g. computing requests answers) from OnRead callbacks // - inherited classes should override abstract OnRead, OnClose, OnError and // SlotFromConnection methods according to the actual connection class TPollAsynchSockets = class protected fRead: TPollSockets; fWrite: TPollSockets; fReadCount: integer; fWriteCount: integer; fReadBytes: Int64; fWriteBytes: Int64; fProcessing: integer; fOptions: TPollAsynchSocketsOptions; function GetCount: integer; // warning: abstract methods below should be properly overriden // return low-level socket information from connection instance function SlotFromConnection(connection: TObject): PPollSocketsSlot; virtual; abstract; // extract frames from slot.readbuf, and handle them function OnRead(connection: TObject): TPollAsynchSocketOnRead; virtual; abstract; // called when slot.writebuf has been sent through the socket procedure AfterWrite(connection: TObject); virtual; abstract; // pseClosed: should do connection.free - Stop() has been called (socket=0) procedure OnClose(connection: TObject); virtual; abstract; // pseError: return false to close socket and connection (calling OnClose) function OnError(connection: TObject; events: TPollSocketEvents): boolean; virtual; abstract; public /// initialize the read/write sockets polling // - fRead and fWrite TPollSocketsBuffer instances will track pseRead or // pseWrite events, and maintain input and output data buffers constructor Create; virtual; /// finalize buffer-oriented sockets polling, and release all used memory destructor Destroy; override; /// assign a new connection to the internal poll // - the TSocket handle will be retrieved via SlotFromConnection, and // set in non-blocking mode from now on - it is not recommended to access // it directly any more, but use Write() and handle OnRead() callback // - fRead will poll incoming packets, then call OnRead to handle them, // or Unsubscribe and delete the socket when pseClosed is notified // - fWrite will poll for outgoing packets as specified by Write(), then // send any pending data once the socket is ready function Start(connection: TObject): boolean; virtual; /// remove a connection from the internal poll, and shutdown its socket // - most of the time, the connection is released by OnClose when the other // end shutdown the socket; but you can explicitely call this method when // the connection (and its socket) is to be shutdown // - this method won't call OnClose, since it is initiated by the class function Stop(connection: TObject): boolean; virtual; /// add some data to the asynchronous output buffer of a given connection // - this method may block if the connection is currently writing from // another thread (which is not possible from TPollAsynchSockets.Write), // up to timeout milliseconds function Write(connection: TObject; const data; datalen: integer; timeout: integer=5000): boolean; virtual; /// add some data to the asynchronous output buffer of a given connection function WriteString(connection: TObject; const data: SockString): boolean; /// one or several threads should execute this method // - thread-safe handle of any incoming packets // - if this method is called from a single thread, you should use // a TSynThreadPool for any blocking process of OnRead events // - otherwise, this method is thread-safe, and incoming packets may be // consumed from a set of threads, and call OnRead with newly received data procedure ProcessRead(timeoutMS: integer); /// one or several threads should execute this method // - thread-safe handle of any outgoing packets procedure ProcessWrite(timeoutMS: integer); /// notify internal socket polls to stop their polling loop ASAP procedure Terminate(waitforMS: integer); /// low-level access to the polling class used for incoming data property PollRead: TPollSockets read fRead; /// low-level access to the polling class used for outgoind data property PollWrite: TPollSockets write fWrite; /// some processing options property Options: TPollAsynchSocketsOptions read fOptions write fOptions; published /// how many connections are currently managed by this instance property Count: integer read GetCount; /// how many times data has been received by this instance property ReadCount: integer read fReadCount; /// how many times data has been sent by this instance property WriteCount: integer read fWriteCount; /// how many data bytes have been received by this instance property ReadBytes: Int64 read fReadBytes; /// how many data bytes have been sent by this instance property WriteBytes: Int64 read fWriteBytes; end; {$M-} function SysErrorMessagePerModule(Code: DWORD; ModuleName: PChar): string; {$ifdef MSWINDOWS} /// is HTTP.SYS web socket API available on the target system Windows 8 and UP function WinHTTP_WebSocketEnabled: boolean; {$endif} var /// Queue length for completely established sockets waiting to be accepted, // a backlog parameter for listen() function. If queue overflows client // got ECONNREFUSED error for connect() call // - for windows default is taken from SynWinSock ($7fffffff) and should // not be modified. Actual limit is 200; // - for Unix default is taken from SynFPCSock (128 as in linux kernel >2.2), // but actual value is min(DefaultListenBacklog, /proc/sys/net/core/somaxconn) DefaultListenBacklog: integer = SOMAXCONN; implementation { ************ some shared helper functions and classes } var ReasonCache: array[1..5,0..13] of SockString; // avoid memory allocation function StatusCodeToReasonInternal(Code: cardinal): SockString; begin case Code of 100: result := 'Continue'; 101: result := 'Switching Protocols'; 200: result := 'OK'; 201: result := 'Created'; 202: result := 'Accepted'; 203: result := 'Non-Authoritative Information'; 204: result := 'No Content'; 205: result := 'Reset Content'; 206: result := 'Partial Content'; 207: result := 'Multi-Status'; 300: result := 'Multiple Choices'; 301: result := 'Moved Permanently'; 302: result := 'Found'; 303: result := 'See Other'; 304: result := 'Not Modified'; 305: result := 'Use Proxy'; 307: result := 'Temporary Redirect'; 308: result := 'Permanent Redirect'; 400: result := 'Bad Request'; 401: result := 'Unauthorized'; 403: result := 'Forbidden'; 404: result := 'Not Found'; 405: result := 'Method Not Allowed'; 406: result := 'Not Acceptable'; 407: result := 'Proxy Authentication Required'; 408: result := 'Request Timeout'; 409: result := 'Conflict'; 410: result := 'Gone'; 411: result := 'Length Required'; 412: result := 'Precondition Failed'; 413: result := 'Payload Too Large'; 414: result := 'URI Too Long'; 415: result := 'Unsupported Media Type'; 416: result := 'Requested Range Not Satisfiable'; 426: result := 'Upgrade Required'; 500: result := 'Internal Server Error'; 501: result := 'Not Implemented'; 502: result := 'Bad Gateway'; 503: result := 'Service Unavailable'; 504: result := 'Gateway Timeout'; 505: result := 'HTTP Version Not Supported'; 511: result := 'Network Authentication Required'; else result := 'Invalid Request'; end; end; function StatusCodeToReason(Code: cardinal): SockString; var Hi,Lo: cardinal; begin if Code=200 then begin // optimistic approach :) Hi := 2; Lo := 0; end else begin Hi := Code div 100; Lo := Code-Hi*100; if not ((Hi in [1..5]) and (Lo in [0..13])) then begin result := StatusCodeToReasonInternal(Code); exit; end; end; result := ReasonCache[Hi,Lo]; if result<>'' then exit; result := StatusCodeToReasonInternal(Code); ReasonCache[Hi,Lo] := result; end; function Hex2Dec(c: integer): integer; {$ifdef HASINLINE}inline;{$endif} begin result := c; case c of ord('A')..ord('Z'): dec(result,(ord('A') - 10)); ord('a')..ord('z'): dec(result,(ord('a') - 10)); ord('0')..ord('9'): dec(result,ord('0')); else result := -1; end; end; function SockBase64Encode(const s: SockString): SockString; procedure Encode(rp, sp: PAnsiChar; len: integer); const b64: array[0..63] of AnsiChar = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; var i: integer; c: cardinal; begin for i := 1 to len div 3 do begin c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8 + ord(sp[2]); rp[0] := b64[(c shr 18) and $3f]; rp[1] := b64[(c shr 12) and $3f]; rp[2] := b64[(c shr 6) and $3f]; rp[3] := b64[c and $3f]; inc(rp,4); inc(sp,3); end; case len mod 3 of 1: begin c := ord(sp[0]) shl 16; rp[0] := b64[(c shr 18) and $3f]; rp[1] := b64[(c shr 12) and $3f]; rp[2] := '='; rp[3] := '='; end; 2: begin c := ord(sp[0]) shl 16 + ord(sp[1]) shl 8; rp[0] := b64[(c shr 18) and $3f]; rp[1] := b64[(c shr 12) and $3f]; rp[2] := b64[(c shr 6) and $3f]; rp[3] := '='; end; end; end; var len: integer; begin result:=''; len := length(s); if len = 0 then exit; SetLength(result, ((len + 2) div 3) * 4); Encode(pointer(result),pointer(s),len); end; function SockBase64Decode(const s: SockString): SockString; var i, j, len: integer; sp, rp: PAnsiChar; c, ch: integer; begin result:= ''; len := length(s); if (len <= 0) or (len and 3 <> 0) then exit; len := len shr 2; SetLength(result, len * 3); sp := pointer(s); rp := pointer(result); for i := 1 to len do begin c := 0; j := 0; while true do begin ch := ord(sp[j]); case chr(ch) of 'A'..'Z': c := c or (ch - ord('A')); 'a'..'z': c := c or (ch - (ord('a')-26)); '0'..'9': c := c or (ch - (ord('0')-52)); '+': c := c or 62; '/': c := c or 63; else if j=3 then begin rp[0] := AnsiChar(c shr 16); rp[1] := AnsiChar(c shr 8); SetLength(result, len*3-1); exit; end else begin rp[0] := AnsiChar(c shr 10); SetLength(result, len*3-2); exit; end; end; if j=3 then break; inc(j); c := c shl 6; end; rp[2] := AnsiChar(c); c := c shr 8; rp[1] := AnsiChar(c); c := c shr 8; rp[0] := AnsiChar(c); inc(rp,3); inc(sp,4); end; end; function HtmlEncode(const s: SockString): SockString; var i: integer; begin // not very fast, but working result := ''; for i := 1 to length(s) do case s[i] of '<': result := result+'<'; '>': result := result+'>'; '&': result := result+'&'; '"': result := result+'"'; else result := result+s[i]; end; end; function HtmlEncodeString(const s: string): string; var i: integer; begin // not very fast, but working result := ''; for i := 1 to length(s) do case s[i] of '<': result := result+'<'; '>': result := result+'>'; '&': result := result+'&'; '"': result := result+'"'; else result := result+s[i]; end; end; const CRLF: array[0..1] of AnsiChar = (#13,#10); function StrLen(S: PAnsiChar): PtrInt; {$ifdef CPUX64} {$ifdef FPC}nostackframe; assembler; asm {$else} asm .noframe // rcx=S (Linux: rdi) {$endif FPC} // from GPL strlen64.asm by Agner Fog - www.agner.org/optimize {$ifdef win64} mov rax, rcx // get pointer to string from rcx mov r8, rcx // copy pointer test rcx, rcx {$else} mov rax, rdi mov ecx, edi test rdi, rdi {$endif} jz @null // returns 0 if S=nil // rax=s,ecx=32-bit of s pxor xmm0, xmm0 // set to zero and ecx, 15 // lower 4 bits indicate misalignment and rax, -16 // align pointer by 16 // will never read outside a memory page boundary, so won't trigger GPF movaps xmm1, [rax] // read from nearest preceding boundary pcmpeqb xmm1, xmm0 // compare 16 bytes with zero pmovmskb edx, xmm1 // get one bit for each byte result shr edx, cl // shift out false bits shl edx, cl // shift back again bsf edx, edx // find first 1-bit jnz @L2 // found // Main loop, search 16 bytes at a time {$ifdef FPC} align 16 {$else} .align 16 {$endif} @L1: add rax, 10H // increment pointer by 16 movaps xmm1, [rax] // read 16 bytes aligned pcmpeqb xmm1, xmm0 // compare 16 bytes with zero pmovmskb edx, xmm1 // get one bit for each byte result bsf edx, edx // find first 1-bit // (moving the bsf out of the loop and using test here would be faster // for long strings on old processors, but we are assuming that most // strings are short, and newer processors have higher priority) jz @L1 // loop if not found @L2: // Zero-byte found. Compute string length {$ifdef win64} sub rax, r8 // subtract start address {$else} sub rax, rdi {$endif} add rax, rdx // add byte index @null: end; {$else} begin result := 0; if S<>nil then while true do if S[0]<>#0 then if S[1]<>#0 then if S[2]<>#0 then if S[3]<>#0 then begin inc(S,4); inc(result,4); end else begin inc(result,3); exit; end else begin inc(result,2); exit; end else begin inc(result); exit; end else exit; end; {$endif CPUX64} type TNormToUpper = array[byte] of byte; PPByteArray = ^PByteArray; var NormToUpper: TNormToUpper; function IdemPCharUp(p: PByteArray; up: PByte; toup: PByteArray): boolean; {$ifdef HASINLINE}inline;{$endif} var u: byte; begin result := false; dec(PtrUInt(p),PtrUInt(up)); repeat u := up^; if u=0 then break; if toup[p[PtrUInt(up)]]<>u then exit; inc(up); until false; result := true; end; function IdemPChar(p, up: pAnsiChar): boolean; // if the beginning of p^ is same as up^ (ignore case - up^ must be already Upper) begin if p=nil then result := false else if up=nil then result := true else result := IdemPCharUp(pointer(p),pointer(up),@NormToUpper); end; function IdemPCharArray(p: PAnsiChar; const upArray: array of PAnsiChar): integer; var w: word; toup: PByteArray; up: ^PAnsiChar; begin if p<>nil then begin toup := @NormToUpper; w := toup[ord(p[0])]+toup[ord(p[1])]shl 8; up := @upArray[0]; for result := 0 to high(upArray) do if (PWord(up^)^=w) and IdemPCharUp(pointer(p+2),pointer(up^+2),toup) then exit else inc(up); end; result := -1; end; procedure GetNextItem(var P: PAnsiChar; Sep: AnsiChar; var result: SockString); // return next CSV string in P, nil if no more var S: PAnsiChar; begin if P=nil then result := '' else begin S := P; while (S^<>#0) and (S^<>Sep) do inc(S); SetString(result,P,S-P); if S^<>#0 then P := S+1 else P := nil; end; end; function SameText(const a,b: SockString): boolean; var n,i: integer; begin result := false; n := length(a); if length(b)<>n then exit; for i := 1 to n do if NormToUpper[ord(a[i])]<>NormToUpper[ord(b[i])] then exit; result := true; end; function GetNextItemUInt64(var P: PAnsiChar): ULONGLONG; var c: PtrUInt; begin result := 0; if P<>nil then repeat c := byte(P^)-48; if c>9 then break else result := result*10+ULONGLONG(c); inc(P); until false; end; // P^ will point to the first non digit char procedure GetNextLine(var P: PAnsiChar; var result: SockString); var S: PAnsiChar; begin if P=nil then result := '' else begin S := P; while S^>=' ' do // break on any control char inc(S); SetString(result,P,S-P); while (S^<>#0) and (S^<' ') do inc(S); // ignore e.g. #13 or #10 if S^<>#0 then P := S else P := nil; end; end; // rewrite some functions to avoid unattempted ansi<->unicode conversion function PosCh(ch: AnsiChar; const s: SockString): PtrInt; {$ifdef HASINLINE}inline;{$endif} begin // Pos() overloads are quite cumbersome on Delphi/FPC for result := 1 to length(s) do if s[result]=ch then exit; result := 0; end; procedure TrimCopy(const S: SockString; start,count: PtrInt; out result: SockString); // faster alternative to Trim(copy()) var L: PtrInt; begin if count<=0 then exit; if start<=0 then start := 1; L := Length(S); while (start<=L) and (S[start]<=' ') do begin inc(start); dec(count); end; dec(start); dec(L,start); if count0 do if S[start+L]<=' ' then dec(L) else break; if L>0 then SetString(result,PAnsiChar(@PByteArray(S)[start]),L); end; {$ifdef FPC_OR_PUREPASCAL} function Trim(const S: SockString): SockString; var i, L: PtrInt; begin L := Length(S); i := 1; while (i<=L) and (S[i]<=' ') do inc(i); if i>L then result := '' else if (i=1) and (S[L]>' ') then result := S else begin while S[L]<=' ' do dec(L); result := copy(S,i,L-i+1); end; end; {$else} function Trim(const S: SockString): SockString; asm // fast implementation by John O'Harrow test eax,eax {S = nil?} xchg eax,edx jz System.@LStrClr {Yes, Return Empty String} mov ecx,[edx-4] {Length(S)} cmp byte ptr [edx],' ' {S[1] <= ' '?} jbe @@TrimLeft {Yes, Trim Leading Spaces} cmp byte ptr [edx+ecx-1],' ' {S[Length(S)] <= ' '?} jbe @@TrimRight {Yes, Trim Trailing Spaces} jmp System.@LStrLAsg {No, Result := S (which occurs most time)} @@TrimLeft: {Strip Leading Whitespace} dec ecx jle System.@LStrClr {All Whitespace} inc edx cmp byte ptr [edx],' ' jbe @@TrimLeft @@CheckDone: cmp byte ptr [edx+ecx-1],' ' {$ifdef UNICODE} jbe @@TrimRight push 65535 // SockString code page for Delphi 2009 and up call System.@LStrFromPCharLen // we need a call, not a direct jmp ret {$else} ja System.@LStrFromPCharLen {$endif} @@TrimRight: {Strip Trailing Whitespace} dec ecx jmp @@CheckDone end; {$endif} function ExistNameValue(p,up: PAnsiChar): PAnsiChar; var tab: PByteArray; begin result := p; if p=nil then exit; tab := @NormToUpper; repeat if IdemPCharUp(pointer(result),pointer(up),tab) then exit; while result^>#13 do inc(result); while result^<=#13 do if result^=#0 then begin result := nil; exit; end else inc(result); until false; end; function FindHeaderValue(p: PAnsiChar; const up: SockString): PAnsiChar; begin result := ExistNameValue(p,pointer(up)); if result=nil then exit; inc(result,length(up)); if result^<>':' then result := nil else repeat inc(result); until (result^>' ') or (result^=#0); end; procedure GetHeaderValue(const s, up: SockString; var res: SockString); var p: PAnsiChar; L: PtrInt; begin p := FindHeaderValue(pointer(s),up); if (p=nil) or (p^=#0) then exit; L := 0; while p[L]>#13 do inc(L); while p[L-1]=' ' do dec(L); SetString(res,p,L); end; procedure ExtractNameValue(var headers: SockString; const upname: SockString; out res: SockString); var i,j,k: PtrInt; begin if (headers='') or (upname='') then exit; i := 1; repeat k := length(headers)+1; for j := i to k-1 do if headers[j]<' ' then begin k := j; break; end; if IdemPCharUp(@PByteArray(headers)[i-1],pointer(upname),@NormToUpper) then begin j := i; inc(i,length(upname)); TrimCopy(headers,i,k-i,res); while true do // delete also ending #13#10 if (headers[k]=#0) or (headers[k]>=' ') then break else inc(k); delete(headers,j,k-j); exit; end; i := k; while headers[i]<' ' do if headers[i]=#0 then exit else inc(i); until false; end; procedure UpperMove(Source, Dest: PByte; ToUp: PByteArray; L: cardinal); begin repeat Dest^ := ToUp[Source^]; dec(L); inc(Source); inc(Dest); until L=0; end; function UpperCase(const S: SockString): SockString; var L: cardinal; begin result := ''; L := Length(S); if L=0 then exit; SetLength(result,L); UpperMove(pointer(S),pointer(result),@NormToUpper,L); end; function GetCardinal(P: PAnsiChar): cardinal; overload; var c: cardinal; begin if P=nil then begin result := 0; exit; end; if P^=' ' then repeat inc(P) until P^<>' '; c := byte(P^)-48; if c>9 then result := 0 else begin result := c; inc(P); repeat c := byte(P^)-48; if c>9 then break else result := result*10+c; inc(P); until false; end; end; function GetCardinal(P,PEnd: PAnsiChar): cardinal; overload; var c: cardinal; begin result := 0; if (P=nil) or (P>=PEnd) then exit; if P^=' ' then repeat inc(P); if P=PEnd then exit; until P^<>' '; c := byte(P^)-48; if c>9 then exit; result := c; inc(P); while P9 then break else result := result*10+c; inc(P); end; end; function HttpChunkToHex32(p: PAnsiChar): integer; var v0,v1: integer; begin result := 0; if p<>nil then begin while p^=' ' do inc(p); repeat v0 := Hex2Dec(ord(p[0])); if v0<0 then break; // not in '0'..'9','a'..'f' v1 := Hex2Dec(ord(p[1])); inc(p); if v1<0 then begin result := (result shl 4) or v0; // only one char left break; end; result := (result shl 8) or (v0 shl 4) or v1; inc(p); until false; end; end; {$ifdef DELPHI5OROLDER} function Utf8ToAnsi(const UTF8: SockString): SockString; begin result := UTF8; // fallback to no conversion end; {$endif} const ENGLISH_LANGID = $0409; // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa383770 ERROR_WINHTTP_CANNOT_CONNECT = 12029; ERROR_WINHTTP_TIMEOUT = 12002; ERROR_WINHTTP_INVALID_SERVER_RESPONSE = 12152; function SysErrorMessagePerModule(Code: DWORD; ModuleName: PChar): string; {$ifdef MSWINDOWS} var tmpLen: DWORD; err: PChar; {$endif} begin result := ''; if Code=NO_ERROR then exit; {$ifdef MSWINDOWS} tmpLen := FormatMessage( FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_ALLOCATE_BUFFER, pointer(GetModuleHandle(ModuleName)),Code,ENGLISH_LANGID,@err,0,nil); // if string is empty, it may be because english is not found if (tmpLen = 0) then tmpLen := FormatMessage( FORMAT_MESSAGE_FROM_HMODULE or FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_IGNORE_INSERTS, pointer(GetModuleHandle(ModuleName)),Code,0,@err,0,nil); try while (tmpLen>0) and (ord(err[tmpLen-1]) in [0..32,ord('.')]) do dec(tmpLen); SetString(result,err,tmpLen); finally LocalFree(HLOCAL(err)); end; {$endif} if result='' then begin result := SysErrorMessage(Code); if result='' then if Code=ERROR_WINHTTP_CANNOT_CONNECT then result := 'cannot connect' else if Code=ERROR_WINHTTP_TIMEOUT then result := 'timeout' else if Code=ERROR_WINHTTP_INVALID_SERVER_RESPONSE then result := 'invalid server response' else result := IntToHex(Code,8); end; end; procedure RaiseLastModuleError(ModuleName: PChar; ModuleException: ExceptClass); var LastError: Integer; Error: Exception; begin LastError := GetLastError; if LastError<>NO_ERROR then Error := ModuleException.CreateFmt('%s error %d (%s)', [ModuleName,LastError,SysErrorMessagePerModule(LastError,ModuleName)]) else Error := ModuleException.CreateFmt('Undefined %s error',[ModuleName]); raise Error; end; function Ansi7ToUnicode(const Ansi: SockString): SockString; var n, i: PtrInt; begin // fast ANSI 7 bit conversion result := ''; if Ansi='' then exit; n := length(Ansi); SetLength(result,n*2+1); for i := 0 to n do // to n = including last #0 PWordArray(pointer(result))^[i] := PByteArray(pointer(Ansi))^[i]; end; function DefaultUserAgent(Instance: TObject): SockString; begin // note: some part of mORMot.pas would identify 'mORMot' pattern in the // agent header to enable advanced behavior e.g. about JSON transmission result := 'Mozilla/5.0 ('+XPOWEREDOS+'; '+XPOWEREDPROGRAM+' '+ SockString(Instance.ClassName)+')'; end; /// decode 'CONTENT-ENCODING: ' parameter from registered compression list function ComputeContentEncoding(const Compress: THttpSocketCompressRecDynArray; P: PAnsiChar): THttpSocketCompressSet; var i: PtrInt; aName: SockString; Beg: PAnsiChar; begin integer(result) := 0; if P<>nil then repeat while P^ in [' ',','] do inc(P); Beg := P; // 'gzip;q=1.0, deflate' -> aName='gzip' then 'deflate' while not (P^ in [';',',',#0]) do inc(P); SetString(aName,Beg,P-Beg); for i := 0 to high(Compress) do if aName=Compress[i].Name then include(result,i); while not (P^ in [',',#0]) do inc(P); until P^=#0; end; function RegisterCompressFunc(var Compress: THttpSocketCompressRecDynArray; aFunction: THttpSocketCompress; var aAcceptEncoding: SockString; aCompressMinSize: integer): SockString; var i, n: PtrInt; dummy, aName: SockString; begin result := ''; if @aFunction=nil then exit; n := length(Compress); aName := aFunction(dummy,true); for i := 0 to n-1 do with Compress[i] do if Name=aName then begin // already set if @Func=@aFunction then // update min. compress size value CompressMinSize := aCompressMinSize; exit; end; if n=sizeof(integer)*8 then exit; // fCompressAcceptHeader is 0..31 (casted as integer) SetLength(Compress,n+1); with Compress[n] do begin Name := aName; @Func := @aFunction; CompressMinSize := aCompressMinSize; end; if aAcceptEncoding='' then aAcceptEncoding := 'Accept-Encoding: '+aName else aAcceptEncoding := aAcceptEncoding+','+aName; result := aName; end; function CompressDataAndGetHeaders(Accepted: THttpSocketCompressSet; const Handled: THttpSocketCompressRecDynArray; const OutContentType: SockString; var OutContent: SockString): SockString; var i, OutContentLen: integer; compressible: boolean; OutContentTypeP: PAnsiChar absolute OutContentType; begin if (integer(Accepted)<>0) and (OutContentType<>'') and (Handled<>nil) then begin OutContentLen := length(OutContent); case IdemPCharArray(OutContentTypeP,['TEXT/','IMAGE/','APPLICATION/']) of 0: compressible := true; 1: compressible := IdemPCharArray(OutContentTypeP+6,['SVG','X-ICO'])>=0; 2: compressible := IdemPCharArray(OutContentTypeP+12,['JSON','XML','JAVASCRIPT'])>=0; else compressible := false; end; for i := 0 to high(Handled) do if i in Accepted then with Handled[i] do if (CompressMinSize=0) or // 0 here means "always" (e.g. for encryption) (compressible and (OutContentLen>=CompressMinSize)) then begin // compression of the OutContent + update header result := Func(OutContent,true); exit; // first in fCompress[] is prefered end; end; result := ''; end; procedure AppendI32(value: integer; var dest: shortstring); {$ifdef FPC}inline;{$endif} var temp: shortstring; begin str(value,temp); move(temp[1],dest[ord(dest[0])+1],ord(temp[0])); inc(dest[0],ord(temp[0])); end; procedure AppendI64(value: Int64; var dest: shortstring); var temp: shortstring; begin str(value,temp); move(temp[1],dest[ord(dest[0])+1],ord(temp[0])); inc(dest[0],ord(temp[0])); end; procedure AppendChar(chr: AnsiChar; var dest: shortstring); {$ifdef FPC}inline;{$endif} begin inc(dest[0]); dest[ord(dest[0])] := chr; end; var IP4local: SockString; // contains '127.0.0.1' procedure IP4Text(const ip4addr; var result: SockString); var b: array[0..3] of byte absolute ip4addr; s: shortstring; i: PtrInt; begin if cardinal(ip4addr)=0 then result := '' else if cardinal(ip4addr)=$0100007f then result := IP4local else begin s := ''; i := 0; repeat AppendI32(b[i],s); if i=3 then break; AppendChar('.',s); inc(i); until false; SetString(result,PAnsiChar(@s[1]),ord(s[0])); end; end; procedure IPText(const sin: TVarSin; var result: SockString; localasvoid: boolean); begin if sin.sin_family=AF_INET then if localasvoid and (cardinal(sin.sin_addr)=$0100007f) then result := '' else IP4Text(sin.sin_addr,result) else begin result := GetSinIP(sin); // AF_INET6 may be optimized in a future revision if result='::1' then if localasvoid then result := '' else result := IP4local; // IP6 localhost loopback benefits of matching IP4 end; end; function IsPublicIP(ip4: cardinal): boolean; begin result := false; case ip4 and 255 of // ignore IANA private IP4 address spaces 10: exit; 172: if ((ip4 shr 8) and 255) in [16..31] then exit; 192: if (ip4 shr 8) and 255=168 then exit; end; result := true; end; {$ifdef MSWINDOWS} {$ifdef FPC} // oddly not defined in fpc\rtl\win function SwitchToThread: BOOL; stdcall; external kernel32 name 'SwitchToThread'; {$endif} procedure SleepHiRes(ms: cardinal); // see SynKylix/SynFPCLinux for POSIX begin if (ms<>0) or not SwitchToThread then Windows.Sleep(ms); end; const HexCharsLower: array[0..15] of AnsiChar = '0123456789abcdef'; procedure BinToHexDisplayW(Bin: PByte; BinBytes: integer; var result: SockUnicode); var j: PtrInt; P: PWideChar; begin SetString(Result,nil,BinBytes*2); P := pointer(Result); for j := BinBytes-1 downto 0 do begin P[j*2] := WideChar(HexCharsLower[Bin^ shr 4]); P[j*2+1] := WideChar(HexCharsLower[Bin^ and $F]); inc(Bin); end; end; function MacToText(pMacAddr: PByteArray): SockString; var P: PAnsiChar; i: PtrInt; begin SetLength(result,17); P := pointer(result); i := 0; repeat P[0] := HexCharsLower[pMacAddr[i] shr 4]; P[1] := HexCharsLower[pMacAddr[i] and $F]; if i = 5 then break; P[2] := ':'; // as in Linux inc(P,3); inc(i); until false; end; function SendARP(DestIp: DWORD; srcIP: DWORD; pMacAddr: pointer; PhyAddrLen: Pointer): DWORD; stdcall; external 'iphlpapi.dll'; function GetRemoteMacAddress(const IP: SockString): SockString; // implements http://msdn.microsoft.com/en-us/library/aa366358 var dwRemoteIP: DWORD; PhyAddrLen: Longword; pMacAddr: array [0..7] of byte; begin result := ''; dwremoteIP := inet_addr(pointer(IP)); if dwremoteIP<>0 then begin PhyAddrLen := 8; if SendARP(dwremoteIP,0,@pMacAddr,@PhyAddrLen)=NO_ERROR then begin if PhyAddrLen=6 then result := MacToText(@pMacAddr); end; end; end; type PMIB_IPADDRTABLE = ^MIB_IPADDRTABLE; MIB_IPADDRTABLE = record dwNumEntries: DWORD; ip: array[0..200] of record dwAddr: DWORD; dwIndex: DWORD; dwMask: DWORD; dwBCastAddr: DWORD; dwReasmSize: DWORD; unused1: Word; wType: Word; end; end; function GetIpAddrTable(pIpAddrTable: PMIB_IPADDRTABLE; var pdwSize: DWORD; bOrder: BOOL): DWORD; stdcall; external 'iphlpapi.dll'; const MAX_ADAPTER_ADDRESS_LENGTH = 8; GAA_FLAG_SKIP_UNICAST = $1; GAA_FLAG_SKIP_ANYCAST = $2; GAA_FLAG_SKIP_MULTICAST = $4; GAA_FLAG_SKIP_DNS_SERVER = $8; GAA_FLAG_SKIP_FRIENDLY_NAME = $20; GAA_FLAG_INCLUDE_ALL_INTERFACES = $100; // Vista+ GAA_FLAGS = GAA_FLAG_SKIP_UNICAST or GAA_FLAG_SKIP_ANYCAST or GAA_FLAG_SKIP_MULTICAST or GAA_FLAG_SKIP_DNS_SERVER or GAA_FLAG_SKIP_FRIENDLY_NAME; // or GAA_FLAG_INCLUDE_ALL_INTERFACES; IfOperStatusUp = 1; type SOCKET_ADDRESS = record lpSockaddr: PSOCKADDR; iSockaddrLength: Integer; end; PIP_ADAPTER_UNICAST_ADDRESS = pointer; PIP_ADAPTER_ANYCAST_ADDRESS = pointer; PIP_ADAPTER_DNS_SERVER_ADDRESS = pointer; PIP_ADAPTER_MULTICAST_ADDRESS = pointer; PIP_ADAPTER_ADDRESSES = ^_IP_ADAPTER_ADDRESSES; _IP_ADAPTER_ADDRESSES = record Union: record case Integer of 0: ( Alignment: ULONGLONG); 1: ( Length: ULONG; IfIndex: DWORD); end; Next: PIP_ADAPTER_ADDRESSES; AdapterName: PAnsiChar; FirstUnicastAddress: PIP_ADAPTER_UNICAST_ADDRESS; FirstAnycastAddress: PIP_ADAPTER_ANYCAST_ADDRESS; FirstMulticastAddress: PIP_ADAPTER_MULTICAST_ADDRESS; FirstDnsServerAddress: PIP_ADAPTER_DNS_SERVER_ADDRESS; DnsSuffix: PWCHAR; Description: PWCHAR; FriendlyName: PWCHAR; PhysicalAddress: array [0..MAX_ADAPTER_ADDRESS_LENGTH - 1] of BYTE; PhysicalAddressLength: DWORD; Flags: DWORD; Mtu: DWORD; IfType: ULONG; OperStatus: DWORD; // below fields are only available on Windows XP with SP1 and later Ipv6IfIndex: ULONG; ZoneIndices: array [0..15] of DWORD; FirstPrefix: pointer; // below fields are only available on Windows Vista and later TransmitLinkSpeed: Int64; ReceiveLinkSpeed: Int64; FirstWinsServerAddress: pointer; FirstGatewayAddress: pointer; Ipv4Metric: ULONG; Ipv6Metric: ULONG; Luid: Int64; Dhcpv4Server: SOCKET_ADDRESS; CompartmentId: DWORD; NetworkGuid: TGUID; ConnectionType: DWORD; TunnelType: DWORD; // DHCP v6 Info following end; function GetAdaptersAddresses(Family: ULONG; Flags: DWORD; Reserved: pointer; pAdapterAddresses: PIP_ADAPTER_ADDRESSES; pOutBufLen: PULONG): DWORD; stdcall; external 'iphlpapi.dll'; function GetIPAddresses(Kind: TIPAddress): TSockStringDynArray; var Table: MIB_IPADDRTABLE; Size: DWORD; i: integer; n: cardinal; begin result := nil; Size := SizeOf(Table); if GetIpAddrTable(@Table,Size,false)<>NO_ERROR then exit; SetLength(result,Table.dwNumEntries); n := 0; for i := 0 to Table.dwNumEntries-1 do with Table.ip[i] do if (dwAddr<>$0100007f) and (dwAddr<>0) then begin case Kind of tiaPublic: if not IsPublicIP(dwAddr) then continue; tiaPrivate: if IsPublicIP(dwAddr) then continue; end; IP4Text(dwAddr,result[n]); inc(n); end; if n<>Table.dwNumEntries then SetLength(result,n); end; {$else MSWINDOWS} function GetFileOpenLimit(hard: boolean=false): integer; var limit: TRLIMIT; begin {$ifdef FPC} if fpgetrlimit(RLIMIT_NOFILE,@limit)=0 then {$else} if getrlimit(RLIMIT_NOFILE,limit)=0 then {$endif} if hard then result := limit.rlim_max else result := limit.rlim_cur else result := -1; end; function SetFileOpenLimit(max: integer; hard: boolean=false): integer; var limit: TRLIMIT; begin result := -1; {$ifdef FPC} if fpgetrlimit(RLIMIT_NOFILE,@limit)<>0 then {$else} if getrlimit(RLIMIT_NOFILE,limit)<>0 then {$endif} exit; if (hard and (integer(limit.rlim_max)=max)) or (not hard and (integer(limit.rlim_cur)=max)) then begin result := max; // already to the expected value exit; end; if hard then limit.rlim_max := max else limit.rlim_cur := max; {$ifdef FPC} if fpsetrlimit(RLIMIT_NOFILE,@limit)=0 then {$else} if setrlimit(RLIMIT_NOFILE,limit)=0 then {$endif} result := GetFileOpenLimit(hard); end; {$define USE_IFADDRS} {$ifdef USE_IFADDRS} type Pifaddrs = ^ifaddrs; ifaddrs = record ifa_next: Pifaddrs; ifa_name: PAnsiChar; ifa_flags: cardinal; ifa_addr: Psockaddr; ifa_netmask: Psockaddr; ifa_dstaddr: Psockaddr; ifa_data: Pointer; end; const IFF_UP = $1; IFF_LOOPBACK = $8; {$ifndef KYLIX3} libcmodulename = 'c'; {$endif} function getifaddrs(var ifap: Pifaddrs): Integer; cdecl; external libcmodulename name 'getifaddrs'; procedure freeifaddrs(ifap: Pifaddrs); cdecl; external libcmodulename name 'freeifaddrs'; function GetIPAddresses(Kind: TIPAddress): TSockStringDynArray; var list, info: Pifaddrs; n, dwAddr: integer; s: SockString; begin result := nil; n := 0; if getifaddrs(list)=0 then try info := list; repeat if (info^.ifa_addr<>nil) and (info^.ifa_flags and IFF_LOOPBACK=0) and (info^.ifa_flags and IFF_UP<>0) then begin s := ''; case info^.ifa_addr^.sa_family of AF_INET: begin dwAddr := integer(info^.ifa_addr^.sin_addr); if (dwAddr<>$0100007f) and (dwAddr<>0) then case Kind of tiaPublic: if IsPublicIP(dwAddr) then IP4Text(dwAddr,s); tiaPrivate: if not IsPublicIP(dwAddr) then IP4Text(dwAddr,s); tiaAny: IP4Text(dwAddr,s); end; //s := s+'@'+info^.ifa_name; end; //AF_INET6: IPText(PVarSin(info^.ifa_addr)^,s); end; if s<>'' then begin if n=length(result) then SetLength(result,n+8); result[n] := s; inc(n); end; end; info := info^.ifa_next; until info=nil; finally freeifaddrs(list); end; if n<>length(result) then SetLength(result,n); end; {$else} function GetIPAddresses(Kind: TIPAddress): TSockStringDynArray; begin result := nil; end; {$endif USE_IFADDRS} {$endif MSWINDOWS} {$ifdef MSWINDOWS} var // not available before Vista -> Lazy loading GetTick64: function: Int64; stdcall; GetTickXP: Int64Rec; function GetTick64ForXP: Int64; stdcall; var t32: cardinal; t64: Int64Rec absolute result; begin // warning: GetSystemTimeAsFileTime() is fast, but not monotonic! t32 := Windows.GetTickCount; t64 := GetTickXP; // (almost) atomic read if t32IPAddressesTix[PublicOnly] then IPAddressesTix[PublicOnly] := tix else begin result := IPAddressesText[PublicOnly]; if result<>'' then exit; end; end; if PublicOnly then ip := GetIPAddresses(tiaPublic) else ip := GetIPAddresses(tiaAny); if ip=nil then exit; result := ip[0]; for i := 1 to high(ip) do result := result+Sep+ip[i]; if Sep=' ' then IPAddressesText[PublicOnly] := result; end; var MacAddressesSearched: boolean; // will not change during process lifetime MacAddresses: TMacAddressDynArray; MacAddressesText: SockString; {$ifdef LINUX} procedure GetSmallFile(const fn: TFileName; out result: SockString); var tmp: array[byte] of AnsiChar; F: THandle; t: PtrInt; begin F := FileOpen(fn, fmOpenRead or fmShareDenyNone); if PtrInt(F) < 0 then exit; t := FileRead(F, tmp, SizeOf(tmp)); FileClose(F); while (t > 0) and (tmp[t - 1] <= ' ') do dec(t); // trim right if t > 0 then SetString(result, PAnsiChar(@tmp), t); end; {$endif LINUX} procedure RetrieveMacAddresses; var n: integer; {$ifdef LINUX} SR: TSearchRec; fn: TFileName; f: SockString; {$endif LINUX} {$ifdef MSWINDOWS} tmp: array[word] of byte; siz: ULONG; p: PIP_ADAPTER_ADDRESSES; {$endif MSWINDOWS} begin EnterCriticalSection(SynSockCS); try if MacAddressesSearched then exit; n := 0; {$ifdef LINUX} if FindFirst('/sys/class/net/*', faDirectory, SR) = 0 then begin repeat if (SR.Name <> 'lo') and (SR.Name[1] <> '.') then begin fn := '/sys/class/net/' + SR.Name; GetSmallFile(fn + '/flags', f); if (length(f) > 2) and // e.g. '0x40' or '0x1043' (HttpChunkToHex32(@f[3]) and (IFF_UP or IFF_LOOPBACK) = IFF_UP) then begin GetSmallFile(fn + '/address', f); if f <> '' then begin SetLength(MacAddresses, n + 1); MacAddresses[n].name := SR.Name; MacAddresses[n].address := f; inc(n); end; end; end; until FindNext(SR) <> 0; FindClose(SR); end; {$endif LINUX} {$ifdef MSWINDOWS} siz := SizeOf(tmp); p := @tmp; if GetAdaptersAddresses(AF_UNSPEC, GAA_FLAGS, nil, p, @siz) = ERROR_SUCCESS then begin repeat if (p^.Flags <> 0) and (p^.OperStatus = IfOperStatusUp) and (p^.PhysicalAddressLength = 6) then begin SetLength(MacAddresses, n + 1); MacAddresses[n].name := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(WideString(p^.Description)); MacAddresses[n].address := MacToText(@p^.PhysicalAddress); inc(n); end; p := p^.Next; until p = nil; end; {$endif MSWINDOWS} { TODO : RetrieveMacAddresses() for BSD see e.g. https://gist.github.com/OrangeTide/909204 } finally LeaveCriticalSection(SynSockCS); end; MacAddressesSearched := true; end; function GetMacAddresses: TMacAddressDynArray; begin if not MacAddressesSearched then RetrieveMacAddresses; result := MacAddresses; end; function GetMacAddressesText: SockString; var i: integer; begin result := MacAddressesText; if (result <> '') or MacAddressesSearched then exit; RetrieveMacAddresses; result := ''; if MacAddresses = nil then exit; for i := 0 to high(MacAddresses) do with MacAddresses[i] do result := result + name + '=' + address + ' '; SetLength(result, length(result) - 1); MacAddressesText := result; end; {$ifndef NOXPOWEREDNAME} const XPOWEREDNAME = 'X-Powered-By'; XPOWEREDVALUE = XPOWEREDPROGRAM + ' synopse.info'; {$endif} { TURI } const DEFAULT_PORT: array[boolean] of SockString = ('80','443'); UNIX_LOW = ord('u')+ord('n')shl 8+ord('i')shl 16+ord('x')shl 24; procedure TURI.Clear; begin Https := false; Layer := cslTCP; Finalize(self); end; function TURI.From(aURI: SockString; const DefaultPort: SockString): boolean; var P,S: PAnsiChar; begin Clear; result := false; aURI := Trim(aURI); if aURI='' then exit; P := pointer(aURI); S := P; while S^ in ['a'..'z','A'..'Z','+','-','.','0'..'9'] do inc(S); if PInteger(S)^ and $ffffff=ord(':')+ord('/')shl 8+ord('/')shl 16 then begin SetString(Scheme,P,S-P); if IdemPChar(P,'HTTPS') then Https := true; P := S+3; end; S := P; if (PInteger(S)^=UNIX_LOW) and (S[4]=':') then begin inc(S,5); // 'http://unix:/path/to/socket.sock:/url/path' inc(P,5); Layer := cslUNIX; while not(S^ in [#0,':']) do inc(S); // Server='path/to/socket.sock' end else while not(S^ in [#0,':','/']) do inc(S); SetString(Server,P,S-P); if S^=':' then begin inc(S); P := S; while not(S^ in [#0,'/']) do inc(S); SetString(Port,P,S-P); // Port='' for cslUnix end else if DefaultPort<>'' then Port := DefaultPort else Port := DEFAULT_PORT[Https]; if S^<>#0 then // ':' or '/' inc(S); Address := S; if Server<>'' then result := true; end; function TURI.URI: SockString; const Prefix: array[boolean] of SockString = ('http://','https://'); begin if Layer=cslUNIX then result := 'http://unix:'+Server+':/'+Address else if (Port='') or (Port='0') or (Port=DEFAULT_PORT[Https]) then result := Prefix[Https]+Server+'/'+Address else result := Prefix[Https]+Server+':'+Port+'/'+Address; end; function TURI.PortInt: integer; begin result := GetCardinal(pointer(port)); end; function TURI.Root: SockString; var i: PtrInt; begin i := PosCh('?',Address); if i=0 then Root := Address else Root := copy(Address,1,i-1); end; { ************ Socket API access - TCrtSocket and THttp*Socket } var WsaDataOnce: TWSADATA; SO_TRUE: integer = ord(true); function ResolveName(const Name: SockString; Family, SockProtocol, SockType: integer): SockString; var l: TStringList; begin l := TStringList.Create; try ResolveNameToIP(Name, Family, SockProtocol, SockType, l); if l.Count=0 then result := Name else result := SockString(l[0]); finally l.Free; end; end; procedure SetInt32Option(Sock: TSocket; OptName, OptVal: integer); var li: TLinger; {$ifndef MSWINDOWS} timeval: TTimeval; {$endif} begin if Sock<=0 then raise ECrtSocket.CreateFmt('Unexpected SetOption(%d,%d)',[OptName,OptVal]); case OptName of SO_SNDTIMEO, SO_RCVTIMEO: begin {$ifndef MSWINDOWS} // POSIX expects a timeval parameter for time out values timeval.tv_sec := OptVal div 1000; timeval.tv_usec := (OptVal mod 1000)*1000; if SetSockOpt(Sock,SOL_SOCKET,OptName,@timeval,sizeof(timeval))=0 then {$else} // WinAPI expects the time out directly as ms integer if SetSockOpt(Sock,SOL_SOCKET,OptName,pointer(@OptVal),sizeof(OptVal))=0 then {$endif} exit; end; SO_KEEPALIVE: // boolean (0/1) value if SetSockOpt(Sock,SOL_SOCKET,OptName,pointer(@OptVal),sizeof(OptVal))=0 then exit; SO_LINGER: begin // not available on UDP if OptVal<0 then li.l_onoff := Ord(false) else begin li.l_onoff := Ord(true); li.l_linger := OptVal; end; SetSockOpt(Sock,SOL_SOCKET, SO_LINGER, @li, SizeOf(li)); if OptVal>0 then begin {$ifdef LINUX} {$ifdef BSD} SetSockOpt(Sock,SOL_SOCKET,SO_REUSEPORT,@SO_TRUE,SizeOf(SO_TRUE)); {$ifndef OpenBSD} SetSockOpt(Sock,SOL_SOCKET,SO_NOSIGPIPE,@SO_TRUE,SizeOf(SO_TRUE)); {$endif OpenBSD} {$else} SetSockOpt(Sock,SOL_SOCKET, SO_REUSEADDR,@SO_TRUE,SizeOf(SO_TRUE)); {$endif BSD} {$endif LINUX} end; exit; end; TCP_NODELAY: // boolean (0/1) value if SetSockOpt(Sock,IPPROTO_TCP,OptName,@OptVal,sizeof(OptVal))=0 then exit; end; raise ECrtSocket.CreateFmt('SetOption(%d,%d)',[OptName,OptVal],-1); end; function CallServer(const Server, Port: SockString; doBind: boolean; aLayer: TCrtSocketLayer; ConnectTimeout: DWORD): TSocket; var sin: TVarSin; IP: SockString; socktype, ipproto, family: integer; {$ifndef MSWINDOWS} //serveraddr: sockaddr_un; {$endif} begin result := -1; case aLayer of cslTCP: begin socktype := SOCK_STREAM; ipproto := IPPROTO_TCP; end; cslUDP: begin socktype := SOCK_DGRAM; ipproto := IPPROTO_UDP; end; cslUNIX: begin {$ifdef MSWINDOWS} exit; // not handled under Win32 {$else} socktype := SOCK_STREAM; ipproto := 0; {$endif} end; else exit; end; if SameText(Server,'localhost') {$ifndef MSWINDOWS}or ((Server='') and not doBind){$endif} then IP := cLocalHost else if aLayer=cslUNIX then IP := Server else IP := ResolveName(Server,AF_INET,ipproto,socktype); {$ifndef MSWINDOWS} if aLayer=cslUNIX then family := AF_UNIX else {$endif} // use AF_INET instead of AF_UNSPEC: IP6 is buggy! family := AF_INET; if SetVarSin(sin,IP,Port,family,ipproto,socktype,false)<>0 then exit; result := Socket(integer(sin.AddressFamily),socktype,ipproto); if result=-1 then exit; if doBind then begin // Socket should remain open for 5 seconds after a closesocket() call SetInt32Option(result,SO_LINGER,5); // bind and listen to this port as server if (Bind(result,sin)<>0) or ((aLayer<>cslUDP) and (Listen(result,DefaultListenBacklog)<>0)) then begin CloseSocket(result); result := -1; end; end else begin // open client connection if ConnectTimeout>0 then begin SetInt32Option(result,SO_RCVTIMEO,ConnectTimeout); SetInt32Option(result,SO_SNDTIMEO,ConnectTimeout); end; if Connect(result,sin)<>0 then begin CloseSocket(result); result := -1; end; end; end; type PCrtSocket = ^TCrtSocket; function OutputSock(var F: TTextRec): integer; begin if F.BufPos=0 then result := 0 else if PCrtSocket(@F.UserData)^.TrySndLow(F.BufPtr,F.BufPos) then begin F.BufPos := 0; result := 0; end else result := -1; // on socket error -> raise ioresult error end; function WSAIsFatalError(anothernonfatal: integer=NO_ERROR): boolean; var err: integer; begin err := WSAGetLastError; result := (err<>NO_ERROR) and (err<>WSATRY_AGAIN) and {$ifdef MSWINDOWS}(err<>WSAETIMEDOUT) and (err<>WSAEWOULDBLOCK) and{$endif} (err<>anothernonfatal); // allow WSAEADDRNOTAVAIL from OpenBind() end; function WSAErrorAtShutdown(sock: TSocket): integer; var dummy: byte; begin if AsynchRecv(sock,@dummy,SizeOf(dummy))<0 then result := WSAGetLastError else result := 0; // read access allowed = socket was closed gracefully end; function InputSock(var F: TTextRec): Integer; // SockIn pseudo text file fill its internal buffer only with available data // -> no unwanted wait time is added // -> very optimized use for readln() in HTTP stream var Size: integer; Sock: TCRTSocket; {$ifdef MSWINDOWS} iSize: integer; {$else} sin: TVarSin; {$endif} begin F.BufEnd := 0; F.BufPos := 0; Sock := PCrtSocket(@F.UserData)^; if (Sock=nil) or (Sock.Sock<=0) then begin result := WSAECONNABORTED; // on socket error -> raise ioresult error exit; // file closed = no socket -> error end; result := Sock.fSockInEofError; if result<>0 then exit; // already reached error below Size := F.BufSize; if Sock.SocketLayer=cslUDP then begin {$ifdef MSWINDOWS} iSize := SizeOf(TSockAddr); Size := RecvFrom(Sock.Sock, F.BufPtr, Size, 0, @Sock.fPeerAddr, @iSize); {$else} Size := RecvFrom(Sock.Sock, F.BufPtr, Size, 0, sin); Sock.fPeerAddr.sin_port := sin.sin_port; Sock.fPeerAddr.sin_addr := sin.sin_addr; {$endif} end else // cslTCP/cslUNIX if not Sock.TrySockRecv(F.BufPtr,Size,{StopBeforeLength=}true) then Size := -1; // fatal socket error // TrySockRecv() may return Size=0 if no data is pending, but no TCP/IP error if Size>=0 then begin F.BufEnd := Size; inc(Sock.fBytesIn,Size); result := 0; // no error end else begin if Sock.Sock<=0 then // socket broken or closed result := WSAECONNABORTED else begin result := -integer(WSAGetLastError); // integer() for FPC+Win target if result=0 then result := WSAETIMEDOUT; end; Sock.fSockInEofError := result; // error -> mark end of SockIn // result <0 will update ioresult and raise an exception if {$I+} end; end; function CloseSock(var F: TTextRec): integer; begin if PCrtSocket(@F.UserData)^<>nil then PCrtSocket(@F.UserData)^.Close; PCrtSocket(@F.UserData)^ := nil; Result := 0; end; function OpenSock(var F: TTextRec): integer; begin F.BufPos := 0; F.BufEnd := 0; if F.Mode=fmInput then begin // ReadLn F.InOutFunc := @InputSock; F.FlushFunc := nil; end else begin // WriteLn F.Mode := fmOutput; F.InOutFunc := @OutputSock; F.FlushFunc := @OutputSock; end; F.CloseFunc := @CloseSock; Result := 0; end; { TCrtSocket } function Split(const Text: SockString; Sep: AnsiChar; var Before,After: SockString): boolean; var i: integer; begin for i := length(Text)-1 downto 2 do if Text[i]=Sep then begin trimcopy(Text,1,i-1,Before); trimcopy(Text,i+1,maxInt,After); result := true; exit; end; result := false; end; constructor TCrtSocket.Bind(const aAddr: SockString; aLayer: TCrtSocketLayer; aTimeOut: integer); var s,p: SockString; aSock: integer; {$ifdef LINUXNOTBSD} n: integer; {$endif} begin Create(aTimeOut); if aAddr='' then begin {$ifdef LINUXNOTBSD} // try systemd if not SystemdIsAvailable then raise ECrtSocket.Create('Bind('''') but Systemd is not available'); n := ExternalLibraries.sd_listen_fds(0); if n > 1 then raise ECrtSocket.Create('Bind(''''): Systemd activation failed - too ' + 'many file descriptors received'); aSock := SD_LISTEN_FDS_START + 0; {$else} raise ECrtSocket.Create('Bind('''') is not allowed on this platform'); {$endif} end else begin aSock := -1; // force OpenBind to create listening socket if not Split(aAddr,':',s,p) then begin s := '0.0.0.0'; p := aAddr; end; {$ifndef MSWINDOWS} if s='unix' then begin aLayer := cslUNIX; s := p; p := ''; end; {$endif MSWINDOWS} end; OpenBind(s,p,{dobind=}true,aSock,aLayer); // raise a ECrtSocket on error end; constructor TCrtSocket.Open(const aServer, aPort: SockString; aLayer: TCrtSocketLayer; aTimeOut: cardinal; aTLS: boolean); begin Create(aTimeOut); // default read timeout is 10 seconds OpenBind(aServer,aPort,{dobind=}false,-1,aLayer,aTLS); // raise an ECrtSocket on error end; type PTextRec = ^TTextRec; procedure TCrtSocket.Close; begin if self=nil then exit; fSndBufLen := 0; // always reset (e.g. in case of further Open) fSockInEofError := 0; ioresult; // reset ioresult value if SockIn/SockOut were used if SockIn<>nil then begin PTextRec(SockIn)^.BufPos := 0; // reset input buffer PTextRec(SockIn)^.BufEnd := 0; end; if SockOut<>nil then begin PTextRec(SockOut)^.BufPos := 0; // reset output buffer PTextRec(SockOut)^.BufEnd := 0; end; if fSock<=0 then exit; // no opened connection, or Close already executed {$ifdef LINUXNOTBSD} if (fWasBind and (fPort='')) then begin // binded on external socket fSock := -1; exit; end; {$endif} {$ifdef MSWINDOWS} if fSecure.Initialized then fSecure.BeforeDisconnection(fSock); {$endif MSWINDOWS} DirectShutdown(fSock,{rdwr=}fWasBind); fSock := -1; // don't change Server or Port, since may try to reconnect end; constructor TCrtSocket.Create(aTimeOut: PtrInt); begin fTimeOut := aTimeOut; end; procedure TCrtSocket.SetInt32OptionByIndex(OptName, OptVal: integer); begin SetInt32Option(Sock,OptName,OptVal); end; procedure TCrtSocket.OpenBind(const aServer, aPort: SockString; doBind: boolean; aSock: integer; aLayer: TCrtSocketLayer; aTLS: boolean); const BINDTXT: array[boolean] of string[4] = ('open','bind'); BINDMSG: array[boolean] of string = ('Is a server running on this address:port?', 'Another process may be currently listening to this port!'); var retry: integer; begin fSocketLayer := aLayer; fWasBind := doBind; if aSock<=0 then begin if (aPort='') and (aLayer<>cslUNIX) then fPort := DEFAULT_PORT[aTLS] else // default port is 80/443 (HTTP/S) fPort := aPort; fServer := aServer; if doBind then // allow small number of retries (e.g. XP or BSD during aggressive tests) retry := 10 else retry := {$ifdef BSD}10{$else}2{$endif}; repeat fSock := CallServer(aServer,Port,doBind,aLayer,Timeout); // OPEN or BIND if (fSock>0) then break; dec(retry); if WSAIsFatalError(WSAEADDRNOTAVAIL) or (retry<=0) then raise ECrtSocket.CreateFmt('OpenBind(%s:%s,%s) failed: %s', [aServer,fPort,BINDTXT[doBind],BINDMSG[doBind]],-1); sleep(10); until false; end else fSock := aSock; // ACCEPT mode -> socket is already created by caller if TimeOut>0 then begin // set timout values for both directions ReceiveTimeout := TimeOut; SendTimeout := TimeOut; end; if aLayer=cslTCP then begin if (aSock<0) or ((aSock>0) and not doBind) then begin // do not touch externally created socket TCPNoDelay := 1; // disable Nagle algorithm since we use our own buffers KeepAlive := 1; // enable TCP keepalive (even if we rely on transport layer) end; if aTLS and (aSock<=0) and not doBind then try {$ifdef MSWINDOWS} fSecure.AfterConnection(fSock,pointer(aServer)); {$else} raise ECrtSocket.Create('TLS is unsupported on this system'); {$endif MSWINDOWS} fTLS := true; except on E: Exception do raise ECrtSocket.CreateFmt('OpenBind(%s:%s,%s): TLS failed [%s %s]', [aServer,Port,BINDTXT[doBind],E.ClassName,E.Message],-1); end; end; {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'OpenBind(%:%) % sock=% (accept=%) ', [fServer,fPort,BINDTXT[doBind], fSock, aSock], self); {$endif} end; procedure TCrtSocket.AcceptRequest(aClientSock: TSocket; aClientSin: PVarSin); begin {$ifdef LINUXNOTBSD} // on Linux fd returned from accept() inherits all parent fd options // except O_NONBLOCK and O_ASYNC fSock := aClientSock; {$else} // on other OS inheritance is undefined, so call OpenBind to set all fd options OpenBind('','',false,aClientSock,fSocketLayer); // set the ACCEPTed aClientSock Linger := 5; // should remain open for 5 seconds after a closesocket() call {$endif LINUXNOTBSD} if aClientSin<>nil then IPText(aClientSin^,fRemoteIP,RemoteIPLocalHostAsVoidInServers); end; procedure TCrtSocket.SockSend(const Values: array of const); var i: integer; tmp: shortstring; begin for i := 0 to high(Values) do with Values[i] do case VType of vtString: SockSend(@VString^[1],pByte(VString)^); vtAnsiString: SockSend(VAnsiString,length(SockString(VAnsiString))); {$ifdef HASVARUSTRING} vtUnicodeString: begin tmp := ShortString(UnicodeString(VUnicodeString)); // convert into ansi SockSend(@tmp[1],length(tmp)); end; {$endif} vtPChar: SockSend(VPChar,StrLen(VPChar)); vtChar: SockSend(@VChar,1); vtWideChar: SockSend(@VWideChar,1); // only ansi part of the character vtInteger: begin Str(VInteger,tmp); SockSend(@tmp[1],length(tmp)); end; vtInt64{$ifdef FPC},vtQWord{$endif}: begin Str(VInt64^,tmp); SockSend(@tmp[1],length(tmp)); end; end; SockSend(@CRLF,2); end; procedure TCrtSocket.SockSend(const Line: SockString); begin if Line<>'' then SockSend(pointer(Line),length(Line)); SockSend(@CRLF,2); end; procedure TCrtSocket.SockSendFlush(const aBody: SockString); var body,avail: integer; begin body := Length(aBody); if body>0 then begin avail := SockSendRemainingSize; // around 1800 bytes if avail>=body then begin SockSend(pointer(aBody),body); // append to buffer as single TCP packet body := 0; end; end; {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'SockSend sock=% flush len=% body=% %', [fSock,fSndBufLen,length(aBody),LogEscapeFull(pointer(fSndBuf),fSndBufLen)],self); if body>0 then TSynLog.Add.Log(sllCustom2, 'SockSend sock=% body len=% %', [fSock,body,LogEscapeFull(pointer(aBody),body)],self); {$endif} if not TrySockSendFlush then raise ECrtSocket.CreateFmt('SockSendFlush(%s) len=%d',[fServer,fSndBufLen],-1); if body>0 then SndLow(pointer(aBody),body); // direct sending of biggest packets end; function TCrtSocket.TrySockSendFlush: boolean; begin if fSndBufLen=0 then result := true else begin result := TrySndLow(pointer(fSndBuf),fSndBufLen); if result then fSndBufLen := 0; end; end; function TCrtSocket.SockSendRemainingSize: integer; begin result := length(fSndBuf)-fSndBufLen; end; procedure TCrtSocket.SndLow(P: pointer; Len: integer); begin if not TrySndLow(P,Len) then raise ECrtSocket.CreateFmt('SndLow(%s) len=%d',[fServer,Len],-1); end; function TCrtSocket.TrySndLow(P: pointer; Len: integer): boolean; var sent: integer; now, start: Int64; begin result := Len=0; if (self=nil) or (fSock<=0) or (Len<=0) or (P=nil) then exit; start := {$ifdef MSWINDOWS}GetTick64{$else}0{$endif}; repeat {$ifdef MSWINDOWS} if fSecure.Initialized then sent := fSecure.Send(fSock, P, Len) else {$endif MSWINDOWS} sent := AsynchSend(fSock, P, Len); if sent>0 then begin inc(fBytesOut,sent); dec(Len,sent); if Len<=0 then break; inc(PByte(P),sent); end else if WSAIsFatalError then exit; // fatal socket error now := GetTick64; if (start=0) or (sent>0) then start := now else // measure timeout since nothing written if now-start>TimeOut then exit; // identify timeout as error SleepHiRes(1); until false; result := true; end; procedure TCrtSocket.Write(const Data: SockString); begin SndLow(pointer(Data),length(Data)); end; function TCrtSocket.AcceptIncoming(ResultClass: TCrtSocketClass): TCrtSocket; var client: TSocket; sin: TVarSin; begin result := nil; if (self=nil) or (fSock<=0) then exit; client := Accept(fSock,sin); if client<=0 then exit; if ResultClass=nil then ResultClass := TCrtSocket; result := ResultClass.Create(Timeout); result.AcceptRequest(client,@sin); result.CreateSockIn; // use SockIn with 1KB input buffer: 2x faster end; function TCrtSocket.SockInRead(Content: PAnsiChar; Length: integer; UseOnlySockIn: boolean): integer; var len,res: integer; // read Length bytes from SockIn^ buffer + Sock if necessary begin // get data from SockIn buffer, if any (faster than ReadChar) result := 0; if Length<=0 then exit; if SockIn<>nil then with PTextRec(SockIn)^ do repeat len := BufEnd-BufPos; if len>0 then begin if len>Length then len := Length; move(BufPtr[BufPos],Content^,len); inc(BufPos,len); inc(Content,len); dec(Length,len); inc(result,len); end; if Length=0 then exit; // we got everything we wanted if not UseOnlySockIn then break; res := InputSock(PTextRec(SockIn)^); if res<0 then raise ECrtSocket.CreateFmt('SockInRead InputSock=%d',[res],-1); until Timeout=0; // direct receiving of the remaining bytes from socket if Length>0 then begin SockRecv(Content,Length); // raise ECrtSocket if failed to read Length inc(result,Length); end; end; function TCrtSocket.SockInPending(aTimeOutMS: integer; aPendingAlsoInSocket: boolean): integer; var backup: PtrInt; insocket: integer; begin if SockIn=nil then raise ECrtSocket.Create('SockInPending without SockIn'); if aTimeOutMS<0 then raise ECrtSocket.Create('SockInPending(aTimeOutMS<0)'); with PTextRec(SockIn)^ do result := BufEnd-BufPos; if result=0 then // no data in SockIn^.Buffer, so try if some pending at socket level case SockReceivePending(aTimeOutMS) of cspDataAvailable: begin backup := fTimeOut; fTimeOut := 0; // not blocking call to fill SockIn buffer try // call InputSock() to actually retrieve any pending data if InputSock(PTextRec(SockIn)^)=NO_ERROR then with PTextRec(SockIn)^ do result := BufEnd-BufPos else result := -1; // indicates broken socket finally fTimeOut := backup; end; end; cspSocketError: result := -1; // indicates broken/closed socket end; // cspNoData will leave result=0 {$ifdef MSWINDOWS} // under Unix SockReceivePending use poll(fSocket) and if data available // ioctl syscall is redundant if aPendingAlsoInSocket then // also includes data in socket bigger than TTextRec's buffer if (IOCtlSocket(Sock,FIONREAD,insocket)=0) and (insocket>0) then inc(result,insocket); {$endif MSWINDOWS} end; destructor TCrtSocket.Destroy; begin Close; CloseSockIn; CloseSockOut; inherited; end; procedure TCrtSocket.SockSend(P: pointer; Len: integer); var cap: integer; begin if Len<=0 then exit; cap := Length(fSndBuf); if Len+fSndBufLen>cap then SetLength(fSndBuf,len+cap+cap shr 3+2048); move(P^,PByteArray(fSndBuf)[fSndBufLen],Len); inc(fSndBufLen,Len); end; const SOCKMINBUFSIZE = 1024; // big enough for headers (content will be read directly) {$ifdef FPC} procedure SetLineBreakStyle(var T: Text; Style: TTextLineBreakStyle); begin case Style Of tlbsCR: TextRec(T).LineEnd := #13; tlbsLF: TextRec(T).LineEnd := #10; tlbsCRLF: TextRec(T).LineEnd := #13#10; end; end; {$endif FPC} procedure TCrtSocket.CreateSockIn(LineBreak: TTextLineBreakStyle; InputBufferSize: Integer); begin if (Self=nil) or (SockIn<>nil) then exit; // initialization already occured if InputBufferSizenil then exit; // initialization already occured if OutputBufferSizenil) and (fSockIn<>nil) then begin Freemem(fSockIn); fSockIn := nil; end; end; procedure TCrtSocket.CloseSockOut; begin if (self<>nil) and (fSockOut<>nil) then begin Freemem(fSockOut); fSockOut := nil; end; end; procedure TCrtSocket.SockRecv(Buffer: pointer; Length: integer); var read: integer; begin read := Length; if not TrySockRecv(Buffer,read,{StopBeforeLength=}false) or (Length<>read) then raise ECrtSocket.CreateFmt('SockRecv(%d) failure (read=%d)',[Length,read]); end; const _CSP: array[TCrtSocketPending] of string[7] = ('ERROR','nodata','data'); function TCrtSocket.TrySockRecv(Buffer: pointer; var Length: integer; StopBeforeLength: boolean): boolean; var expected,read: PtrInt; now, last, diff: Int64; begin result := false; if (self<>nil) and (fSock>0) and (Buffer<>nil) and (Length>0) then begin expected := Length; Length := 0; last := {$ifdef MSWINDOWS}GetTick64{$else}0{$endif}; repeat read := expected-Length; {$ifdef MSWINDOWS} if fSecure.Initialized then read := fSecure.Receive(fSock,Buffer,read) else {$endif MSWINDOWS} read := AsynchRecv(fSock,Buffer,read); if read<=0 then begin // no more to read, or socket issue? {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'TrySockRecv: sock=% AsynchRecv=% %', [Sock,read,SocketErrorMessage],self); {$endif} if (read=0) or WSAIsFatalError then begin Close; // connection broken or socket closed gracefully (read=0) exit; end; if StopBeforeLength then break; end else begin inc(fBytesIn,read); inc(Length,read); if StopBeforeLength or (Length=expected) then break; // good enough for now inc(PByte(Buffer),read); end; now := GetTick64; if (last=0) or (read>0) then // check timeout from unfinished read last := now else begin diff := now-last; if diff>=TimeOut then begin {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'TrySockRecv: timeout (diff=%>%)',[diff,TimeOut],self); {$endif} exit; // identify read timeout as error end; if diff<100 then SleepHiRes(0) else SleepHiRes(1); end; until false; result := true; end; end; function TCrtSocket.SockReceivePending(TimeOutMS: integer): TCrtSocketPending; var res: integer; {$ifdef MSWINDOWS} tv: TTimeVal; fdset: TFDSet; pending: integer; {$ifdef SYNCRTDEBUGLOW} time: TPrecisionTimer; {$endif} {$else} p: TPollFD; // TFDSet limited to 1024 total sockets in POSIX -> use poll() {$endif} begin if (self=nil) or (fSock<=0) then begin {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'SockReceivePending: no Sock',self); {$endif} result := cspSocketError; exit; end; {$ifdef MSWINDOWS} {$ifdef SYNCRTDEBUGLOW} time.Start; {$endif} fdset.fd_array[0] := fSock; fdset.fd_count := 1; tv.tv_sec := TimeOutMS div 1000; tv.tv_usec := (TimeOutMS mod 1000)*1000; pending := -1; res := Select(fSock+1,@fdset,nil,nil,@tv); if res<0 then result := cspSocketError else if (res=0) or (fdset.fd_count<>1) or (fdset.fd_array[0]<>fSock) then result := cspNoData else if IoctlSocket(fSock,FIONREAD,pending)=0 then if pending>0 then result := cspDataAvailable else if TimeOutMS=0 then result := cspNoData else begin // https://docs.microsoft.com/en-us/windows/win32/api/winsock2/nf-winsock2-select#remarks {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom3, 'SockReceivePending: sock=% closed gracefully?',[fSock],self); {$endif} result := cspSocketError; end else result := cspSocketError; {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'SockReceivePending sock=% timeout=% fd_count=% fd_array[0]=% select=% result=% pending=% time=%', [fSock, TimeOutMS, fdset.fd_count, fdset.fd_array[0], res, _CSP[result], pending, time.Stop], self); {$endif} {$else} // https://moythreads.com/wordpress/2009/12/22/select-system-call-limitation p.fd := fSock; p.events := POLLIN; p.revents := 0; res := poll(@p,1,TimeOutMS); if res<0 then if WSAIsFatalError then result := cspSocketError else result := cspNoData else if p.revents=POLLIN then result := cspDataAvailable else result := cspNoData; {$endif} end; function TCrtSocket.LastLowSocketError: Integer; begin result := WSAGetLastError; // retrieved directly from Sockets API end; procedure TCrtSocket.SockRecvLn(out Line: SockString; CROnly: boolean); procedure RecvLn(var Line: SockString); var P: PAnsiChar; LP, L: PtrInt; tmp: array[0..1023] of AnsiChar; // avoid ReallocMem() every char begin P := @tmp; Line := ''; repeat SockRecv(P,1); // this is very slow under Windows -> use SockIn^ instead if P^<>#13 then // at least NCSA 1.3 does send a #10 only -> ignore #13 if P^=#10 then begin if Line='' then // get line SetString(Line,tmp,P-tmp) else begin LP := P-tmp; // append to already read chars L := length(Line); Setlength(Line,L+LP); move(tmp,PByteArray(Line)[L],LP); end; exit; end else if P=@tmp[1023] then begin // tmp[] buffer full? L := length(Line); // -> append to already read chars Setlength(Line,L+1024); move(tmp,PByteArray(Line)[L],1024); P := tmp; end else inc(P); until false; end; var c: byte; L, Error: PtrInt; begin if CROnly then begin // slower but accurate version expecting #13 as line end // SockIn^ expect either #10, either #13#10 -> a dedicated version is needed repeat SockRecv(@c,1); // this is slow but works if c in [0,13] then exit; // end of line L := length(Line); SetLength(Line,L+1); PByteArray(Line)[L] := c; until false; end else if SockIn<>nil then begin {$I-} readln(SockIn^,Line); // example: HTTP/1.0 200 OK Error := ioresult; if Error<>0 then raise ECrtSocket.CreateFmt('SockRecvLn after %d chars',[length(Line)],Error); {$I+} end else RecvLn(Line); // slow under Windows -> use SockIn^ instead end; procedure TCrtSocket.SockRecvLn; var c: AnsiChar; Error: integer; begin if SockIn<>nil then begin {$I-} readln(SockIn^); Error := ioresult; if Error<>0 then raise ECrtSocket.Create('SockRecvLn',Error); {$I+} end else repeat SockRecv(@c,1); until c=#10; end; function TCrtSocket.SockConnected: boolean; var sin: TVarSin; begin result := (self<>nil) and (fSock>0) and (GetPeerName(fSock,sin)=0); end; function TCrtSocket.PeerAddress: SockString; begin IPText(PVarSin(@fPeerAddr)^,result); end; function TCrtSocket.PeerPort: integer; begin result := fPeerAddr.sin_port; end; function TCrtSocket.SockReceiveString: SockString; var available, resultlen, read: integer; begin result := ''; if (self=nil) or (fSock<=0) then exit; resultlen := 0; repeat if (fSock<=0) or ((IOCtlSocket(fSock,FIONREAD,available)<>0) and WSAIsFatalError) then exit; // raw socket error if available=0 then // no data in the allowed timeout if result='' then begin // wait till something SleepHiRes(1);// some delay in infinite loop continue; end else break; // return what we have SetLength(result,resultlen+available); // append to result read := available; if not TrySockRecv(@PByteArray(result)[resultlen],read,{StopBeforeLength=}true) then begin Close; SetLength(result,resultlen); exit; end; inc(resultlen,read); if read'' then SockSend(TCPPrefix); if (url='') or (url[1]<>'/') then SockSend([method,' /',url,' HTTP/1.1']) else SockSend([method,' ',url,' HTTP/1.1']); if Port=DEFAULT_PORT[fTLS] then SockSend(['Host: ',Server]) else SockSend(['Host: ',Server,':',Port]); SockSend(['Accept: */*'#13#10'User-Agent: ',UserAgent]); end; function THttpClientSocket.Request(const url, method: SockString; KeepAlive: cardinal; const header, Data, DataType: SockString; retry: boolean): integer; procedure DoRetry(Error: integer; const msg: SockString); begin {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'Request: % socket=% DoRetry(%) retry=%',[msg,Sock,Error,BOOL_STR[retry]],self); {$endif} if retry then // retry once -> return error only if failed after retrial result := Error else begin Close; // close this connection try HeaderFlags := []; OpenBind(Server,Port,false,-1,cslTcp,fTLS); // retry with a new socket result := Request(url,method,KeepAlive,Header,Data,DataType,true); except on Exception do result := Error; end; end; end; var P: PAnsiChar; aData: SockString; begin if SockIn=nil then // done once CreateSockIn; // use SockIn by default if not already initialized: 2x faster Content := ''; if (connectionClose in HeaderFlags) or (SockReceivePending(0)=cspSocketError) then begin DoRetry(STATUS_NOTFOUND,'connection broken (kepepalive timeout or too many requests)'); exit; end; try try // send request - we use SockSend because writeln() is calling flush() // -> all headers will be sent at once RequestSendHeader(url,method); if KeepAlive>0 then SockSend(['Keep-Alive: ',KeepAlive,#13#10'Connection: Keep-Alive']) else SockSend('Connection: Close'); aData := Data; // local var copy for Data to be compressed in-place CompressDataAndWriteHeaders(DataType,aData); if header<>'' then SockSend(header); if fCompressAcceptEncoding<>'' then SockSend(fCompressAcceptEncoding); SockSend; // send CRLF SockSendFlush(aData); // flush all pending data to network // get headers if SockReceivePending(1000)=cspSocketError then begin DoRetry(STATUS_NOTFOUND,'cspSocketError waiting for headers'); exit; end; SockRecvLn(Command); // will raise ECrtSocket on any error if TCPPrefix<>'' then if Command<>TCPPrefix then begin result := STATUS_HTTPVERSIONNONSUPPORTED; // 505 exit; end else SockRecvLn(Command); P := pointer(Command); if IdemPChar(P,'HTTP/1.') then begin result := GetCardinal(P+9); // get http numeric status code (200,404...) if result=0 then begin result := STATUS_HTTPVERSIONNONSUPPORTED; exit; end; while result=100 do begin repeat // 100 CONTINUE is just to be ignored client side SockRecvLn(Command); P := pointer(Command); until IdemPChar(P,'HTTP/1.'); // ignore up to next command result := GetCardinal(P+9); end; if P[7]='0' then KeepAlive := 0; // HTTP/1.0 -> force connection close end else begin // error on reading answer DoRetry(STATUS_HTTPVERSIONNONSUPPORTED,Command); // 505=wrong format exit; end; GetHeader(false); // read all other headers if (result>=STATUS_SUCCESS) and (result<>STATUS_NOCONTENT) and (result<>STATUS_NOTMODIFIED) and (IdemPCharArray(pointer(method),['HEAD','OPTIONS'])<0) then GetBody; // get content if necessary (HEAD or OPTIONS have no body) except on Exception do DoRetry(STATUS_NOTFOUND,'Exception'); end; finally if KeepAlive=0 then Close; end; end; function Open(const aServer, aPort: SockString; aTLS: boolean): TCrtSocket; begin try result := TCrtSocket.Open(aServer,aPort,cslTCP,10000,aTLS); except on ECrtSocket do result := nil; end; end; function OpenHttp(const aServer, aPort: SockString; aTLS: boolean; aLayer: TCrtSocketLayer): THttpClientSocket; begin try result := THttpClientSocket.Open(aServer,aPort,aLayer,0,aTLS); // HTTP_DEFAULT_RECEIVETIMEOUT except on ECrtSocket do result := nil; end; end; function OpenHttp(const aURI: SockString; aAddress: PSockString): THttpClientSocket; var URI: TURI; begin result := nil; if URI.From(aURI) then begin result := OpenHttp(URI.Server,URI.Port,URI.Https,URI.Layer); if aAddress <> nil then aAddress^ := URI.Address; end; end; function HttpGet(const server, port: SockString; const url: SockString; const inHeaders: SockString; outHeaders: PSockString; aLayer: TCrtSocketLayer): SockString; var Http: THttpClientSocket; begin result := ''; Http := OpenHttp(server,port,false,aLayer); if Http<>nil then try if Http.Get(url,0,inHeaders) in [STATUS_SUCCESS..STATUS_PARTIALCONTENT] then begin result := Http.Content; if outHeaders<>nil then outHeaders^ := Http.HeaderGetText; end; finally Http.Free; end; end; function HttpGet(const aURI: SockString; outHeaders: PSockString; forceNotSocket: boolean; outStatus: PInteger): SockString; begin result := HttpGet(aURI,'',outHeaders,forceNotSocket,outStatus); end; function HttpGet(const aURI: SockString; const inHeaders: SockString; outHeaders: PSockString; forceNotSocket: boolean; outStatus: PInteger): SockString; var URI: TURI; begin if URI.From(aURI) then if URI.Https or forceNotSocket then {$ifdef USEWININET} result := TWinHTTP.Get(aURI,inHeaders,{weakCA=}true,outHeaders,outStatus) else {$else} {$ifdef USELIBCURL} result := TCurlHTTP.Get(aURI,inHeaders,{weakCA=}true,outHeaders,outStatus) else {$else} raise ECrtSocket.CreateFmt('https is not supported by HttpGet(%s)',[aURI]) else {$endif} {$endif USEWININET} result := HttpGet(URI.Server,URI.Port,URI.Address,inHeaders,outHeaders,URI.Layer) else result := ''; {$ifdef LINUX_RAWDEBUGVOIDHTTPGET} if result='' then writeln('HttpGet returned VOID for ',URI.server,':',URI.Port,' ',URI.Address); {$endif} end; function HttpGetAuth(const aURI, aAuthToken: SockString; outHeaders: PSockString; forceNotSocket: boolean; outStatus: PInteger): SockString; var status: integer; begin result := HttpGet(aURI,AuthorizationBearer(aAuthToken),outHeaders,forceNotSocket,@status); if outStatus<>nil then outStatus^ := status; if not(status in [STATUS_SUCCESS..STATUS_PARTIALCONTENT]) then result := ''; end; function HttpPost(const server, port: SockString; const url, Data, DataType: SockString; outData: PSockString; const auth: SockString): boolean; var Http: THttpClientSocket; begin result := false; Http := OpenHttp(server,port); if Http<>nil then try result := Http.Post(url,Data,DataType,0,AuthorizationBearer(auth)) in [STATUS_SUCCESS,STATUS_CREATED,STATUS_NOCONTENT]; if outdata<>nil then outdata^ := Http.Content; finally Http.Free; end; end; function HttpPut(const server, port: SockString; const url, Data, DataType: SockString; outData: PSockString; const auth: SockString): boolean; var Http: THttpClientSocket; begin result := false; Http := OpenHttp(server,port); if Http<>nil then try result := Http.Put(url,Data,DataType,0,AuthorizationBearer(auth)) in [STATUS_SUCCESS,STATUS_CREATED,STATUS_NOCONTENT]; if outdata<>nil then outdata^ := Http.Content; finally Http.Free; end; end; function TSMTPConnection.FromText(const aText: SockString): boolean; var u,h: SockString; begin if aText=SMTP_DEFAULT then begin result := false; exit; end; if Split(aText,'@',u,h) then begin if not Split(u,':',User,Pass) then User := u; end else h := aText; if not Split(h,':',Host,Port) then begin Host := h; Port := '25'; end; if (Host<>'') and (Host[1]='?') then Host := ''; result := Host<>''; end; function SendEmail(const Server: TSMTPConnection; const From, CSVDest, Subject, Text, Headers, TextCharSet: SockString; aTLS: boolean): boolean; begin result := SendEmail(Server.Host, From, CSVDest, Subject, Text, Headers, Server.User, Server.Pass, Server.Port, TextCharSet, (Server.Port = '465') or (Server.Port = '587')); end; function SendEmail(const Server, From, CSVDest, Subject, Text, Headers, User, Pass, Port, TextCharSet: SockString; aTLS: boolean): boolean; var TCP: TCrtSocket; procedure Expect(const Answer: SockString); var Res: SockString; begin repeat readln(TCP.SockIn^,Res); until (Length(Res)<4)or(Res[4]<>'-'); if not IdemPChar(pointer(Res),pointer(Answer)) then raise ECrtSocket.Create(string(Res)); end; procedure Exec(const Command, Answer: SockString); begin writeln(TCP.SockOut^,Command); Expect(Answer) end; var P: PAnsiChar; rec, ToList, head: SockString; begin result := false; P := pointer(CSVDest); if P=nil then exit; TCP := Open(Server,Port,aTLS); if TCP<>nil then try TCP.CreateSockIn; // we use SockIn and SockOut here TCP.CreateSockOut; Expect('220'); if (User<>'') and (Pass<>'') then begin Exec('EHLO '+Server,'25'); Exec('AUTH LOGIN','334'); Exec(SockBase64Encode(User),'334'); Exec(SockBase64Encode(Pass),'235'); end else Exec('HELO '+Server,'25'); writeln(TCP.SockOut^,'MAIL FROM:<',From,'>'); Expect('250'); repeat GetNextItem(P,',',rec); rec := Trim(rec); if rec='' then continue; if PosCh('<',rec)=0 then rec := '<'+rec+'>'; Exec('RCPT TO:'+rec,'25'); if ToList='' then ToList := #13#10'To: '+rec else ToList := ToList+', '+rec; until P=nil; Exec('DATA','354'); head := trim(Headers); if head<>'' then head := head+#13#10; writeln(TCP.SockOut^,'Subject: ',Subject,#13#10'From: ',From,ToList); if TextCharSet='JSON' then writeln(TCP.SockOut^,'Content-Type: application/json; charset=UTF-8') else writeln(TCP.SockOut^,'Content-Type: text/plain; charset=',TextCharSet); writeln(TCP.SockOut^,'Content-Transfer-Encoding: 8bit'#13#10,head,#13#10,Text); Exec('.','25'); writeln(TCP.SockOut^,'QUIT'); result := true; finally TCP.Free; end; end; function IsAnsi7(const s: string): boolean; var i: integer; begin result := false; for i := 1 to length(s) do if ord(s[i])>126 then exit; result := true; end; function SendEmailSubject(const Text: string): SockString; var utf8: UTF8String; begin if IsAnsi7(Text) then result := SockString(Text) else begin utf8 := UTF8String(Text); result := '=?UTF-8?B?'+SockBase64Encode(utf8); end; end; { THttpServerRequest } constructor THttpServerRequest.Create(aServer: THttpServerGeneric; aConnectionID: THttpServerConnectionID; aConnectionThread: TSynThread); begin inherited Create; fServer := aServer; fConnectionID := aConnectionID; fConnectionThread := aConnectionThread; end; var GlobalRequestID: integer; procedure THttpServerRequest.Prepare(const aURL, aMethod, aInHeaders, aInContent, aInContentType, aRemoteIP: SockString; aUseSSL: boolean); var id: PInteger; begin if fServer=nil then id := @GlobalRequestID else id := @fServer.fCurrentRequestID; fRequestID := InterLockedIncrement(id^); if fRequestID=maxInt-2048 then // ensure no overflow (31-bit range) id^ := 0; fUseSSL := aUseSSL; fURL := aURL; fMethod := aMethod; fRemoteIP := aRemoteIP; if aRemoteIP<>'' then if aInHeaders='' then fInHeaders := 'RemoteIP: '+aRemoteIP else fInHeaders := aInHeaders+#13#10'RemoteIP: '+aRemoteIP else fInHeaders := aInHeaders; fInContent := aInContent; fInContentType := aInContentType; fOutContent := ''; fOutContentType := ''; fOutCustomHeaders := ''; end; procedure THttpServerRequest.AddInHeader(additionalHeader: SockString); begin additionalHeader := Trim(additionalHeader); if additionalHeader<>'' then if fInHeaders='' then fInHeaders := additionalHeader else fInHeaders := fInHeaders+#13#10+additionalHeader; end; { TServerGeneric } constructor TServerGeneric.Create(CreateSuspended: boolean; OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); begin fProcessName := ProcessName; fOnHttpThreadStart := OnStart; SetOnTerminate(OnStop); inherited Create(CreateSuspended); end; procedure TServerGeneric.NotifyThreadStart(Sender: TSynThread); begin if Sender=nil then raise ECrtSocket.Create('NotifyThreadStart(nil)'); if Assigned(fOnHttpThreadStart) and not Assigned(Sender.fStartNotified) then begin fOnHttpThreadStart(Sender); Sender.fStartNotified := self; end; end; procedure TServerGeneric.SetOnTerminate(const Event: TNotifyThreadEvent); begin fOnThreadTerminate := Event; end; { THttpServerGeneric } constructor THttpServerGeneric.Create(CreateSuspended: boolean; OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); begin SetServerName('mORMot ('+XPOWEREDOS+')'); inherited Create(CreateSuspended,OnStart,OnStop,ProcessName); end; procedure THttpServerGeneric.RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer=1024); begin RegisterCompressFunc(fCompress,aFunction,fCompressAcceptEncoding,aCompressMinSize); end; procedure THttpServerGeneric.Shutdown; begin if self<>nil then fShutdownInProgress := true; end; function THttpServerGeneric.Request(Ctxt: THttpServerRequest): cardinal; begin if (self=nil) or fShutdownInProgress then result := STATUS_NOTFOUND else begin NotifyThreadStart(Ctxt.ConnectionThread); if Assigned(OnRequest) then result := OnRequest(Ctxt) else result := STATUS_NOTFOUND; end; end; function THttpServerGeneric.Callback(Ctxt: THttpServerRequest; aNonBlocking: boolean): cardinal; begin raise ECrtSocket.CreateFmt('%s.Callback is not implemented: try to use '+ 'another communication protocol, e.g. WebSockets',[ClassName]); end; procedure THttpServerGeneric.SetServerName(const aName: SockString); begin fServerName := aName; end; procedure THttpServerGeneric.SetOnRequest(const aRequest: TOnHttpServerRequest); begin fOnRequest := aRequest; end; procedure THttpServerGeneric.SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); begin fOnBeforeBody := aEvent; end; procedure THttpServerGeneric.SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); begin fOnBeforeRequest := aEvent; end; procedure THttpServerGeneric.SetOnAfterRequest(const aEvent: TOnHttpServerRequest); begin fOnAfterRequest := aEvent; end; procedure THttpServerGeneric.SetOnAfterResponse( const aEvent: TOnHttpServerAfterResponse); begin fOnAfterResponse := aEvent; end; function THttpServerGeneric.DoBeforeRequest(Ctxt: THttpServerRequest): cardinal; begin if Assigned(fOnBeforeRequest) then result := fOnBeforeRequest(Ctxt) else result := 0; end; function THttpServerGeneric.DoAfterRequest(Ctxt: THttpServerRequest): cardinal; begin if Assigned(fOnAfterRequest) then result := fOnAfterRequest(Ctxt) else result := 0; end; procedure THttpServerGeneric.DoAfterResponse(Ctxt: THttpServerRequest; const Code: cardinal); begin if Assigned(fOnAfterResponse) then fOnAfterResponse(Ctxt, Code); end; procedure THttpServerGeneric.SetMaximumAllowedContentLength(aMax: cardinal); begin fMaximumAllowedContentLength := aMax; end; procedure THttpServerGeneric.SetRemoteIPHeader(const aHeader: SockString); begin fRemoteIPHeader := aHeader; fRemoteIPHeaderUpper := UpperCase(aHeader); end; procedure THttpServerGeneric.SetRemoteConnIDHeader(const aHeader: SockString); begin fRemoteConnIDHeader := aHeader; fRemoteConnIDHeaderUpper := UpperCase(aHeader); end; function THttpServerGeneric.NextConnectionID: integer; begin result := InterlockedIncrement(fCurrentConnectionID); if result=maxInt-2048 then // paranoid 31-bit counter reset to ensure >0 fCurrentConnectionID := 0; end; { THttpServer } constructor THttpServer.Create(const aPort: SockString; OnStart, OnStop: TNotifyThreadEvent; const ProcessName: SockString; ServerThreadPoolCount: integer; KeepAliveTimeOut: integer; HeadersUnFiltered: boolean; CreateSuspended: boolean); begin fSockPort := aPort; fInternalHttpServerRespList := {$ifdef FPC}TFPList{$else}TList{$endif}.Create; InitializeCriticalSection(fProcessCS); fServerKeepAliveTimeOut := KeepAliveTimeOut; // 30 seconds by default if fThreadPool<>nil then fThreadPool.ContentionAbortDelay := 5000; // 5 seconds default // event handlers set before inherited Create to be visible in childs fOnHttpThreadStart := OnStart; SetOnTerminate(OnStop); if fThreadRespClass=nil then fThreadRespClass := THttpServerResp; if fSocketClass=nil then fSocketClass := THttpServerSocket; if ServerThreadPoolCount>0 then begin fThreadPool := TSynThreadPoolTHttpServer.Create(self,ServerThreadPoolCount); fHTTPQueueLength := 1000; end; fHeadersNotFiltered := HeadersUnFiltered; inherited Create(CreateSuspended,OnStart,OnStop,ProcessName); end; function THttpServer.GetAPIVersion: string; begin result := Format('%s.%d',[WsaDataOnce.szDescription,WsaDataOnce.wVersion]); end; destructor THttpServer.Destroy; var endtix: Int64; i: integer; resp: THttpServerResp; begin Terminate; // set Terminated := true for THttpServerResp.Execute if fThreadPool<>nil then fThreadPool.fTerminated := true; // notify background process if (fExecuteState=esRunning) and (Sock<>nil) then begin Sock.Close; // shutdown the socket to unlock Accept() in Execute DirectShutdown(CallServer('127.0.0.1',Sock.Port,false,cslTCP,1)); end; endtix := GetTick64+20000; EnterCriticalSection(fProcessCS); try if fInternalHttpServerRespList<>nil then begin for i := 0 to fInternalHttpServerRespList.Count-1 do begin resp := fInternalHttpServerRespList.List[i]; resp.Terminate; DirectShutdown(resp.fServerSock.Sock,{rdwr=}true); end; repeat // wait for all THttpServerResp.Execute to be finished if (fInternalHttpServerRespList.Count=0) and (fExecuteState<>esRunning) then break; LeaveCriticalSection(fProcessCS); SleepHiRes(100); EnterCriticalSection(fProcessCS); until GetTick64>endtix; FreeAndNil(fInternalHttpServerRespList); end; finally LeaveCriticalSection(fProcessCS); FreeAndNil(fThreadPool); // release all associated threads and I/O completion FreeAndNil(fSock); inherited Destroy; // direct Thread abort, no wait till ended DeleteCriticalSection(fProcessCS); end; end; function THttpServer.GetStat(one: THttpServerSocketGetRequestResult): integer; begin result := fStats[one]; end; function THttpServer.GetHTTPQueueLength: Cardinal; begin result := fHTTPQueueLength; end; procedure THttpServer.SetHTTPQueueLength(aValue: Cardinal); begin fHTTPQueueLength := aValue; end; procedure THttpServer.InternalHttpServerRespListAdd(resp: THttpServerResp); begin if (self=nil) or (fInternalHttpServerRespList=nil) or (resp=nil) then exit; EnterCriticalSection(fProcessCS); try fInternalHttpServerRespList.Add(resp); finally LeaveCriticalSection(fProcessCS); end; end; procedure THttpServer.InternalHttpServerRespListRemove(resp: THttpServerResp); var i: integer; begin if (self=nil) or (fInternalHttpServerRespList=nil) then exit; EnterCriticalSection(fProcessCS); try i := fInternalHttpServerRespList.IndexOf(resp); if i>=0 then fInternalHttpServerRespList.Delete(i); finally LeaveCriticalSection(fProcessCS); end; end; function THttpServer.OnNginxAllowSend(Context: THttpServerRequest; const LocalFileName: TFileName): boolean; var match,i,f: PtrInt; folder: ^TFileName; begin match := 0; folder := pointer(fNginxSendFileFrom); if LocalFileName<>'' then for f := 1 to length(fNginxSendFileFrom) do begin match := length(folder^); for i := 1 to match do // case sensitive left search if LocalFileName[i]<>folder^[i] then begin match := 0; break; end; if match<>0 then break; // found matching folder inc(folder); end; result := match<>0; if not result then exit; // no match -> manual send delete(Context.fOutContent,1,match); // remove e.g. '/var/www' Context.OutCustomHeaders := Trim(Context.OutCustomHeaders+#13#10+ 'X-Accel-Redirect: '+Context.OutContent); Context.OutContent := ''; end; procedure THttpServer.NginxSendFileFrom(const FileNameLeftTrim: TFileName); var n: PtrInt; begin n := length(fNginxSendFileFrom); SetLength(fNginxSendFileFrom,n+1); fNginxSendFileFrom[n] := FileNameLeftTrim; fOnSendFile := OnNginxAllowSend; end; procedure THttpServer.WaitStarted(Seconds: integer); var tix: Int64; ok: boolean; begin tix := GetTick64 + Seconds * 1000; // never wait forever repeat EnterCriticalSection(fProcessCS); ok := Terminated or (fExecuteState in [esRunning, esFinished]); LeaveCriticalSection(fProcessCS); if ok then exit; Sleep(1); if GetTick64 > tix then raise ECrtSocket.CreateFmt('%s.WaitStarted failed after %d seconds [%s]', [ClassName,Seconds,fExecuteMessage]); until false; end; {.$define MONOTHREAD} // define this not to create a thread at every connection (not recommended) procedure THttpServer.Execute; var ClientSock: TSocket; ClientSin: TVarSin; ClientCrtSock: THttpServerSocket; {$ifdef MONOTHREAD} endtix: Int64; {$endif} begin // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event fExecuteState := esBinding; NotifyThreadStart(self); // main server process loop try fSock := TCrtSocket.Bind(fSockPort); // BIND + LISTEN {$ifdef LINUXNOTBSD} // in case we started by systemd, listening socket is created by another process // and do not interrupt while process got a signal. So we need to set a timeout to // unblock accept() periodically and check we need terminations if fSockPort = '' then // external socket fSock.ReceiveTimeout := 1000; // unblock accept every second {$endif} fExecuteState := esRunning; if fSock.Sock<=0 then // paranoid (Bind would have raise an exception) raise ECrtSocket.Create('THttpServer.Execute: TCrtSocket.Bind failed'); while not Terminated do begin ClientSock := Accept(Sock.Sock,ClientSin); if ClientSock<=0 then if Terminated then break else begin SleepHiRes(1); // failure (too many clients?) -> wait and retry continue; end; if Terminated or (Sock=nil) then begin DirectShutdown(ClientSock); break; // don't accept input if server is down end; OnConnect; {$ifdef MONOTHREAD} ClientCrtSock := fSocketClass.Create(self); try ClientCrtSock.InitRequest(ClientSock); endtix := fHeaderRetrieveAbortDelay; if endtix>0 then inc(endtix,GetTick64); if ClientCrtSock.GetRequest({withbody=}true,endtix) in [grBodyReceived,grHeaderReceived] then Process(ClientCrtSock,0,self); OnDisconnect; DirectShutdown(ClientSock); finally ClientCrtSock.Free; end; {$else} if Assigned(fThreadPool) then begin // use thread pool to process the request header, and probably its body ClientCrtSock := fSocketClass.Create(self); ClientCrtSock.AcceptRequest(ClientSock,@ClientSin); if not fThreadPool.Push(pointer(PtrUInt(ClientCrtSock)),{waitoncontention=}true) then begin // returned false if there is no idle thread in the pool, and queue is full ClientCrtSock.Free; // will call DirectShutdown(ClientSock) end; end else // default implementation creates one thread for each incoming socket fThreadRespClass.Create(ClientSock,ClientSin,self); {$endif MONOTHREAD} end; except on E: Exception do // any exception would break and release the thread fExecuteMessage := E.ClassName+' ['+E.Message+']'; end; EnterCriticalSection(fProcessCS); fExecuteState := esFinished; LeaveCriticalSection(fProcessCS); end; procedure THttpServer.OnConnect; begin InterLockedIncrement(fServerConnectionCount); InterLockedIncrement(fServerConnectionActive); end; procedure THttpServer.OnDisconnect; begin InterLockedDecrement(fServerConnectionActive); end; procedure THttpServer.Process(ClientSock: THttpServerSocket; ConnectionID: THttpServerConnectionID; ConnectionThread: TSynThread); var ctxt: THttpServerRequest; P: PAnsiChar; respsent: boolean; Code, afterCode: cardinal; s, reason: SockString; ErrorMsg: string; function SendResponse: boolean; var fs: TFileStream; fn: TFileName; begin result := not Terminated; // true=success if not result then exit; {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'SendResponse respsent=% code=%', [respsent,code], self); {$endif} respsent := true; // handle case of direct sending of static file (as with http.sys) if (ctxt.OutContent<>'') and (ctxt.OutContentType=HTTP_RESP_STATICFILE) then try ExtractNameValue(ctxt.fOutCustomHeaders,'CONTENT-TYPE:',ctxt.fOutContentType); fn := {$ifdef UNICODE}UTF8ToUnicodeString{$else}Utf8ToAnsi{$endif}(ctxt.OutContent); if not Assigned(fOnSendFile) or not fOnSendFile(ctxt,fn) then begin fs := TFileStream.Create(fn,fmOpenRead or fmShareDenyNone); try SetString(ctxt.fOutContent,nil,fs.Size); fs.Read(Pointer(ctxt.fOutContent)^,length(ctxt.fOutContent)); finally fs.Free; end; end; except on E: Exception do begin // error reading or sending file ErrorMsg := E.ClassName+': '+E.Message; Code := STATUS_NOTFOUND; result := false; // fatal error end; end; if ctxt.OutContentType=HTTP_RESP_NORESPONSE then ctxt.OutContentType := ''; // true HTTP always expects a response // send response (multi-thread OK) at once if (Code'' then begin ctxt.OutCustomHeaders := ''; ctxt.OutContentType := 'text/html; charset=utf-8'; // create message to display ctxt.OutContent := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}( format(''#10+ '

%s Server Error %d

HTTP %d %s

%s

%s', [ClassName,Code,Code,reason,HtmlEncodeString(ErrorMsg),fServerName])); end; // 1. send HTTP status command if ClientSock.TCPPrefix<>'' then ClientSock.SockSend(ClientSock.TCPPrefix); if ClientSock.KeepAliveClient then ClientSock.SockSend(['HTTP/1.1 ',Code,' ',reason]) else ClientSock.SockSend(['HTTP/1.0 ',Code,' ',reason]); // 2. send headers // 2.1. custom headers from Request() method P := pointer(ctxt.fOutCustomHeaders); while P<>nil do begin GetNextLine(P,s); if s<>'' then begin // no void line (means headers ending) ClientSock.SockSend(s); if IdemPChar(pointer(s),'CONTENT-ENCODING:') then integer(ClientSock.fCompressAcceptHeader) := 0; // custom encoding: don't compress end; end; // 2.2. generic headers ClientSock.SockSend([ {$ifndef NOXPOWEREDNAME}XPOWEREDNAME+': '+XPOWEREDVALUE+#13#10+{$endif} 'Server: ',fServerName]); ClientSock.CompressDataAndWriteHeaders(ctxt.OutContentType,ctxt.fOutContent); if ClientSock.KeepAliveClient then begin if ClientSock.fCompressAcceptEncoding<>'' then ClientSock.SockSend(ClientSock.fCompressAcceptEncoding); ClientSock.SockSend('Connection: Keep-Alive'#13#10); // #13#10 -> end headers end else ClientSock.SockSend; // headers must end with a void line // 3. sent HTTP body content (if any) ClientSock.SockSendFlush(ctxt.OutContent); // flush all data to network end; begin if (ClientSock=nil) or (ClientSock.Headers='') then // we didn't get the request = socket read error exit; // -> send will probably fail -> nothing to send back if Terminated then exit; ctxt := THttpServerRequest.Create(self,ConnectionID,ConnectionThread); try respsent := false; with ClientSock do ctxt.Prepare(URL,Method,HeaderGetText(fRemoteIP),Content,ContentType,'',ClientSock.fTLS); try Code := DoBeforeRequest(ctxt); {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'DoBeforeRequest=%', [code], self); {$endif} if Code>0 then if not SendResponse or (Code<>STATUS_ACCEPTED) then exit; Code := Request(ctxt); afterCode := DoAfterRequest(ctxt); {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'Request=% DoAfterRequest=%', [code,afterCode], self); {$endif} if afterCode>0 then Code := afterCode; if respsent or SendResponse then DoAfterResponse(ctxt, Code); {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'DoAfterResponse respsent=% ErrorMsg=%', [respsent,ErrorMsg], self); {$endif} except on E: Exception do if not respsent then begin ErrorMsg := E.ClassName+': '+E.Message; Code := STATUS_SERVERERROR; SendResponse; end; end; finally if Sock<>nil then begin // add transfert stats to main socket EnterCriticalSection(fProcessCS); inc(Sock.fBytesIn,ClientSock.BytesIn); inc(Sock.fBytesOut,ClientSock.BytesOut); LeaveCriticalSection(fProcessCS); ClientSock.fBytesIn := 0; ClientSock.fBytesOut := 0; end; ctxt.Free; end; end; { TSynThread } constructor TSynThread.Create(CreateSuspended: boolean); begin {$ifdef FPC} inherited Create(CreateSuspended,512*1024); // DefaultSizeStack=512KB {$else} inherited Create(CreateSuspended); {$endif} end; function TSynThread.SleepOrTerminated(MS: cardinal): boolean; var endtix: Int64; begin result := true; // notify Terminated if Terminated then exit; if MS<32 then begin // smaller than GetTickCount resolution (under Windows) SleepHiRes(MS); if Terminated then exit; end else begin endtix := GetTick64+MS; repeat SleepHiRes(10); if Terminated then exit; until GetTick64>endtix; end; result := false; // abnormal delay expiration end; {$ifndef LVCL} procedure TSynThread.DoTerminate; begin try if Assigned(fStartNotified) and Assigned(fOnThreadTerminate) then begin fOnThreadTerminate(self); fStartNotified := nil; end; inherited DoTerminate; // call OnTerminate via Synchronize() except // hardened: a closing thread should not jeopardize the whole project! end; end; {$endif} {$ifndef HASTTHREADSTART} procedure TSynThread.Start; begin Resume; end; {$endif} { THttpServerResp } constructor THttpServerResp.Create(aSock: TSocket; const aSin: TVarSin; aServer: THttpServer); var c: THttpServerSocketClass; begin fClientSock := aSock; fClientSin := aSin; if aServer=nil then c := THttpServerSocket else c := aServer.fSocketClass; Create(c.Create(aServer),aServer); // on Linux, Execute raises during Create end; constructor THttpServerResp.Create(aServerSock: THttpServerSocket; aServer: THttpServer); begin fServer := aServer; fServerSock := aServerSock; fOnThreadTerminate := fServer.fOnThreadTerminate; fServer.InternalHttpServerRespListAdd(self); fConnectionID := aServerSock.RemoteConnectionID; if fConnectionID=0 then fConnectionID := fServer.NextConnectionID; // fallback to 31-bit sequence FreeOnTerminate := true; inherited Create(false); end; procedure THttpServerResp.Execute; procedure HandleRequestsProcess; var keepaliveendtix,beforetix,headertix,tix: Int64; pending: TCrtSocketPending; res: THttpServerSocketGetRequestResult; begin {$ifdef SYNCRTDEBUGLOW} try {$endif} try repeat beforetix := GetTick64; keepaliveendtix := beforetix+fServer.ServerKeepAliveTimeOut; repeat // within this loop, break=wait for next command, exit=quit if (fServer=nil) or fServer.Terminated or (fServerSock=nil) then exit; // server is down -> close connection pending := fServerSock.SockReceivePending(50); // 50 ms timeout if (fServer=nil) or fServer.Terminated then exit; // server is down -> disconnect the client {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2, 'HandleRequestsProcess: sock=% pending=%', [fServerSock.fSock, _CSP[pending]], self); {$endif} case pending of cspSocketError: exit; // socket error -> disconnect the client cspNoData: begin tix := GetTick64; if tix>=keepaliveendtix then exit; // reached keep alive time out -> close connection if tix-beforetix<40 then begin {$ifdef SYNCRTDEBUGLOW} // getsockopt(fServerSock.fSock,SOL_SOCKET,SO_ERROR,@error,errorlen) returns 0 :( TSynLog.Add.Log(sllCustom2, 'HandleRequestsProcess: sock=% LOWDELAY=%', [fServerSock.fSock, tix-beforetix], self); {$endif} SleepHiRes(1); // seen only on Windows in practice if (fServer=nil) or fServer.Terminated then exit; // server is down -> disconnect the client end; beforetix := tix; end; cspDataAvailable: begin // get request and headers headertix := fServer.HeaderRetrieveAbortDelay; if headertix>0 then inc(headertix,beforetix); res := fServerSock.GetRequest({withbody=}true,headertix); if (fServer=nil) or fServer.Terminated then exit; // server is down -> disconnect the client InterLockedIncrement(fServer.fStats[res]); case res of grBodyReceived, grHeaderReceived: begin if res=grBodyReceived then InterlockedIncrement(fServer.fStats[grHeaderReceived]); // calc answer and send response fServer.Process(fServerSock,ConnectionID,self); // keep connection only if necessary if fServerSock.KeepAliveClient then break else exit; end; grOwned: begin fServerSock := nil; // will be freed by new owner exit; end; else // fServerSock connection was down or headers are not correct exit; end; end; end; until false; until false; except on E: Exception do ; // any exception will silently disconnect the client end; {$ifdef SYNCRTDEBUGLOW} finally TSynLog.Add.Log(sllCustom2, 'HandleRequestsProcess: close sock=%', [fServerSock.fSock], self); end; {$endif} end; var aSock: TSocket; begin fServer.NotifyThreadStart(self); try try if fClientSock<>0 then begin // direct call from incoming socket aSock := fClientSock; fClientSock := 0; // fServerSock owns fClientSock fServerSock.AcceptRequest(aSock,@fClientSin); if fServer<>nil then HandleRequestsProcess; end else begin // call from TSynThreadPoolTHttpServer -> handle first request if not fServerSock.fBodyRetrieved and (IdemPCharArray(pointer(fServerSock.fMethod),['HEAD','OPTIONS'])<0) then fServerSock.GetBody; fServer.Process(fServerSock,ConnectionID,self); if (fServer<>nil) and fServerSock.KeepAliveClient then HandleRequestsProcess; // process further kept alive requests end; finally try if fServer<>nil then try fServer.OnDisconnect; finally fServer.InternalHttpServerRespListRemove(self); fServer := nil; end; finally FreeAndNil(fServerSock); // if Destroy happens before fServerSock.GetRequest() in Execute below DirectShutdown(fClientSock); end; end; except on Exception do ; // just ignore unexpected exceptions here, especially during clean-up end; end; { THttpSocket } procedure THttpSocket.GetBody; var Line: SockString; // 32 bits chunk length in hexa LinePChar: array[0..31] of AnsiChar; Len, LContent, Error: integer; begin fBodyRetrieved := true; Content := ''; {$I-} // direct read bytes, as indicated by Content-Length or Chunked if transferChuked in HeaderFlags then begin // we ignore the Length LContent := 0; // current read position in Content repeat if SockIn<>nil then begin readln(SockIn^,LinePChar); // use of a static PChar is faster Error := ioresult; if Error<>0 then raise ECrtSocket.Create('GetBody1',Error); Len := HttpChunkToHex32(LinePChar); // get chunk length in hexa end else begin SockRecvLn(Line); Len := HttpChunkToHex32(pointer(Line)); // get chunk length in hexa end; if Len=0 then begin // ignore next line (normally void) SockRecvLn; break; end; SetLength(Content,LContent+Len); // reserve memory space for this chunk SockInRead(@PByteArray(Content)[LContent],Len) ; // append chunk data inc(LContent,Len); SockRecvLn; // ignore next #13#10 until false; end else if ContentLength>0 then begin SetLength(Content,ContentLength); // not chuncked: direct read SockInRead(pointer(Content),ContentLength); // works with SockIn=nil or not end else if (ContentLength<0) and IdemPChar(pointer(Command),'HTTP/1.0 200') then begin // body = either Content-Length or Transfer-Encoding (HTTP/1.1 RFC 4.3) if SockIn<>nil then // client loop for compatibility with old servers while not eof(SockIn^) do begin readln(SockIn^,Line); if Content='' then Content := Line else Content := Content+#13#10+Line; end; ContentLength := length(Content); // update Content-Length exit; end; // optionaly uncompress content if cardinal(fContentCompress)nil then begin Error := ioresult; if Error<>0 then raise ECrtSocket.Create('GetBody2',Error); end; {$I+} end; procedure GetTrimmed(P: PAnsiChar; out result: SockString); var B: PAnsiChar; begin while (P^>#0) and (P^<=' ') do inc(P); B := P; while P^<>#0 do inc(P); while (P>B) and (P[-1]<=' ') do dec(P); SetString(result,B,P-B); end; var JSON_CONTENT_TYPE_VAR: SockString; procedure THttpSocket.GetHeader(HeadersUnFiltered: boolean); var s,c: SockString; i, len: PtrInt; err: integer; P: PAnsiChar; line: array[0..4095] of AnsiChar; // avoid most memory allocation begin HeaderFlags := []; fBodyRetrieved := false; fContentCompress := -1; integer(fCompressAcceptHeader) := 0; ContentType := ''; Upgrade := ''; ContentLength := -1; ServerInternalState := 0; fSndBufLen := 0; // SockSend() internal buffer is used when adding headers repeat P := @line; if (SockIn<>nil) and not HeadersUnFiltered then begin {$I-} readln(SockIn^,line); err := ioresult; if err<>0 then raise ECrtSocket.CreateFmt('%s.GetHeader',[ClassName],err); {$I+} if line[0]=#0 then break; // HTTP headers end with a void line end else begin SockRecvLn(s); if s = '' then break; P := pointer(s); // set P=nil below to store in Headers[] end; case IdemPCharArray(P,['CONTENT-', 'TRANSFER-ENCODING: CHUNKED', 'CONNECTION: ', 'ACCEPT-ENCODING:', 'UPGRADE:', 'SERVER-INTERNALSTATE:', 'X-POWERED-BY:']) of 0: case IdemPCharArray(P+8,['LENGTH:', 'TYPE:', 'ENCODING:']) of 0: ContentLength := GetCardinal(P+16); 1: begin inc(P,13); while P^=' ' do inc(P); if IdemPChar(P,'APPLICATION/JSON') then ContentType := JSON_CONTENT_TYPE_VAR else begin GetTrimmed(P,ContentType); if ContentType<>'' then P := nil; // is searched by HEADER_CONTENT_TYPE_UPPER later on end; end; 2: if fCompress<>nil then begin GetTrimmed(P+17,c); for i := 0 to high(fCompress) do if fCompress[i].Name=c then begin fContentCompress := i; break; end; end; else P := nil; end; 1: include(HeaderFlags,transferChuked); 2: case IdemPCharArray(P+12,['CLOSE','UPGRADE','KEEP-ALIVE']) of 0: include(HeaderFlags,connectionClose); 1: include(HeaderFlags,connectionUpgrade); 2: begin include(HeaderFlags,connectionKeepAlive); if P[22]=',' then begin inc(P,23); if P^=' ' then inc(P); if IdemPChar(P,'UPGRADE') then include(HeaderFlags,connectionUpgrade); end; end; else P := nil; end; 3: if fCompress<>nil then fCompressAcceptHeader := ComputeContentEncoding(fCompress,P+16) else P := nil; 4: GetTrimmed(P+8,Upgrade); 5: ServerInternalState := GetCardinal(P+21); 6: GetTrimmed(P+13,XPoweredBy); else P := nil; end; if (P=nil) or HeadersUnFiltered then // only store meaningful headers if s='' then begin len := StrLen(line); if len>SizeOf(line)-2 then break; // avoid buffer overflow PWord(@line[len])^ := 13+10 shl 8; // CR + LF SockSend(@line,len+2); end else SockSend(s); // SockSend() internal buffer is used as temporary buffer until false; Headers := copy(fSndBuf, 1, fSndBufLen); fSndBufLen := 0; end; procedure THttpSocket.HeaderAdd(const aValue: SockString); begin if aValue<>'' then Headers := Headers+aValue+#13#10; end; procedure THttpSocket.HeaderSetText(const aText, aForcedContentType: SockString); begin if aText='' then Headers := '' else if aText[length(aText)-1]<>#10 then Headers := aText+#13#10 else Headers := aText; if (aForcedContentType<>'') and (ExistNameValue(pointer(aText),'CONTENT-TYPE:')=nil) then Headers := Headers+'Content-Type: '+aForcedContentType+#13#10; end; function THttpSocket.HeaderGetText(const aRemoteIP: SockString): SockString; begin if (aRemoteIP<>'') and not(hasRemoteIP in HeaderFlags) then begin Headers := Headers+'RemoteIP: '+aRemoteIP+#13#10; include(HeaderFlags,hasRemoteIP); end; result := Headers; end; function THttpSocket.HeaderGetValue(const aUpperName: SockString): SockString; begin result := ''; GetHeaderValue(Headers,aUpperName,result); end; function THttpSocket.RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer): boolean; begin result := RegisterCompressFunc(fCompress,aFunction,fCompressAcceptEncoding,aCompressMinSize)<>''; end; procedure THttpSocket.CompressDataAndWriteHeaders(const OutContentType: SockString; var OutContent: SockString); var OutContentEncoding: SockString; begin if integer(fCompressAcceptHeader)<>0 then begin OutContentEncoding := CompressDataAndGetHeaders(fCompressAcceptHeader,fCompress, OutContentType,OutContent); if OutContentEncoding<>'' then SockSend(['Content-Encoding: ',OutContentEncoding]); end; SockSend(['Content-Length: ',length(OutContent)]); // needed even 0 if (OutContentType<>'') and (OutContentType<>HTTP_RESP_STATICFILE) then SockSend(['Content-Type: ',OutContentType]); end; { THttpServerSocket } constructor THttpServerSocket.Create(aServer: THttpServer); begin inherited Create(5000); if aServer<>nil then begin // nil e.g. from TRTSPOverHTTPServer fServer := aServer; fCompress := aServer.fCompress; fCompressAcceptEncoding := aServer.fCompressAcceptEncoding; fSocketLayer:=aServer.Sock.SocketLayer; TCPPrefix := aServer.TCPPrefix; end; end; function THttpServerSocket.GetRequest(withBody: boolean; headerMaxTix: Int64): THttpServerSocketGetRequestResult; var P: PAnsiChar; status: cardinal; pending: integer; reason, allheaders: SockString; noheaderfilter: boolean; begin result := grError; try // use SockIn with 1KB buffer if not already initialized: 2x faster CreateSockIn; // abort now with no exception if socket is obviously broken if fServer<>nil then begin pending := SockInPending(100,{alsosocket=}true); if (pending<0) or (fServer=nil) or fServer.Terminated then exit; noheaderfilter := fServer.HeadersNotFiltered; end else noheaderfilter := false; // 1st line is command: 'GET /path HTTP/1.1' e.g. SockRecvLn(Command); if TCPPrefix<>'' then if TCPPrefix<>Command then exit else SockRecvLn(Command); P := pointer(Command); if P=nil then exit; // broken GetNextItem(P,' ',fMethod); // 'GET' GetNextItem(P,' ',fURL); // '/path' fKeepAliveClient := ((fServer=nil) or (fServer.ServerKeepAliveTimeOut>0)) and IdemPChar(P,'HTTP/1.1'); Content := ''; // get headers and content GetHeader(noheaderfilter); if fServer<>nil then begin // nil from TRTSPOverHTTPServer if fServer.fRemoteIPHeaderUpper<>'' then // real Internet IP (replace 127.0.0.1 from a proxy) GetHeaderValue(Headers,fServer.fRemoteIPHeaderUpper,fRemoteIP); if fServer.fRemoteConnIDHeaderUpper<>'' then begin P := FindHeaderValue(pointer(Headers),fServer.fRemoteConnIDHeaderUpper); if P<>nil then fRemoteConnectionID := GetNextItemUInt64(P); end; end; if connectionClose in HeaderFlags then fKeepAliveClient := false; if (ContentLength<0) and (KeepAliveClient or (fMethod = 'GET')) then ContentLength := 0; // HTTP/1.1 and no content length -> no eof if (headerMaxTix>0) and (GetTick64>headerMaxTix) then begin result := grTimeout; exit; // allow 10 sec for header -> DOS/TCPSYN Flood end; if fServer<>nil then begin if (ContentLength>0) and (fServer.MaximumAllowedContentLength>0) and (cardinal(ContentLength)>fServer.MaximumAllowedContentLength) then begin SockSend('HTTP/1.0 413 Payload Too Large'#13#10#13#10'Rejected'); SockSendFlush(''); result := grOversizedPayload; exit; end; if Assigned(fServer.OnBeforeBody) then begin allheaders := HeaderGetText(fRemoteIP); status := fServer.OnBeforeBody(fURL,fMethod,allheaders,ContentType,RemoteIP,ContentLength,false); {$ifdef SYNCRTDEBUGLOW} TSynLog.Add.Log(sllCustom2,'GetRequest sock=% OnBeforeBody=% Command=% Headers=%', [fSock, status, LogEscapeFull(Command), LogEscapeFull(allheaders)], self); TSynLog.Add.Log(sllCustom2,'GetRequest OnBeforeBody headers', TypeInfo(TSockStringDynArray), Headers, self); {$endif} if status<>STATUS_SUCCESS then begin reason := StatusCodeToReason(status); SockSend(['HTTP/1.0 ',status,' ',reason,#13#10#13#10,reason,' ', status]); SockSendFlush(''); result := grRejected; exit; end; end; end; if withBody and not (connectionUpgrade in HeaderFlags) then begin if IdemPCharArray(pointer(fMethod),['HEAD','OPTIONS'])<0 then GetBody; result := grBodyReceived; end else result := grHeaderReceived; except on E: Exception do result := grException; end; end; procedure DirectShutdown(sock: TSocket; rdwr: boolean); const SHUT_: array[boolean] of integer = (SHUT_RD, SHUT_RDWR); begin if sock<=0 then exit; {$ifdef LINUXNOTBSD} // at last under Linux close() is enough. For example nginx don't call shutdown if rdwr then {$endif LINUXNOTBSD} Shutdown(sock,SHUT_[rdwr]); // SHUT_RD doesn't unlock accept() on Linux CloseSocket(sock); // SO_LINGER usually set to 5 or 10 seconds end; function AsynchSocket(sock: TSocket): boolean; var nonblocking: integer; begin nonblocking := 1; // for both Windows and POSIX if sock<=0 then result := false else result := IoctlSocket(sock, FIONBIO, nonblocking)=0; end; function AsynchRecv(sock: TSocket; buf: pointer; buflen: integer): integer; begin {$ifdef MSWINDOWS} result := Recv(sock,buf,buflen,0); {$else} {$ifdef KYLIX3} result := LibC.Recv(sock,buf^,buflen,0); {$else} result := fpRecv(sock,buf,buflen,0); {$endif KYLIX3} {$endif MSWINDOWS} end; function AsynchSend(sock: TSocket; buf: pointer; buflen: integer): integer; begin {$ifdef MSWINDOWS} result := Send(sock,buf,buflen,MSG_NOSIGNAL); {$else} {$ifdef KYLIX3} result := LibC.Send(sock,buf^,buflen,MSG_NOSIGNAL); {$else} result := fpSend(sock,buf,buflen,MSG_NOSIGNAL); {$endif} {$endif} end; { ECrtSocket } function GetRemoteIP(aClientSock: TSocket): SockString; var Name: TVarSin; begin if GetPeerName(aClientSock,Name)=0 then IPText(Name,result) else result := ''; end; function SocketErrorMessage(Error: integer): string; begin if Error=-1 then Error := WSAGetLastError; case Error of WSAETIMEDOUT: result := 'WSAETIMEDOUT'; WSAENETDOWN: result := 'WSAENETDOWN'; WSATRY_AGAIN: result := 'WSATRY_AGAIN'; {$ifdef MSWINDOWS} // WSATRY_AGAIN=WSAEWOULDBLOCK on POSIX WSAEWOULDBLOCK: result := 'WSAEWOULDBLOCK'; {$endif} WSAECONNABORTED: result := 'WSAECONNABORTED'; WSAECONNRESET: result := 'WSAECONNRESET'; WSAEMFILE: result := 'WSAEMFILE'; else result := ''; end; result := Format('%d %s %s',[Error,result,SysErrorMessage(Error)]); end; constructor ECrtSocket.Create(const Msg: string); begin Create(Msg,WSAGetLastError); end; constructor ECrtSocket.Create(const Msg: string; Error: integer); begin if Error=0 then fLastError := WSAEWOULDBLOCK else // if unknown, probably a timeout fLastError := abs(Error); inherited CreateFmt('%s [%s]', [Msg,SocketErrorMessage(fLastError)]); end; constructor ECrtSocket.CreateFmt(const Msg: string; const Args: array of const; Error: integer); begin if Error<0 then Error := WSAGetLastError; Create(Format(Msg,Args),Error); end; { TSynThreadPool } const // up to 256 * 2MB = 512MB of RAM for the TSynThreadPoolWorkThread stack THREADPOOL_MAXTHREADS = 256; // kept-alive or big HTTP requests will create a dedicated THttpServerResp // - each thread reserves 2 MB of memory so it may break the server // - keep the value to a decent number, to let resources be constrained up to 1GB THREADPOOL_MAXWORKTHREADS = 512; // if HTTP body length is bigger than 16 MB, creates a dedicated THttpServerResp THREADPOOL_BIGBODYSIZE = 16*1024*1024; constructor TSynThreadPool.Create(NumberOfThreads: Integer; {$ifdef USE_WINIOCP}aOverlapHandle: THandle{$else}aQueuePendingContext: boolean{$endif}); var i: integer; begin if NumberOfThreads=0 then NumberOfThreads := 1 else if cardinal(NumberOfThreads)>THREADPOOL_MAXTHREADS then NumberOfThreads := THREADPOOL_MAXTHREADS; // create IO completion port to queue the HTTP requests {$ifdef USE_WINIOCP} fRequestQueue := CreateIoCompletionPort(aOverlapHandle, 0, 0, NumberOfThreads); if fRequestQueue=INVALID_HANDLE_VALUE then begin fRequestQueue := 0; exit; end; {$else} InitializeCriticalSection(fSafe); fQueuePendingContext := aQueuePendingContext; {$endif} // now create the worker threads fWorkThreadCount := NumberOfThreads; SetLength(fWorkThread,fWorkThreadCount); for i := 0 to fWorkThreadCount-1 do fWorkThread[i] := TSynThreadPoolWorkThread.Create(Self); end; destructor TSynThreadPool.Destroy; var i: integer; endtix: Int64; begin fTerminated := true; // fWorkThread[].Execute will check this flag try // notify the threads we are shutting down for i := 0 to fWorkThreadCount-1 do {$ifdef USE_WINIOCP} PostQueuedCompletionStatus(fRequestQueue,0,0,nil); {$else} fWorkThread[i].fEvent.SetEvent; {$endif} {$ifndef USE_WINIOCP} // cleanup now any pending task (e.g. THttpServerSocket instance) for i := 0 to fPendingContextCount-1 do TaskAbort(fPendingContext[i]); {$endif} // wait for threads to finish, with 30 seconds TimeOut endtix := GetTick64+30000; while (fRunningThreads>0) and (GetTick64QueueLength then exit; // too many connection limit reached (see QueueIsFull) if n=length(fPendingContext) then SetLength(fPendingContext,n+n shr 3+64); fPendingContext[n] := aContext; inc(fPendingContextCount); result := true; // added in pending queue finally LeaveCriticalsection(fSafe); if found<>nil then found.fEvent.SetEvent; // rather notify outside of the fSafe lock end; end; {$endif} var tix, starttix, endtix: Int64; begin result := false; if (self=nil) or fTerminated then exit; result := Enqueue; if result then exit; inc(fContentionCount); if (fContentionAbortDelay>0) and aWaitOnContention then begin tix := GetTick64; starttix := tix; endtix := tix+fContentionAbortDelay; // default 5 sec repeat // during this delay, no new connection is ACCEPTed if tix-starttix<50 then // wait for an available slot in the queue SleepHiRes(1) else SleepHiRes(10); tix := GetTick64; if fTerminated then exit; if Enqueue then begin result := true; // thread pool acquired or queued the client sock break; end; until fTerminated or (tix>endtix); inc(fContentionTime,tix-starttix); end; if not result then inc(fContentionAbortCount); end; {$ifndef USE_WINIOCP} function TSynThreadPool.GetPendingContextCount: integer; begin result := 0; if (self=nil) or fTerminated or (fPendingContext=nil) then exit; EnterCriticalsection(fSafe); try result := fPendingContextCount; finally LeaveCriticalsection(fSafe); end; end; function TSynThreadPool.QueueIsFull: boolean; begin result := fQueuePendingContext and (GetPendingContextCount+fWorkThreadCount>QueueLength); end; function TSynThreadPool.PopPendingContext: pointer; begin result := nil; if (self=nil) or fTerminated or (fPendingContext=nil) then exit; EnterCriticalsection(fSafe); try if fPendingContextCount>0 then begin result := fPendingContext[0]; dec(fPendingContextCount); Move(fPendingContext[1],fPendingContext[0],fPendingContextCount*SizeOf(pointer)); if fPendingContextCount=128 then SetLength(fPendingContext,128); // small queue when congestion is resolved end; finally LeaveCriticalsection(fSafe); end; end; function TSynThreadPool.QueueLength: integer; begin result := 10000; // lazy high value end; {$endif USE_WINIOCP} function TSynThreadPool.NeedStopOnIOError: boolean; begin result := True; end; procedure TSynThreadPool.TaskAbort(aContext: Pointer); begin end; { TSynThreadPoolWorkThread } constructor TSynThreadPoolWorkThread.Create(Owner: TSynThreadPool); begin fOwner := Owner; // ensure it is set ASAP: on Linux, Execute raises immediately fOnThreadTerminate := Owner.fOnThreadTerminate; {$ifndef USE_WINIOCP} fEvent := TEvent.Create(nil,false,false,''); {$endif} inherited Create(false); end; destructor TSynThreadPoolWorkThread.Destroy; begin inherited Destroy; {$ifndef USE_WINIOCP} fEvent.Free; {$endif} end; {$ifdef USE_WINIOCP} function GetQueuedCompletionStatus(CompletionPort: THandle; var lpNumberOfBytesTransferred: DWORD; var lpCompletionKey: PtrUInt; var lpOverlapped: pointer; dwMilliseconds: DWORD): BOOL; stdcall; external kernel32; // redefine with an unique signature for all Delphi/FPC {$endif} procedure TSynThreadPoolWorkThread.DoTask(Context: pointer); begin try fOwner.Task(Self,Context); except on Exception do // intercept any exception and let the thread continue inc(fOwner.fExceptionsCount); end; end; procedure TSynThreadPoolWorkThread.Execute; var ctxt: pointer; {$ifdef USE_WINIOCP} dum1: DWORD; dum2: PtrUInt; {$endif} begin if fOwner<>nil then try fThreadNumber := InterlockedIncrement(fOwner.fRunningThreads); NotifyThreadStart(self); repeat {$ifdef USE_WINIOCP} if (not GetQueuedCompletionStatus(fOwner.fRequestQueue,dum1,dum2,ctxt,INFINITE) and fOwner.NeedStopOnIOError) or fOwner.fTerminated then break; if ctxt<>nil then DoTask(ctxt); {$else} fEvent.WaitFor(INFINITE); if fOwner.fTerminated then break; EnterCriticalSection(fOwner.fSafe); ctxt := fProcessingContext; LeaveCriticalSection(fOwner.fSafe); if ctxt<>nil then begin repeat DoTask(ctxt); ctxt := fOwner.PopPendingContext; // unqueue any pending context until ctxt=nil; EnterCriticalSection(fOwner.fSafe); fProcessingContext := nil; // indicates this thread is now available LeaveCriticalSection(fOwner.fSafe); end; {$endif USE_WINIOCP} until fOwner.fTerminated or Terminated; finally InterlockedDecrement(fOwner.fRunningThreads); end; end; procedure TSynThreadPoolWorkThread.NotifyThreadStart(Sender: TSynThread); begin if Sender=nil then raise ECrtSocket.Create('NotifyThreadStart(nil)'); {$ifdef FPC} {$ifdef LINUX} if fNotifyThreadStartName='' then begin fNotifyThreadStartName := format('Pool%d-%4x',[fThreadNumber,PtrInt(fOwner)]); SetUnixThreadName(fThreadID,fNotifyThreadStartName); end; {$endif} {$endif} if Assigned(fOwner.fOnThreadStart) and not Assigned(Sender.fStartNotified) then begin fOwner.fOnThreadStart(Sender); Sender.fStartNotified := self; end; end; { TSynThreadPoolTHttpServer } constructor TSynThreadPoolTHttpServer.Create(Server: THttpServer; NumberOfThreads: Integer=32); begin fServer := Server; fOnThreadTerminate := fServer.fOnThreadTerminate; inherited Create(NumberOfThreads{$ifndef USE_WINIOCP},{queuepending=}true{$endif}); end; {$ifndef USE_WINIOCP} function TSynThreadPoolTHttpServer.QueueLength: integer; begin if fServer=nil then result := 10000 else result := fServer.fHTTPQueueLength; end; {$endif USE_WINIOCP} procedure TSynThreadPoolTHttpServer.Task(aCaller: TSynThread; aContext: Pointer); var ServerSock: THttpServerSocket; headertix: Int64; res: THttpServerSocketGetRequestResult; begin ServerSock := aContext; try if fServer.Terminated then exit; // get Header of incoming request in the thread pool headertix := fServer.HeaderRetrieveAbortDelay; if headertix>0 then headertix := headertix+GetTick64; res := ServerSock.GetRequest({withbody=}false,headertix); if (fServer=nil) or fServer.Terminated then exit; InterlockedIncrement(fServer.fStats[res]); case res of grHeaderReceived: begin // connection and header seem valid -> process request further if (fServer.ServerKeepAliveTimeOut>0) and (fServer.fInternalHttpServerRespList.CountTHREADPOOL_BIGBODYSIZE)) then begin // HTTP/1.1 Keep Alive (including WebSockets) or posted data > 16 MB // -> process in dedicated background thread fServer.fThreadRespClass.Create(ServerSock,fServer); ServerSock := nil; // THttpServerResp will own and free ServerSock end else begin // no Keep Alive = multi-connection -> process in the Thread Pool if not (connectionUpgrade in ServerSock.HeaderFlags) and (IdemPCharArray(pointer(ServerSock.Method),['HEAD','OPTIONS'])<0) then begin ServerSock.GetBody; // we need to get it now InterlockedIncrement(fServer.fStats[grBodyReceived]); end; // multi-connection -> process now fServer.Process(ServerSock,ServerSock.RemoteConnectionID,aCaller); fServer.OnDisconnect; // no Shutdown here: will be done client-side end; end; grOwned: // e.g. for asynchrounous WebSockets ServerSock := nil; // to ignore FreeAndNil(ServerSock) below end; // errors will close the connection finally FreeAndNil(ServerSock); end; end; procedure TSynThreadPoolTHttpServer.TaskAbort(aContext: Pointer); begin THttpServerSocket(aContext).Free; end; {$ifdef MSWINDOWS} { ************ http.sys / HTTP API low-level direct access } {$MINENUMSIZE 4} {$A+} {$ifdef FPC} {$PACKRECORDS C} {$endif} type // HTTP version used HTTP_VERSION = packed record MajorVersion: word; MinorVersion: word; end; // the req* values identify Request Headers, and resp* Response Headers THttpHeader = ( reqCacheControl, reqConnection, reqDate, reqKeepAlive, reqPragma, reqTrailer, reqTransferEncoding, reqUpgrade, reqVia, reqWarning, reqAllow, reqContentLength, reqContentType, reqContentEncoding, reqContentLanguage, reqContentLocation, reqContentMd5, reqContentRange, reqExpires, reqLastModified, reqAccept, reqAcceptCharset, reqAcceptEncoding, reqAcceptLanguage, reqAuthorization, reqCookie, reqExpect, reqFrom, reqHost, reqIfMatch, reqIfModifiedSince, reqIfNoneMatch, reqIfRange, reqIfUnmodifiedSince, reqMaxForwards, reqProxyAuthorization, reqReferrer, reqRange, reqTe, reqTranslate, reqUserAgent {$ifdef DELPHI5OROLDER} ); const // Delphi 5 does not support values overlapping for enums respAcceptRanges = THttpHeader(20); respAge = THttpHeader(21); respEtag = THttpHeader(22); respLocation = THttpHeader(23); respProxyAuthenticate = THttpHeader(24); respRetryAfter = THttpHeader(25); respServer = THttpHeader(26); respSetCookie = THttpHeader(27); respVary = THttpHeader(28); respWwwAuthenticate = THttpHeader(29); type {$else} , respAcceptRanges = 20, respAge, respEtag, respLocation, respProxyAuthenticate, respRetryAfter, respServer, respSetCookie, respVary, respWwwAuthenticate); {$endif} THttpVerb = ( hvUnparsed, hvUnknown, hvInvalid, hvOPTIONS, hvGET, hvHEAD, hvPOST, hvPUT, hvDELETE, hvTRACE, hvCONNECT, hvTRACK, // used by Microsoft Cluster Server for a non-logged trace hvMOVE, hvCOPY, hvPROPFIND, hvPROPPATCH, hvMKCOL, hvLOCK, hvUNLOCK, hvSEARCH, hvMaximum ); THttpChunkType = ( hctFromMemory, hctFromFileHandle, hctFromFragmentCache); THttpServiceConfigID = ( hscIPListenList, hscSSLCertInfo, hscUrlAclInfo, hscMax); THttpServiceConfigQueryType = ( hscQueryExact, hscQueryNext, hscQueryMax); HTTP_URL_CONTEXT = HTTP_OPAQUE_ID; HTTP_CONNECTION_ID = HTTP_OPAQUE_ID; HTTP_RAW_CONNECTION_ID = HTTP_OPAQUE_ID; // Pointers overlap and point into pFullUrl. nil if not present. HTTP_COOKED_URL = record FullUrlLength: word; // in bytes not including the #0 HostLength: word; // in bytes not including the #0 AbsPathLength: word; // in bytes not including the #0 QueryStringLength: word; // in bytes not including the #0 pFullUrl: PWideChar; // points to "http://hostname:port/abs/.../path?query" pHost: PWideChar; // points to the first char in the hostname pAbsPath: PWideChar; // Points to the 3rd '/' char pQueryString: PWideChar; // Points to the 1st '?' char or #0 end; HTTP_TRANSPORT_ADDRESS = record pRemoteAddress: PSOCKADDR; pLocalAddress: PSOCKADDR; end; HTTP_UNKNOWN_HEADER = record NameLength: word; // in bytes not including the #0 RawValueLength: word; // in bytes not including the n#0 pName: PAnsiChar; // The header name (minus the ':' character) pRawValue: PAnsiChar; // The header value end; PHTTP_UNKNOWN_HEADER = ^HTTP_UNKNOWN_HEADER; HTTP_UNKNOWN_HEADERs = array of HTTP_UNKNOWN_HEADER; HTTP_KNOWN_HEADER = record RawValueLength: word; // in bytes not including the #0 pRawValue: PAnsiChar; end; PHTTP_KNOWN_HEADER = ^HTTP_KNOWN_HEADER; HTTP_RESPONSE_HEADERS = record // number of entries in the unknown HTTP headers array UnknownHeaderCount: word; // array of unknown HTTP headers pUnknownHeaders: pointer; // Reserved, must be 0 TrailerCount: word; // Reserved, must be nil pTrailers: pointer; // Known headers KnownHeaders: array[low(THttpHeader)..respWwwAuthenticate] of HTTP_KNOWN_HEADER; end; HTTP_REQUEST_HEADERS = record // number of entries in the unknown HTTP headers array UnknownHeaderCount: word; // array of unknown HTTP headers pUnknownHeaders: PHTTP_UNKNOWN_HEADER; // Reserved, must be 0 TrailerCount: word; // Reserved, must be nil pTrailers: pointer; // Known headers KnownHeaders: array[low(THttpHeader)..reqUserAgent] of HTTP_KNOWN_HEADER; end; HTTP_BYTE_RANGE = record StartingOffset: ULARGE_INTEGER; Length: ULARGE_INTEGER; end; // we use 3 distinct HTTP_DATA_CHUNK_* records since variable records // alignment is buggy/non compatible under Delphi XE3 HTTP_DATA_CHUNK_INMEMORY = record DataChunkType: THttpChunkType; // always hctFromMemory Reserved1: ULONG; pBuffer: pointer; BufferLength: ULONG; Reserved2: ULONG; Reserved3: ULONG; end; PHTTP_DATA_CHUNK_INMEMORY = ^HTTP_DATA_CHUNK_INMEMORY; HTTP_DATA_CHUNK_FILEHANDLE = record DataChunkType: THttpChunkType; // always hctFromFileHandle ByteRange: HTTP_BYTE_RANGE; FileHandle: THandle; end; HTTP_DATA_CHUNK_FRAGMENTCACHE = record DataChunkType: THttpChunkType; // always hctFromFragmentCache FragmentNameLength: word; // in bytes not including the #0 pFragmentName: PWideChar; end; HTTP_SSL_CLIENT_CERT_INFO = record CertFlags: ULONG; CertEncodedSize: ULONG; pCertEncoded: PUCHAR; Token: THandle; CertDeniedByMapper: boolean; end; PHTTP_SSL_CLIENT_CERT_INFO = ^HTTP_SSL_CLIENT_CERT_INFO; HTTP_SSL_INFO = record ServerCertKeySize: word; ConnectionKeySize: word; ServerCertIssuerSize: ULONG; ServerCertSubjectSize: ULONG; pServerCertIssuer: PAnsiChar; pServerCertSubject: PAnsiChar; pClientCertInfo: PHTTP_SSL_CLIENT_CERT_INFO; SslClientCertNegotiated: ULONG; end; PHTTP_SSL_INFO = ^HTTP_SSL_INFO; HTTP_SERVICE_CONFIG_URLACL_KEY = record pUrlPrefix: PWideChar; end; HTTP_SERVICE_CONFIG_URLACL_PARAM = record pStringSecurityDescriptor: PWideChar; end; HTTP_SERVICE_CONFIG_URLACL_SET = record KeyDesc: HTTP_SERVICE_CONFIG_URLACL_KEY; ParamDesc: HTTP_SERVICE_CONFIG_URLACL_PARAM; end; HTTP_SERVICE_CONFIG_URLACL_QUERY = record QueryDesc: THttpServiceConfigQueryType; KeyDesc: HTTP_SERVICE_CONFIG_URLACL_KEY; dwToken: DWORD; end; HTTP_REQUEST_INFO_TYPE = ( HttpRequestInfoTypeAuth, HttpRequestInfoTypeChannelBind, HttpRequestInfoTypeSslProtocol, HttpRequestInfoTypeSslTokenBindingDraft, HttpRequestInfoTypeSslTokenBinding, HttpRequestInfoTypeRequestTiming, HttpRequestInfoTypeTcpInfoV0, HttpRequestInfoTypeRequestSizing, HttpRequestInfoTypeQuicStats, HttpRequestInfoTypeTcpInfoV1 ); // about Authentication in HTTP Version 2.0 // see https://msdn.microsoft.com/en-us/library/windows/desktop/aa364452 HTTP_AUTH_STATUS = ( HttpAuthStatusSuccess, HttpAuthStatusNotAuthenticated, HttpAuthStatusFailure ); HTTP_REQUEST_AUTH_TYPE = ( HttpRequestAuthTypeNone, HttpRequestAuthTypeBasic, HttpRequestAuthTypeDigest, HttpRequestAuthTypeNTLM, HttpRequestAuthTypeNegotiate, HttpRequestAuthTypeKerberos ); SECURITY_STATUS = ULONG; HTTP_REQUEST_AUTH_INFO = record AuthStatus: HTTP_AUTH_STATUS; SecStatus: SECURITY_STATUS; Flags: ULONG; AuthType: HTTP_REQUEST_AUTH_TYPE; AccessToken: THandle; ContextAttributes: ULONG; PackedContextLength: ULONG; PackedContextType: ULONG; PackedContext: pointer; MutualAuthDataLength: ULONG; pMutualAuthData: PAnsiChar; PackageNameLength: word; pPackageName: LPWSTR; end; PHTTP_REQUEST_AUTH_INFO = ^HTTP_REQUEST_AUTH_INFO; HTTP_REQUEST_INFO = record InfoType: HTTP_REQUEST_INFO_TYPE; InfoLength: ULONG; pInfo: pointer; end; HTTP_REQUEST_INFOS = array[0..1000] of HTTP_REQUEST_INFO; PHTTP_REQUEST_INFOS = ^HTTP_REQUEST_INFOS; /// structure used to handle data associated with a specific request HTTP_REQUEST = record // either 0 (Only Header), either HTTP_RECEIVE_REQUEST_FLAG_COPY_BODY Flags: cardinal; // An identifier for the connection on which the request was received ConnectionId: HTTP_CONNECTION_ID; // A value used to identify the request when calling // HttpReceiveRequestEntityBody, HttpSendHttpResponse, and/or // HttpSendResponseEntityBody RequestId: HTTP_REQUEST_ID; // The context associated with the URL prefix UrlContext: HTTP_URL_CONTEXT; // The HTTP version number Version: HTTP_VERSION; // An HTTP verb associated with this request Verb: THttpVerb; // The length of the verb string if the Verb field is hvUnknown // (in bytes not including the last #0) UnknownVerbLength: word; // The length of the raw (uncooked) URL (in bytes not including the last #0) RawUrlLength: word; // Pointer to the verb string if the Verb field is hvUnknown pUnknownVerb: PAnsiChar; // Pointer to the raw (uncooked) URL pRawUrl: PAnsiChar; // The canonicalized Unicode URL CookedUrl: HTTP_COOKED_URL; // Local and remote transport addresses for the connection Address: HTTP_TRANSPORT_ADDRESS; // The request headers. Headers: HTTP_REQUEST_HEADERS; // The total number of bytes received from network for this request BytesReceived: ULONGLONG; EntityChunkCount: word; pEntityChunks: pointer; RawConnectionId: HTTP_RAW_CONNECTION_ID; // SSL connection information pSslInfo: PHTTP_SSL_INFO; { beginning of HTTP_REQUEST_V2 structure - manual padding is needed :( } {$ifdef CPU32} padding: dword; {$endif CPU32} /// how many extended info about a specific request is available in v2 RequestInfoCount: word; /// v2 trailing structure used to handle extended info about a specific request pRequestInfo: PHTTP_REQUEST_INFOS; end; PHTTP_REQUEST = ^HTTP_REQUEST; HTTP_RESPONSE_INFO_TYPE = ( HttpResponseInfoTypeMultipleKnownHeaders, HttpResponseInfoTypeAuthenticationProperty, HttpResponseInfoTypeQosProperty, HttpResponseInfoTypeChannelBind ); HTTP_RESPONSE_INFO = record Typ: HTTP_RESPONSE_INFO_TYPE; Length: ULONG; pInfo: Pointer; end; PHTTP_RESPONSE_INFO = ^HTTP_RESPONSE_INFO; /// structure as expected by HttpSendHttpResponse() API HTTP_RESPONSE = object public Flags: cardinal; // The raw HTTP protocol version number Version: HTTP_VERSION; // The HTTP status code (e.g., 200) StatusCode: word; // in bytes not including the '\0' ReasonLength: word; // The HTTP reason (e.g., "OK"). This MUST not contain non-ASCII characters // (i.e., all chars must be in range 0x20-0x7E). pReason: PAnsiChar; // The response headers Headers: HTTP_RESPONSE_HEADERS; // number of elements in pEntityChunks[] array EntityChunkCount: word; // pEntityChunks points to an array of EntityChunkCount HTTP_DATA_CHUNK_* pEntityChunks: pointer; // contains the number of HTTP API 2.0 extended information ResponseInfoCount: word; // map the HTTP API 2.0 extended information pResponseInfo: PHTTP_RESPONSE_INFO; // will set both StatusCode and Reason // - OutStatus is a temporary variable which will be field with the // corresponding text procedure SetStatus(code: integer; var OutStatus: SockString); // will set the content of the reponse, and ContentType header procedure SetContent(var DataChunk: HTTP_DATA_CHUNK_INMEMORY; const Content: SockString; const ContentType: SockString='text/html'); /// will set all header values from lines // - Content-Type/Content-Encoding/Location will be set in KnownHeaders[] // - all other headers will be set in temp UnknownHeaders[] procedure SetHeaders(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs); /// add one header value to the internal headers // - SetHeaders() method should have been called before to initialize the // internal UnknownHeaders[] array function AddCustomHeader(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs; ForceCustomHeader: boolean): PAnsiChar; end; PHTTP_RESPONSE = ^HTTP_RESPONSE; HTTP_PROPERTY_FLAGS = ULONG; HTTP_ENABLED_STATE = ( HttpEnabledStateActive, HttpEnabledStateInactive ); PHTTP_ENABLED_STATE = ^HTTP_ENABLED_STATE; HTTP_STATE_INFO = record Flags: HTTP_PROPERTY_FLAGS; State: HTTP_ENABLED_STATE; end; PHTTP_STATE_INFO = ^HTTP_STATE_INFO; THTTP_503_RESPONSE_VERBOSITY = ( Http503ResponseVerbosityBasic, Http503ResponseVerbosityLimited, Http503ResponseVerbosityFull ); PHTTP_503_RESPONSE_VERBOSITY = ^ THTTP_503_RESPONSE_VERBOSITY; HTTP_QOS_SETTING_TYPE = ( HttpQosSettingTypeBandwidth, HttpQosSettingTypeConnectionLimit, HttpQosSettingTypeFlowRate // Windows Server 2008 R2 and Windows 7 only. ); PHTTP_QOS_SETTING_TYPE = ^HTTP_QOS_SETTING_TYPE; HTTP_QOS_SETTING_INFO = record QosType: HTTP_QOS_SETTING_TYPE; QosSetting: Pointer; end; PHTTP_QOS_SETTING_INFO = ^HTTP_QOS_SETTING_INFO; HTTP_CONNECTION_LIMIT_INFO = record Flags: HTTP_PROPERTY_FLAGS; MaxConnections: ULONG; end; PHTTP_CONNECTION_LIMIT_INFO = ^HTTP_CONNECTION_LIMIT_INFO; HTTP_BANDWIDTH_LIMIT_INFO = record Flags: HTTP_PROPERTY_FLAGS; MaxBandwidth: ULONG; end; PHTTP_BANDWIDTH_LIMIT_INFO = ^HTTP_BANDWIDTH_LIMIT_INFO; HTTP_FLOWRATE_INFO = record Flags: HTTP_PROPERTY_FLAGS; MaxBandwidth: ULONG; MaxPeakBandwidth: ULONG; BurstSize: ULONG; end; PHTTP_FLOWRATE_INFO = ^HTTP_FLOWRATE_INFO; const HTTP_MIN_ALLOWED_BANDWIDTH_THROTTLING_RATE {:ULONG} = 1024; HTTP_LIMIT_INFINITE {:ULONG} = ULONG(-1); type HTTP_SERVICE_CONFIG_TIMEOUT_KEY = ( IdleConnectionTimeout, HeaderWaitTimeout ); PHTTP_SERVICE_CONFIG_TIMEOUT_KEY = ^HTTP_SERVICE_CONFIG_TIMEOUT_KEY; HTTP_SERVICE_CONFIG_TIMEOUT_PARAM = word; PHTTP_SERVICE_CONFIG_TIMEOUT_PARAM = ^HTTP_SERVICE_CONFIG_TIMEOUT_PARAM; HTTP_SERVICE_CONFIG_TIMEOUT_SET = record KeyDesc: HTTP_SERVICE_CONFIG_TIMEOUT_KEY; ParamDesc: HTTP_SERVICE_CONFIG_TIMEOUT_PARAM; end; PHTTP_SERVICE_CONFIG_TIMEOUT_SET = ^HTTP_SERVICE_CONFIG_TIMEOUT_SET; HTTP_TIMEOUT_LIMIT_INFO = record Flags: HTTP_PROPERTY_FLAGS; EntityBody: word; DrainEntityBody: word; RequestQueue: word; IdleConnection: word; HeaderWait: word; MinSendRate: cardinal; end; PHTTP_TIMEOUT_LIMIT_INFO = ^HTTP_TIMEOUT_LIMIT_INFO; HTTP_LISTEN_ENDPOINT_INFO = record Flags: HTTP_PROPERTY_FLAGS; EnableSharing: boolean; end; PHTTP_LISTEN_ENDPOINT_INFO = ^HTTP_LISTEN_ENDPOINT_INFO; HTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS = record DomainNameLength: word; DomainName: PWideChar; RealmLength: word; Realm: PWideChar; end; PHTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS = ^HTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS; HTTP_SERVER_AUTHENTICATION_BASIC_PARAMS = record RealmLength: word; Realm: PWideChar; end; PHTTP_SERVER_AUTHENTICATION_BASIC_PARAMS = ^HTTP_SERVER_AUTHENTICATION_BASIC_PARAMS; const HTTP_AUTH_ENABLE_BASIC = $00000001; HTTP_AUTH_ENABLE_DIGEST = $00000002; HTTP_AUTH_ENABLE_NTLM = $00000004; HTTP_AUTH_ENABLE_NEGOTIATE = $00000008; HTTP_AUTH_ENABLE_KERBEROS = $00000010; HTTP_AUTH_ENABLE_ALL = $0000001F; HTTP_AUTH_EX_FLAG_ENABLE_KERBEROS_CREDENTIAL_CACHING = $01; HTTP_AUTH_EX_FLAG_CAPTURE_CREDENTIAL = $02; type HTTP_SERVER_AUTHENTICATION_INFO = record Flags: HTTP_PROPERTY_FLAGS; AuthSchemes: ULONG; ReceiveMutualAuth: BYTEBOOL; ReceiveContextHandle: BYTEBOOL; DisableNTLMCredentialCaching: BYTEBOOL; ExFlags: BYTE; DigestParams: HTTP_SERVER_AUTHENTICATION_DIGEST_PARAMS; BasicParams: HTTP_SERVER_AUTHENTICATION_BASIC_PARAMS; end; PHTTP_SERVER_AUTHENTICATION_INFO = ^HTTP_SERVER_AUTHENTICATION_INFO; HTTP_SERVICE_BINDING_TYPE=( HttpServiceBindingTypeNone, HttpServiceBindingTypeW, HttpServiceBindingTypeA ); HTTP_SERVICE_BINDING_BASE = record BindingType: HTTP_SERVICE_BINDING_TYPE; end; PHTTP_SERVICE_BINDING_BASE = ^HTTP_SERVICE_BINDING_BASE; HTTP_SERVICE_BINDING_A = record Base: HTTP_SERVICE_BINDING_BASE; Buffer: PAnsiChar; BufferSize: ULONG; end; PHTTP_SERVICE_BINDING_A = HTTP_SERVICE_BINDING_A; HTTP_SERVICE_BINDING_W = record Base: HTTP_SERVICE_BINDING_BASE; Buffer: PWCHAR; BufferSize: ULONG; end; PHTTP_SERVICE_BINDING_W = ^HTTP_SERVICE_BINDING_W; HTTP_AUTHENTICATION_HARDENING_LEVELS = ( HttpAuthenticationHardeningLegacy, HttpAuthenticationHardeningMedium, HttpAuthenticationHardeningStrict ); const HTTP_CHANNEL_BIND_PROXY = $1; HTTP_CHANNEL_BIND_PROXY_COHOSTING = $20; HTTP_CHANNEL_BIND_NO_SERVICE_NAME_CHECK = $2; HTTP_CHANNEL_BIND_DOTLESS_SERVICE = $4; HTTP_CHANNEL_BIND_SECURE_CHANNEL_TOKEN = $8; HTTP_CHANNEL_BIND_CLIENT_SERVICE = $10; type HTTP_CHANNEL_BIND_INFO = record Hardening: HTTP_AUTHENTICATION_HARDENING_LEVELS; Flags: ULONG; ServiceNames: PHTTP_SERVICE_BINDING_BASE; NumberOfServiceNames: ULONG; end; PHTTP_CHANNEL_BIND_INFO = ^HTTP_CHANNEL_BIND_INFO; HTTP_REQUEST_CHANNEL_BIND_STATUS = record ServiceName: PHTTP_SERVICE_BINDING_BASE; ChannelToken: PUCHAR; ChannelTokenSize: ULONG; Flags: ULONG; end; PHTTP_REQUEST_CHANNEL_BIND_STATUS = ^HTTP_REQUEST_CHANNEL_BIND_STATUS; const // Logging option flags. When used in the logging configuration alters // some default logging behaviour. // HTTP_LOGGING_FLAG_LOCAL_TIME_ROLLOVER - This flag is used to change // the log file rollover to happen by local time based. By default // log file rollovers happen by GMT time. HTTP_LOGGING_FLAG_LOCAL_TIME_ROLLOVER = 1; // HTTP_LOGGING_FLAG_USE_UTF8_CONVERSION - When set the unicode fields // will be converted to UTF8 multibytes when writting to the log // files. When this flag is not present, the local code page // conversion happens. HTTP_LOGGING_FLAG_USE_UTF8_CONVERSION = 2; // HTTP_LOGGING_FLAG_LOG_ERRORS_ONLY - // HTTP_LOGGING_FLAG_LOG_SUCCESS_ONLY - These two flags are used to // to do selective logging. If neither of them are present both // types of requests will be logged. Only one these flags can be // set at a time. They are mutually exclusive. HTTP_LOGGING_FLAG_LOG_ERRORS_ONLY = 4; HTTP_LOGGING_FLAG_LOG_SUCCESS_ONLY = 8; // The known log fields recognized/supported by HTTPAPI. Following fields // are used for W3C logging. Subset of them are also used for error logging HTTP_LOG_FIELD_DATE = $00000001; HTTP_LOG_FIELD_TIME = $00000002; HTTP_LOG_FIELD_CLIENT_IP = $00000004; HTTP_LOG_FIELD_USER_NAME = $00000008; HTTP_LOG_FIELD_SITE_NAME = $00000010; HTTP_LOG_FIELD_COMPUTER_NAME = $00000020; HTTP_LOG_FIELD_SERVER_IP = $00000040; HTTP_LOG_FIELD_METHOD = $00000080; HTTP_LOG_FIELD_URI_STEM = $00000100; HTTP_LOG_FIELD_URI_QUERY = $00000200; HTTP_LOG_FIELD_STATUS = $00000400; HTTP_LOG_FIELD_WIN32_STATUS = $00000800; HTTP_LOG_FIELD_BYTES_SENT = $00001000; HTTP_LOG_FIELD_BYTES_RECV = $00002000; HTTP_LOG_FIELD_TIME_TAKEN = $00004000; HTTP_LOG_FIELD_SERVER_PORT = $00008000; HTTP_LOG_FIELD_USER_AGENT = $00010000; HTTP_LOG_FIELD_COOKIE = $00020000; HTTP_LOG_FIELD_REFERER = $00040000; HTTP_LOG_FIELD_VERSION = $00080000; HTTP_LOG_FIELD_HOST = $00100000; HTTP_LOG_FIELD_SUB_STATUS = $00200000; HTTP_ALL_NON_ERROR_LOG_FIELDS = HTTP_LOG_FIELD_SUB_STATUS*2-1; // Fields that are used only for error logging HTTP_LOG_FIELD_CLIENT_PORT = $00400000; HTTP_LOG_FIELD_URI = $00800000; HTTP_LOG_FIELD_SITE_ID = $01000000; HTTP_LOG_FIELD_REASON = $02000000; HTTP_LOG_FIELD_QUEUE_NAME = $04000000; type HTTP_LOGGING_TYPE = ( HttpLoggingTypeW3C, HttpLoggingTypeIIS, HttpLoggingTypeNCSA, HttpLoggingTypeRaw ); HTTP_LOGGING_ROLLOVER_TYPE = ( HttpLoggingRolloverSize, HttpLoggingRolloverDaily, HttpLoggingRolloverWeekly, HttpLoggingRolloverMonthly, HttpLoggingRolloverHourly ); HTTP_LOGGING_INFO = record Flags: HTTP_PROPERTY_FLAGS; LoggingFlags: ULONG; SoftwareName: PWideChar; SoftwareNameLength: word; DirectoryNameLength: word; DirectoryName: PWideChar; Format: HTTP_LOGGING_TYPE; Fields: ULONG; pExtFields: pointer; NumOfExtFields: word; MaxRecordSize: word; RolloverType: HTTP_LOGGING_ROLLOVER_TYPE; RolloverSize: ULONG; pSecurityDescriptor: PSECURITY_DESCRIPTOR; end; PHTTP_LOGGING_INFO = ^HTTP_LOGGING_INFO; HTTP_LOG_DATA_TYPE = ( HttpLogDataTypeFields ); HTTP_LOG_DATA = record Typ: HTTP_LOG_DATA_TYPE end; PHTTP_LOG_DATA = ^HTTP_LOG_DATA; HTTP_LOG_FIELDS_DATA = record Base: HTTP_LOG_DATA; UserNameLength: word; UriStemLength: word; ClientIpLength: word; ServerNameLength: word; ServiceNameLength: word; ServerIpLength: word; MethodLength: word; UriQueryLength: word; HostLength: word; UserAgentLength: word; CookieLength: word; ReferrerLength: word; UserName: PWideChar; UriStem: PWideChar; ClientIp: PAnsiChar; ServerName: PAnsiChar; ServiceName: PAnsiChar; ServerIp: PAnsiChar; Method: PAnsiChar; UriQuery: PAnsiChar; Host: PAnsiChar; UserAgent: PAnsiChar; Cookie: PAnsiChar; Referrer: PAnsiChar; ServerPort: word; ProtocolStatus: word; Win32Status: ULONG; MethodNum: THttpVerb; SubStatus: word; end; PHTTP_LOG_FIELDS_DATA = ^HTTP_LOG_FIELDS_DATA; HTTP_BINDING_INFO = record Flags: HTTP_PROPERTY_FLAGS; RequestQueueHandle: THandle; end; HTTP_PROTECTION_LEVEL_TYPE=( HttpProtectionLevelUnrestricted, HttpProtectionLevelEdgeRestricted, HttpProtectionLevelRestricted ); HTTP_PROTECTION_LEVEL_INFO = record Flags: HTTP_PROPERTY_FLAGS; Level: HTTP_PROTECTION_LEVEL_TYPE; end; PHTTP_PROTECTION_LEVEL_INFO = ^HTTP_PROTECTION_LEVEL_INFO; const HTTP_VERSION_UNKNOWN: HTTP_VERSION = (MajorVersion: 0; MinorVersion: 0); HTTP_VERSION_0_9: HTTP_VERSION = (MajorVersion: 0; MinorVersion: 9); HTTP_VERSION_1_0: HTTP_VERSION = (MajorVersion: 1; MinorVersion: 0); HTTP_VERSION_1_1: HTTP_VERSION = (MajorVersion: 1; MinorVersion: 1); /// error raised by HTTP API when the client disconnected (e.g. after timeout) HTTPAPI_ERROR_NONEXISTENTCONNECTION = 1229; // if set, available entity body is copied along with the request headers // into pEntityChunks HTTP_RECEIVE_REQUEST_FLAG_COPY_BODY = 1; // there is more entity body to be read for this request HTTP_REQUEST_FLAG_MORE_ENTITY_BODY_EXISTS = 1; // initialization for applications that use the HTTP Server API HTTP_INITIALIZE_SERVER = 1; // initialization for applications that use the HTTP configuration functions HTTP_INITIALIZE_CONFIG = 2; // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa364496 HTTP_RECEIVE_REQUEST_ENTITY_BODY_FLAG_FILL_BUFFER = 1; // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa364499 HTTP_SEND_RESPONSE_FLAG_DISCONNECT = $00000001; HTTP_SEND_RESPONSE_FLAG_MORE_DATA = $00000002; HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA = $00000004; HTTP_SEND_RESPONSE_FLAG_PROCESS_RANGES = $00000020; HTTP_SEND_RESPONSE_FLAG_OPAQUE = $00000040; // flag which can be used by HttpRemoveUrlFromUrlGroup() HTTP_URL_FLAG_REMOVE_ALL = 1; HTTP_KNOWNHEADERS: array[low(THttpHeader)..reqUserAgent] of string[19] = ( 'Cache-Control','Connection','Date','Keep-Alive','Pragma','Trailer', 'Transfer-Encoding','Upgrade','Via','Warning','Allow','Content-Length', 'Content-Type','Content-Encoding','Content-Language','Content-Location', 'Content-MD5','Content-Range','Expires','Last-Modified','Accept', 'Accept-Charset','Accept-Encoding','Accept-Language','Authorization', 'Cookie','Expect','From','Host','If-Match','If-Modified-Since', 'If-None-Match','If-Range','If-Unmodified-Since','Max-Forwards', 'Proxy-Authorization','Referer','Range','TE','Translate','User-Agent'); REMOTEIP_HEADERLEN = 10; REMOTEIP_HEADER: string[REMOTEIP_HEADERLEN] = 'RemoteIP: '; function RetrieveHeaders(const Request: HTTP_REQUEST; const RemoteIPHeadUp: SockString; out RemoteIP: SockString): SockString; var i, L, Lip: integer; H: THttpHeader; P: PHTTP_UNKNOWN_HEADER; D: PAnsiChar; begin assert(low(HTTP_KNOWNHEADERS)=low(Request.Headers.KnownHeaders)); assert(high(HTTP_KNOWNHEADERS)=high(Request.Headers.KnownHeaders)); // compute remote IP L := length(RemoteIPHeadUp); if L<>0 then begin P := Request.Headers.pUnknownHeaders; if P<>nil then for i := 1 to Request.Headers.UnknownHeaderCount do if (P^.NameLength=L) and IdemPChar(P^.pName,Pointer(RemoteIPHeadUp)) then begin SetString(RemoteIP,p^.pRawValue,p^.RawValueLength); break; end else inc(P); end; if (RemoteIP='') and (Request.Address.pRemoteAddress<>nil) then IPText(PVarSin(Request.Address.pRemoteAddress)^,RemoteIP,RemoteIPLocalHostAsVoidInServers); // compute headers length Lip := length(RemoteIP); if Lip<>0 then L := (REMOTEIP_HEADERLEN+2)+Lip else L := 0; for H := low(HTTP_KNOWNHEADERS) to high(HTTP_KNOWNHEADERS) do if Request.Headers.KnownHeaders[h].RawValueLength<>0 then inc(L,Request.Headers.KnownHeaders[h].RawValueLength+ord(HTTP_KNOWNHEADERS[h][0])+4); P := Request.Headers.pUnknownHeaders; if P<>nil then for i := 1 to Request.Headers.UnknownHeaderCount do begin inc(L,P^.NameLength+P^.RawValueLength+4); // +4 for each ': '+#13#10 inc(P); end; // set headers content SetString(result,nil,L); D := pointer(result); for H := low(HTTP_KNOWNHEADERS) to high(HTTP_KNOWNHEADERS) do if Request.Headers.KnownHeaders[h].RawValueLength<>0 then begin move(HTTP_KNOWNHEADERS[h][1],D^,ord(HTTP_KNOWNHEADERS[h][0])); inc(D,ord(HTTP_KNOWNHEADERS[h][0])); PWord(D)^ := ord(':')+ord(' ')shl 8; inc(D,2); move(Request.Headers.KnownHeaders[h].pRawValue^,D^, Request.Headers.KnownHeaders[h].RawValueLength); inc(D,Request.Headers.KnownHeaders[h].RawValueLength); PWord(D)^ := 13+10 shl 8; inc(D,2); end; P := Request.Headers.pUnknownHeaders; if P<>nil then for i := 1 to Request.Headers.UnknownHeaderCount do begin move(P^.pName^,D^,P^.NameLength); inc(D,P^.NameLength); PWord(D)^ := ord(':')+ord(' ')shl 8; inc(D,2); move(P^.pRawValue^,D^,P^.RawValueLength); inc(D,P^.RawValueLength); inc(P); PWord(D)^ := 13+10 shl 8; inc(D,2); end; if Lip<>0 then begin move(REMOTEIP_HEADER[1],D^,REMOTEIP_HEADERLEN); inc(D,REMOTEIP_HEADERLEN); move(pointer(RemoteIP)^,D^,Lip); inc(D,Lip); PWord(D)^ := 13+10 shl 8; {$ifopt C+} inc(D,2); end; assert(D-pointer(result)=L); {$else} end; {$endif} end; type HTTP_SERVER_PROPERTY = ( HttpServerAuthenticationProperty, HttpServerLoggingProperty, HttpServerQosProperty, HttpServerTimeoutsProperty, HttpServerQueueLengthProperty, HttpServerStateProperty, HttpServer503VerbosityProperty, HttpServerBindingProperty, HttpServerExtendedAuthenticationProperty, HttpServerListenEndpointProperty, HttpServerChannelBindProperty, HttpServerProtectionLevelProperty ); /// direct late-binding access to the HTTP API server 1.0 or 2.0 THttpAPI = packed record /// access to the httpapi.dll loaded library Module: THandle; /// will be either 1.0 or 2.0, depending on the published .dll functions Version: HTTP_VERSION; /// The HttpInitialize function initializes the HTTP Server API driver, starts it, // if it has not already been started, and allocates data structures for the // calling application to support response-queue creation and other operations. // Call this function before calling any other functions in the HTTP Server API. Initialize: function(Version: HTTP_VERSION; Flags: cardinal; pReserved: pointer=nil): HRESULT; stdcall; /// The HttpTerminate function cleans up resources used by the HTTP Server API // to process calls by an application. An application should call HttpTerminate // once for every time it called HttpInitialize, with matching flag settings. Terminate: function(Flags: cardinal; Reserved: integer=0): HRESULT; stdcall; /// The HttpCreateHttpHandle function creates an HTTP request queue for the // calling application and returns a handle to it. CreateHttpHandle: function(var ReqQueueHandle: THandle; Reserved: integer=0): HRESULT; stdcall; /// The HttpAddUrl function registers a given URL so that requests that match // it are routed to a specified HTTP Server API request queue. An application // can register multiple URLs to a single request queue using repeated calls to // HttpAddUrl // - a typical url prefix is 'http://+:80/vroot/', 'https://+:80/vroot/' or // 'https://adatum.com:443/secure/database/' - here the '+' is called a // Strong wildcard, i.e. will match every IP or server name AddUrl: function(ReqQueueHandle: THandle; UrlPrefix: PWideChar; Reserved: integer=0): HRESULT; stdcall; /// Unregisters a specified URL, so that requests for it are no longer // routed to a specified queue. RemoveUrl: function(ReqQueueHandle: THandle; UrlPrefix: PWideChar): HRESULT; stdcall; /// retrieves the next available HTTP request from the specified request queue ReceiveHttpRequest: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; Flags: cardinal; var pRequestBuffer: HTTP_REQUEST; RequestBufferLength: ULONG; var pBytesReceived: ULONG; pOverlapped: pointer=nil): HRESULT; stdcall; /// sent the response to a specified HTTP request // - pLogData optional parameter is handled since HTTP API 2.0 SendHttpResponse: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; Flags: integer; var pHttpResponse: HTTP_RESPONSE; pReserved1: pointer; var pBytesSent: cardinal; pReserved2: pointer=nil; Reserved3: ULONG=0; pOverlapped: pointer=nil; pLogData: PHTTP_LOG_DATA=nil): HRESULT; stdcall; /// receives additional entity body data for a specified HTTP request ReceiveRequestEntityBody: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; Flags: ULONG; pBuffer: pointer; BufferLength: cardinal; var pBytesReceived: cardinal; pOverlapped: pointer=nil): HRESULT; stdcall; /// sends entity-body data associated with an HTTP response. SendResponseEntityBody: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; Flags: integer; EntityChunkCount: word; pEntityChunks: pointer; var pBytesSent: Cardinal; pReserved1: Pointer=nil; pReserved2: Pointer=nil; pOverlapped: POverlapped=nil; pLogData: PHTTP_LOG_DATA=nil): HRESULT; stdcall; /// set specified data, such as IP addresses or SSL Certificates, from the // HTTP Server API configuration store SetServiceConfiguration: function(ServiceHandle: THandle; ConfigId: THttpServiceConfigID; pConfigInformation: pointer; ConfigInformationLength: ULONG; pOverlapped: pointer=nil): HRESULT; stdcall; /// deletes specified data, such as IP addresses or SSL Certificates, from the // HTTP Server API configuration store DeleteServiceConfiguration: function(ServiceHandle: THandle; ConfigId: THttpServiceConfigID; pConfigInformation: pointer; ConfigInformationLength: ULONG; pOverlapped: pointer=nil): HRESULT; stdcall; /// removes from the HTTP Server API cache associated with a given request // queue all response fragments that have a name whose site portion matches // a specified UrlPrefix FlushResponseCache: function(ReqQueueHandle: THandle; pUrlPrefix: PWideChar; Flags: ULONG; pOverlapped: POverlapped): ULONG; stdcall; /// cancels a specified request // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) CancelHttpRequest: function(ReqQueueHandle: THandle; RequestId: HTTP_REQUEST_ID; pOverlapped: pointer = nil): HRESULT; stdcall; /// creates a server session for the specified HTTP API version // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) CreateServerSession: function(Version: HTTP_VERSION; var ServerSessionId: HTTP_SERVER_SESSION_ID; Reserved: ULONG = 0): HRESULT; stdcall; /// deletes the server session identified by the server session ID // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) CloseServerSession: function(ServerSessionId: HTTP_SERVER_SESSION_ID): HRESULT; stdcall; /// creates a new request queue or opens an existing request queue // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) // - replaces the HTTP version 1.0 CreateHttpHandle() function CreateRequestQueue: function(Version: HTTP_VERSION; pName: PWideChar; pSecurityAttributes: Pointer; Flags: ULONG; var ReqQueueHandle: THandle): HRESULT; stdcall; /// sets a new server session property or modifies an existing property // on the specified server session // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) SetServerSessionProperty: function(ServerSessionId: HTTP_SERVER_SESSION_ID; aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; PropertyInformationLength: ULONG): HRESULT; stdcall; /// queries a server property on the specified server session // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) QueryServerSessionProperty: function(ServerSessionId: HTTP_SERVER_SESSION_ID; aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; PropertyInformationLength: ULONG; pReturnLength: PULONG = nil): HRESULT; stdcall; /// creates a URL Group under the specified server session // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) CreateUrlGroup: function(ServerSessionId: HTTP_SERVER_SESSION_ID; var UrlGroupId: HTTP_URL_GROUP_ID; Reserved: ULONG = 0): HRESULT; stdcall; /// closes the URL Group identified by the URL Group ID // - this call also removes all of the URLs that are associated with // the URL Group // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) CloseUrlGroup: function(UrlGroupId: HTTP_URL_GROUP_ID): HRESULT; stdcall; /// adds the specified URL to the URL Group identified by the URL Group ID // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) // - this function replaces the HTTP version 1.0 AddUrl() function AddUrlToUrlGroup: function(UrlGroupId: HTTP_URL_GROUP_ID; pFullyQualifiedUrl: PWideChar; UrlContext: HTTP_URL_CONTEXT = 0; Reserved: ULONG = 0): HRESULT; stdcall; /// removes the specified URL from the group identified by the URL Group ID // - this function removes one, or all, of the URLs from the group // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) // - it replaces the HTTP version 1.0 RemoveUrl() function RemoveUrlFromUrlGroup: function(UrlGroupId: HTTP_URL_GROUP_ID; pFullyQualifiedUrl: PWideChar; Flags: ULONG): HRESULT; stdcall; /// sets a new property or modifies an existing property on the specified // URL Group // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) SetUrlGroupProperty: function(UrlGroupId: HTTP_URL_GROUP_ID; aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; PropertyInformationLength: ULONG): HRESULT; stdcall; /// queries a property on the specified URL Group // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) QueryUrlGroupProperty: function(UrlGroupId: HTTP_URL_GROUP_ID; aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; PropertyInformationLength: ULONG; pReturnLength: PULONG = nil): HRESULT; stdcall; /// sets a new property or modifies an existing property on the request // queue identified by the specified handle // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) SetRequestQueueProperty: function(ReqQueueHandle: THandle; aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; PropertyInformationLength: ULONG; Reserved: ULONG; pReserved: Pointer): HRESULT; stdcall; /// queries a property of the request queue identified by the // specified handle // - available only for HTTP API 2.0 (since Windows Vista / Server 2008) QueryRequestQueueProperty: function(ReqQueueHandle: THandle; aProperty: HTTP_SERVER_PROPERTY; pPropertyInformation: Pointer; PropertyInformationLength: ULONG; Reserved: ULONG; pReturnLength: PULONG; pReserved: Pointer): HRESULT; stdcall; end; var Http: THttpAPI; type THttpAPIs = (hInitialize,hTerminate,hCreateHttpHandle, hAddUrl, hRemoveUrl, hReceiveHttpRequest, hSendHttpResponse, hReceiveRequestEntityBody, hResponseEntityBody, hSetServiceConfiguration, hDeleteServiceConfiguration, hFlushResponseCache, hCancelHttpRequest, hCreateServerSession, hCloseServerSession, hCreateRequestQueue, hSetServerSessionProperty, hQueryServerSessionProperty, hCreateUrlGroup, hCloseUrlGroup, hAddUrlToUrlGroup, hRemoveUrlFromUrlGroup, hSetUrlGroupProperty, hQueryUrlGroupProperty, hSetRequestQueueProperty, hQueryRequestQueueProperty ); const hHttpApi2First = hCancelHttpRequest; HttpNames: array[THttpAPIs] of PChar = ( 'HttpInitialize','HttpTerminate','HttpCreateHttpHandle', 'HttpAddUrl', 'HttpRemoveUrl', 'HttpReceiveHttpRequest', 'HttpSendHttpResponse', 'HttpReceiveRequestEntityBody', 'HttpSendResponseEntityBody', 'HttpSetServiceConfiguration', 'HttpDeleteServiceConfiguration', 'HttpFlushResponseCache', 'HttpCancelHttpRequest', 'HttpCreateServerSession', 'HttpCloseServerSession', 'HttpCreateRequestQueue', 'HttpSetServerSessionProperty', 'HttpQueryServerSessionProperty', 'HttpCreateUrlGroup', 'HttpCloseUrlGroup', 'HttpAddUrlToUrlGroup', 'HttpRemoveUrlFromUrlGroup', 'HttpSetUrlGroupProperty', 'HttpQueryUrlGroupProperty', 'HttpSetRequestQueueProperty', 'HttpQueryRequestQueueProperty' ); function RegURL(aRoot, aPort: SockString; Https: boolean; aDomainName: SockString): SockUnicode; const Prefix: array[boolean] of SockString = ('http://','https://'); begin if aPort='' then aPort := DEFAULT_PORT[Https]; aRoot := trim(aRoot); aDomainName := trim(aDomainName); if aDomainName='' then begin result := ''; exit; end; if aRoot<>'' then begin if aRoot[1]<>'/' then insert('/',aRoot,1); if aRoot[length(aRoot)]<>'/' then aRoot := aRoot+'/'; end else aRoot := '/'; // allow for instance 'http://*:2869/' aRoot := Prefix[Https]+aDomainName+':'+aPort+aRoot; result := SockUnicode(aRoot); end; const HTTPAPI_DLL = 'httpapi.dll'; procedure HttpApiInitialize; var api: THttpAPIs; P: PPointer; begin if Http.Module<>0 then exit; // already loaded try Http.Module := LoadLibrary(HTTPAPI_DLL); Http.Version.MajorVersion := 2; // API 2.0 if all functions are available if Http.Module<=255 then raise ECrtSocket.CreateFmt('Unable to find %s',[HTTPAPI_DLL]); P := @@Http.Initialize; for api := low(api) to high(api) do begin P^ := GetProcAddress(Http.Module,HttpNames[api]); if P^=nil then if api255 then begin FreeLibrary(Http.Module); Http.Module := 0; end; raise; end; end; end; { EHttpApiServer } type EHttpApiServer = class(ECrtSocket) protected fLastApi: THttpAPIs; public class procedure RaiseOnError(api: THttpAPIs; Error: integer); constructor Create(api: THttpAPIs; Error: integer); reintroduce; published property LastApi: THttpAPIs read fLastApi; end; class procedure EHttpApiServer.RaiseOnError(api: THttpAPIs; Error: integer); begin if Error<>NO_ERROR then raise self.Create(api,Error); end; constructor EHttpApiServer.Create(api: THttpAPIs; Error: integer); begin fLastError := Error; fLastApi := api; inherited CreateFmt('%s failed: %s (%d)', [HttpNames[api],SysErrorMessagePerModule(Error,HTTPAPI_DLL),Error]) end; { THttpApiServer } function THttpApiServer.AddUrl(const aRoot, aPort: SockString; Https: boolean; const aDomainName: SockString; aRegisterURI: boolean; aContext: Int64): integer; var uri: SockUnicode; n: integer; begin result := -1; if (Self=nil) or (fReqQueue=0) or (Http.Module=0) then exit; uri := RegURL(aRoot, aPort, Https, aDomainName); if uri='' then exit; // invalid parameters if aRegisterURI then AddUrlAuthorize(aRoot,aPort,Https,aDomainName); if Http.Version.MajorVersion>1 then result := Http.AddUrlToUrlGroup(fUrlGroupID,pointer(uri),aContext) else result := Http.AddUrl(fReqQueue,pointer(uri)); if result=NO_ERROR then begin n := length(fRegisteredUnicodeUrl); SetLength(fRegisteredUnicodeUrl,n+1); fRegisteredUnicodeUrl[n] := uri; end; end; function THttpApiServer.RemoveUrl(const aRoot, aPort: SockString; Https: boolean; const aDomainName: SockString): integer; var uri: SockUnicode; i,j,n: integer; begin result := -1; if (Self=nil) or (fReqQueue=0) or (Http.Module=0) then exit; uri := RegURL(aRoot, aPort, Https, aDomainName); if uri='' then exit; // invalid parameters n := High(fRegisteredUnicodeUrl); for i := 0 to n do if fRegisteredUnicodeUrl[i]=uri then begin if Http.Version.MajorVersion>1 then result := Http.RemoveUrlFromUrlGroup(fUrlGroupID,pointer(uri),0) else result := Http.RemoveUrl(fReqQueue,pointer(uri)); if result<>0 then exit; // shall be handled by caller for j := i to n-1 do fRegisteredUnicodeUrl[j] := fRegisteredUnicodeUrl[j+1]; SetLength(fRegisteredUnicodeUrl,n); exit; end; end; class function THttpApiServer.AddUrlAuthorize(const aRoot, aPort: SockString; Https: boolean; const aDomainName: SockString; OnlyDelete: boolean): string; const /// will allow AddUrl() registration to everyone // - 'GA' (GENERIC_ALL) to grant all access // - 'S-1-1-0' defines a group that includes all users HTTPADDURLSECDESC: PWideChar = 'D:(A;;GA;;;S-1-1-0)'; var prefix: SockUnicode; Error: HRESULT; Config: HTTP_SERVICE_CONFIG_URLACL_SET; begin try HttpApiInitialize; prefix := RegURL(aRoot, aPort, Https, aDomainName); if prefix='' then result := 'Invalid parameters' else begin EHttpApiServer.RaiseOnError(hInitialize,Http.Initialize( Http.Version,HTTP_INITIALIZE_CONFIG)); try fillchar(Config,sizeof(Config),0); Config.KeyDesc.pUrlPrefix := pointer(prefix); // first delete any existing information Error := Http.DeleteServiceConfiguration(0,hscUrlAclInfo,@Config,Sizeof(Config)); // then add authorization rule if not OnlyDelete then begin Config.KeyDesc.pUrlPrefix := pointer(prefix); Config.ParamDesc.pStringSecurityDescriptor := HTTPADDURLSECDESC; Error := Http.SetServiceConfiguration(0,hscUrlAclInfo,@Config,Sizeof(Config)); end; if (Error<>NO_ERROR) and (Error<>ERROR_ALREADY_EXISTS) then raise EHttpApiServer.Create(hSetServiceConfiguration,Error); result := ''; // success finally Http.Terminate(HTTP_INITIALIZE_CONFIG); end; end; except on E: Exception do result := E.Message; end; end; type THttpApiServerClass = class of THttpApiServer; procedure THttpApiServer.Clone(ChildThreadCount: integer); var i: integer; begin if (fReqQueue=0) or not Assigned(OnRequest) or (ChildThreadCount<=0) or (fClones<>nil) then exit; // nothing to clone (need a queue and a process event) if ChildThreadCount>256 then ChildThreadCount := 256; // not worth adding SetLength(fClones,ChildThreadCount); for i := 0 to ChildThreadCount-1 do fClones[i] := THttpApiServerClass(Self.ClassType).CreateClone(self); end; function THttpApiServer.GetAPIVersion: string; begin result := Format('HTTP API %d.%d',[Http.Version.MajorVersion,Http.Version.MinorVersion]); end; constructor THttpApiServer.Create(CreateSuspended: boolean; QueueName: SockUnicode; OnStart,OnStop: TNotifyThreadEvent; const ProcessName: SockString); var bindInfo: HTTP_BINDING_INFO; begin SetLength(fLogDataStorage,sizeof(HTTP_LOG_FIELDS_DATA)); // should be done 1st inherited Create({suspended=}true,OnStart,OnStop,ProcessName); HttpApiInitialize; // will raise an exception in case of failure EHttpApiServer.RaiseOnError(hInitialize, Http.Initialize(Http.Version,HTTP_INITIALIZE_SERVER)); if Http.Version.MajorVersion>1 then begin EHttpApiServer.RaiseOnError(hCreateServerSession,Http.CreateServerSession( Http.Version,fServerSessionID)); EHttpApiServer.RaiseOnError(hCreateUrlGroup,Http.CreateUrlGroup( fServerSessionID,fUrlGroupID)); if QueueName='' then BinToHexDisplayW(@fServerSessionID,SizeOf(fServerSessionID),QueueName); EHttpApiServer.RaiseOnError(hCreateRequestQueue,Http.CreateRequestQueue( Http.Version,pointer(QueueName),nil,0,fReqQueue)); bindInfo.Flags := 1; bindInfo.RequestQueueHandle := FReqQueue; EHttpApiServer.RaiseOnError(hSetUrlGroupProperty,Http.SetUrlGroupProperty( fUrlGroupID,HttpServerBindingProperty,@bindInfo,SizeOf(bindInfo))); end else EHttpApiServer.RaiseOnError(hCreateHttpHandle,Http.CreateHttpHandle(fReqQueue)); fReceiveBufferSize := 1048576; // i.e. 1 MB if not CreateSuspended then Suspended := False; end; constructor THttpApiServer.CreateClone(From: THttpApiServer); begin SetLength(fLogDataStorage,sizeof(HTTP_LOG_FIELDS_DATA)); fOwner := From; fReqQueue := From.fReqQueue; fOnRequest := From.fOnRequest; fOnBeforeBody := From.fOnBeforeBody; fOnBeforeRequest := From.fOnBeforeRequest; fOnAfterRequest := From.fOnAfterRequest; fCanNotifyCallback := From.fCanNotifyCallback; fCompress := From.fCompress; fCompressAcceptEncoding := From.fCompressAcceptEncoding; fReceiveBufferSize := From.fReceiveBufferSize; if From.fLogData<>nil then fLogData := pointer(fLogDataStorage); SetServerName(From.fServerName); SetRemoteIPHeader(From.RemoteIPHeader); SetRemoteConnIDHeader(From.RemoteConnIDHeader); fLoggingServiceName := From.fLoggingServiceName; inherited Create(false,From.fOnHttpThreadStart,From.fOnThreadTerminate,From.ProcessName); end; procedure THttpApiServer.DestroyMainThread; var i: PtrInt; begin if fReqQueue<>0 then begin for i := 0 to length(fClones)-1 do fClones[i].Terminate; // for CloseHandle() below to finish Execute if Http.Version.MajorVersion>1 then begin if fUrlGroupID<>0 then begin Http.RemoveUrlFromUrlGroup(fUrlGroupID,nil,HTTP_URL_FLAG_REMOVE_ALL); Http.CloseUrlGroup(fUrlGroupID); fUrlGroupID := 0; end; CloseHandle(fReqQueue); if fServerSessionID<>0 then begin Http.CloseServerSession(fServerSessionID); fServerSessionID := 0; end; end else begin for i := 0 to high(fRegisteredUnicodeUrl) do Http.RemoveUrl(fReqQueue,pointer(fRegisteredUnicodeUrl[i])); CloseHandle(fReqQueue); // will break all THttpApiServer.Execute end; fReqQueue := 0; {$ifdef FPC} for i := 0 to length(fClones)-1 do WaitForSingleObject(fClones[i].Handle,30000); // sometimes needed on FPC {$endif FPC} for i := 0 to length(fClones)-1 do fClones[i].Free; fClones := nil; Http.Terminate(HTTP_INITIALIZE_SERVER); end; end; destructor THttpApiServer.Destroy; begin Terminate; // for Execute to be notified about end of process try if (fOwner=nil) and (Http.Module<>0) then // fOwner<>nil for cloned threads DestroyMainThread; {$ifdef FPC} WaitForSingleObject(Handle,30000); // wait the main Execute method on FPC {$endif FPC} finally inherited Destroy; end; end; procedure GetDomainUserNameFromToken(UserToken: THandle; var result: SockString); var Buffer: array[0..511] of byte; BufferSize, UserSize, DomainSize: DWORD; UserInfo: PSIDAndAttributes; NameUse: {$ifdef FPC}SID_NAME_USE{$else}Cardinal{$endif}; tmp: SockUnicode; P: PWideChar; begin if not GetTokenInformation(UserToken,TokenUser,@Buffer,SizeOf(Buffer),BufferSize) then exit; UserInfo := @Buffer; UserSize := 0; DomainSize := 0; LookupAccountSidW(nil,UserInfo^.Sid,nil,UserSize,nil,DomainSize,NameUse); if (UserSize=0) or (DomainSize=0) then exit; SetLength(tmp,UserSize+DomainSize-1); P := pointer(tmp); if not LookupAccountSidW(nil,UserInfo^.Sid,P+DomainSize,UserSize,P,DomainSize,NameUse) then exit; P[DomainSize] := '\'; result := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(tmp); end; function THttpApiServer.GetSendResponseFlags(Ctxt: THttpServerRequest): Integer; begin result := 0; end; procedure THttpApiServer.Execute; type TVerbText = array[hvOPTIONS..pred(hvMaximum)] of SockString; const VERB_TEXT: TVerbText = ( 'OPTIONS','GET','HEAD','POST','PUT','DELETE','TRACE','CONNECT','TRACK', 'MOVE','COPY','PROPFIND','PROPPATCH','MKCOL','LOCK','UNLOCK','SEARCH'); var Req: PHTTP_REQUEST; ReqID: HTTP_REQUEST_ID; ReqBuf, RespBuf, RemoteIP, RemoteConn: SockString; ContentRange: shortstring; i, L: integer; P: PHTTP_UNKNOWN_HEADER; flags, bytesRead, bytesSent: cardinal; Err: HRESULT; InCompressAccept: THttpSocketCompressSet; InContentLength, InContentLengthChunk, InContentLengthRead: cardinal; InContentEncoding, InAcceptEncoding, Range: SockString; OutContentEncoding, OutStatus: SockString; OutStatusCode, AfterStatusCode: Cardinal; RespSent: boolean; Context: THttpServerRequest; FileHandle: THandle; Resp: PHTTP_RESPONSE; BufRead, R: PAnsiChar; Heads: HTTP_UNKNOWN_HEADERs; RangeStart, RangeLength: ULONGLONG; OutContentLength: ULARGE_INTEGER; DataChunkInMemory: HTTP_DATA_CHUNK_INMEMORY; DataChunkFile: HTTP_DATA_CHUNK_FILEHANDLE; CurrentLog: PHTTP_LOG_FIELDS_DATA; Verbs: TVerbText; // to avoid memory allocation procedure SendError(StatusCode: cardinal; const ErrorMsg: string; E: Exception=nil); var Msg: string; begin try Resp^.SetStatus(StatusCode,OutStatus); CurrentLog^.ProtocolStatus := StatusCode; Msg := format( '

Server Error %d: %s

', [StatusCode,OutStatus]); if E<>nil then Msg := Msg+string(E.ClassName)+' Exception raised:
'; Resp^.SetContent(DataChunkInMemory,UTF8String(Msg)+HtmlEncode( {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(ErrorMsg)) {$ifndef NOXPOWEREDNAME}+'

'+XPOWEREDVALUE{$endif}, 'text/html; charset=utf-8'); Http.SendHttpResponse(fReqQueue, Req^.RequestId,0,Resp^,nil,bytesSent,nil,0,nil,fLogData); except on Exception do ; // ignore any HttpApi level errors here (client may crashed) end; end; function SendResponse: boolean; begin result := not Terminated; // true=success if not result then exit; RespSent := true; Resp^.SetStatus(OutStatusCode,OutStatus); if Terminated then exit; // update log information if Http.Version.MajorVersion>=2 then with Req^,CurrentLog^ do begin MethodNum := Verb; UriStemLength := CookedUrl.AbsPathLength; UriStem := CookedUrl.pAbsPath; with Headers.KnownHeaders[reqUserAgent] do begin UserAgentLength := RawValueLength; UserAgent := pRawValue; end; with Headers.KnownHeaders[reqHost] do begin HostLength := RawValueLength; Host := pRawValue; end; with Headers.KnownHeaders[reqReferrer] do begin ReferrerLength := RawValueLength; Referrer := pRawValue; end; ProtocolStatus := Resp^.StatusCode; ClientIp := pointer(RemoteIP); ClientIpLength := length(RemoteIP); Method := pointer(Context.fMethod); MethodLength := length(Context.fMethod); UserName := pointer(Context.fAuthenticatedUser); UserNameLength := Length(Context.fAuthenticatedUser); end; // send response Resp^.Version := Req^.Version; Resp^.SetHeaders(pointer(Context.OutCustomHeaders),Heads); if fCompressAcceptEncoding<>'' then Resp^.AddCustomHeader(pointer(fCompressAcceptEncoding),Heads,false); with Resp^.Headers.KnownHeaders[respServer] do begin pRawValue := pointer(fServerName); RawValueLength := length(fServerName); end; if Context.OutContentType=HTTP_RESP_STATICFILE then begin // response is file -> OutContent is UTF-8 file name to be served FileHandle := FileOpen( {$ifdef UNICODE}UTF8ToUnicodeString{$else}Utf8ToAnsi{$endif}(Context.OutContent), fmOpenRead or fmShareDenyNone); if PtrInt(FileHandle)<0 then begin SendError(STATUS_NOTFOUND,SysErrorMessage(GetLastError)); result := false; // notify fatal error end; try // http.sys will serve then close the file from kernel DataChunkFile.DataChunkType := hctFromFileHandle; DataChunkFile.FileHandle := FileHandle; flags := 0; DataChunkFile.ByteRange.StartingOffset.QuadPart := 0; Int64(DataChunkFile.ByteRange.Length.QuadPart) := -1; // to eof with Req^.Headers.KnownHeaders[reqRange] do begin if (RawValueLength>6) and IdemPChar(pRawValue,'BYTES=') and (pRawValue[6] in ['0'..'9']) then begin SetString(Range,pRawValue+6,RawValueLength-6); // need #0 end R := pointer(Range); RangeStart := GetNextItemUInt64(R); if R^='-' then begin OutContentLength.LowPart := GetFileSize(FileHandle,@OutContentLength.HighPart); DataChunkFile.ByteRange.Length.QuadPart := OutContentLength.QuadPart-RangeStart; inc(R); flags := HTTP_SEND_RESPONSE_FLAG_PROCESS_RANGES; DataChunkFile.ByteRange.StartingOffset.QuadPart := RangeStart; if R^ in ['0'..'9'] then begin RangeLength := GetNextItemUInt64(R)-RangeStart+1; if RangeLength start=0, len=500 DataChunkFile.ByteRange.Length.QuadPart := RangeLength; end; // "bytes=1000-" -> start=1000, to eof) ContentRange := 'Content-Range: bytes '; AppendI64(RangeStart,ContentRange); AppendChar('-',ContentRange); AppendI64(RangeStart+DataChunkFile.ByteRange.Length.QuadPart-1,ContentRange); AppendChar('/',ContentRange); AppendI64(OutContentLength.QuadPart,ContentRange); AppendChar(#0,ContentRange); Resp^.AddCustomHeader(@ContentRange[1],Heads,false); Resp^.SetStatus(STATUS_PARTIALCONTENT,OutStatus); end; end; with Resp^.Headers.KnownHeaders[respAcceptRanges] do begin pRawValue := 'bytes'; RawValueLength := 5; end; end; Resp^.EntityChunkCount := 1; Resp^.pEntityChunks := @DataChunkFile; Http.SendHttpResponse(fReqQueue, Req^.RequestId,flags,Resp^,nil,bytesSent,nil,0,nil,fLogData); finally FileClose(FileHandle); end; end else begin // response is in OutContent -> send it from memory if Context.OutContentType=HTTP_RESP_NORESPONSE then Context.OutContentType := ''; // true HTTP always expects a response if fCompress<>nil then begin with Resp^.Headers.KnownHeaders[reqContentEncoding] do if RawValueLength=0 then begin // no previous encoding -> try if any compression OutContentEncoding := CompressDataAndGetHeaders(InCompressAccept, fCompress,Context.OutContentType,Context.fOutContent); pRawValue := pointer(OutContentEncoding); RawValueLength := length(OutContentEncoding); end; end; Resp^.SetContent(DataChunkInMemory,Context.OutContent,Context.OutContentType); EHttpApiServer.RaiseOnError(hSendHttpResponse,Http.SendHttpResponse( fReqQueue,Req^.RequestId,getSendResponseFlags(Context), Resp^,nil,bytesSent,nil,0,nil,fLogData)); end; end; begin if Terminated then exit; Context := nil; try // THttpServerGeneric thread preparation: launch any OnHttpThreadStart event NotifyThreadStart(self); // reserve working buffers SetLength(Heads,64); SetLength(RespBuf,sizeof(Resp^)); Resp := pointer(RespBuf); SetLength(ReqBuf,16384+sizeof(HTTP_REQUEST)); // space for Req^ + 16 KB of headers Req := pointer(ReqBuf); CurrentLog := pointer(fLogDataStorage); Verbs := VERB_TEXT; Context := THttpServerRequest.Create(self,0,self); // main loop reusing a single Context instance for this thread ReqID := 0; Context.fServer := self; repeat Context.fInContent := ''; // release input/output body buffers ASAP Context.fOutContent := ''; // Reset AuthenticationStatus & user between requests Context.fAuthenticationStatus := hraNone; Context.fAuthenticatedUser := ''; // retrieve next pending request, and read its headers fillchar(Req^,sizeof(HTTP_REQUEST),0); Err := Http.ReceiveHttpRequest(fReqQueue,ReqID,0,Req^,length(ReqBuf),bytesRead); if Terminated then break; case Err of NO_ERROR: try // parse method and headers Context.fConnectionID := Req^.ConnectionId; Context.fHttpApiRequest := Req; SetString(Context.fFullURL,Req^.CookedUrl.pFullUrl,Req^.CookedUrl.FullUrlLength); SetString(Context.fURL,Req^.pRawUrl,Req^.RawUrlLength); if Req^.Verb in [low(Verbs)..high(Verbs)] then Context.fMethod := Verbs[Req^.Verb] else SetString(Context.fMethod,Req^.pUnknownVerb,Req^.UnknownVerbLength); with Req^.Headers.KnownHeaders[reqContentType] do SetString(Context.fInContentType,pRawValue,RawValueLength); with Req^.Headers.KnownHeaders[reqAcceptEncoding] do SetString(InAcceptEncoding,pRawValue,RawValueLength); InCompressAccept := ComputeContentEncoding(fCompress,pointer(InAcceptEncoding)); Context.fUseSSL := Req^.pSslInfo<>nil; Context.fInHeaders := RetrieveHeaders(Req^,fRemoteIPHeaderUpper,RemoteIP); // compute remote connection ID L := length(fRemoteConnIDHeaderUpper); if L<>0 then begin P := Req^.Headers.pUnknownHeaders; if P<>nil then for i := 1 to Req^.Headers.UnknownHeaderCount do if (P^.NameLength=L) and IdemPChar(P^.pName,Pointer(fRemoteConnIDHeaderUpper)) then begin SetString(RemoteConn,p^.pRawValue,p^.RawValueLength); // need #0 end R := pointer(RemoteConn); Context.fConnectionID := GetNextItemUInt64(R); break; end else inc(P); end; // retrieve any SetAuthenticationSchemes() information if byte(fAuthenticationSchemes)<>0 then // set only with HTTP API 2.0 for i := 0 to Req^.RequestInfoCount-1 do if Req^.pRequestInfo^[i].InfoType=HttpRequestInfoTypeAuth then with PHTTP_REQUEST_AUTH_INFO(Req^.pRequestInfo^[i].pInfo)^ do case AuthStatus of HttpAuthStatusSuccess: if AuthType>HttpRequestAuthTypeNone then begin byte(Context.fAuthenticationStatus) := ord(AuthType)+1; if AccessToken<>0 then begin GetDomainUserNameFromToken(AccessToken,Context.fAuthenticatedUser); // Per spec https://docs.microsoft.com/en-us/windows/win32/http/authentication-in-http-version-2-0 // AccessToken lifecycle is application responsability and should be closed after use CloseHandle(AccessToken); end; end; HttpAuthStatusFailure: Context.fAuthenticationStatus := hraFailed; end; with Req^.Headers.KnownHeaders[reqContentLength] do InContentLength := GetCardinal(pRawValue,pRawValue+RawValueLength); if (InContentLength>0) and (MaximumAllowedContentLength>0) and (InContentLength>MaximumAllowedContentLength) then begin SendError(STATUS_PAYLOADTOOLARGE,'Rejected'); continue; end; if Assigned(OnBeforeBody) then begin Err := OnBeforeBody(Context.URL,Context.Method,Context.InHeaders, Context.InContentType,RemoteIP,InContentLength,Context.fUseSSL); if Err<>STATUS_SUCCESS then begin SendError(Err,'Rejected'); continue; end; end; // retrieve body if HTTP_REQUEST_FLAG_MORE_ENTITY_BODY_EXISTS and Req^.Flags<>0 then begin with Req^.Headers.KnownHeaders[reqContentEncoding] do SetString(InContentEncoding,pRawValue,RawValueLength); if InContentLength<>0 then begin SetLength(Context.fInContent,InContentLength); BufRead := pointer(Context.InContent); InContentLengthRead := 0; repeat BytesRead := 0; if Http.Version.MajorVersion>1 then // speed optimization for Vista+ flags := HTTP_RECEIVE_REQUEST_ENTITY_BODY_FLAG_FILL_BUFFER else flags := 0; InContentLengthChunk := InContentLength-InContentLengthRead; if (fReceiveBufferSize>=1024) and (InContentLengthChunk>fReceiveBufferSize) then InContentLengthChunk := fReceiveBufferSize; Err := Http.ReceiveRequestEntityBody(fReqQueue,Req^.RequestId,flags, BufRead,InContentLengthChunk,BytesRead); if Terminated then exit; inc(InContentLengthRead,BytesRead); if Err=ERROR_HANDLE_EOF then begin if InContentLengthReadNO_ERROR then break; inc(BufRead,BytesRead); until InContentLengthRead=InContentLength; if Err<>NO_ERROR then begin SendError(STATUS_NOTACCEPTABLE,SysErrorMessagePerModule(Err,HTTPAPI_DLL)); continue; end; if InContentEncoding<>'' then for i := 0 to high(fCompress) do if fCompress[i].Name=InContentEncoding then begin fCompress[i].Func(Context.fInContent,false); // uncompress break; end; end; end; try // compute response Context.OutContent := ''; Context.OutContentType := ''; Context.OutCustomHeaders := ''; fillchar(Resp^,sizeof(Resp^),0); RespSent := false; OutStatusCode := DoBeforeRequest(Context); if OutStatusCode>0 then if not SendResponse or (OutStatusCode<>STATUS_ACCEPTED) then continue; OutStatusCode := Request(Context); AfterStatusCode := DoAfterRequest(Context); if AfterStatusCode>0 then OutStatusCode := AfterStatusCode; // send response if not RespSent then if not SendResponse then continue; DoAfterResponse(Context, OutStatusCode); except on E: Exception do // handle any exception raised during process: show must go on! if not RespSent then if not E.InheritsFrom(EHttpApiServer) or // ensure still connected (EHttpApiServer(E).LastError<>HTTPAPI_ERROR_NONEXISTENTCONNECTION) then SendError(STATUS_SERVERERROR,E.Message,E); end; finally ReqId := 0; // reset Request ID to handle the next pending request end; ERROR_MORE_DATA: begin // input buffer was too small to hold the request headers // -> increase buffer size and call the API again ReqID := Req^.RequestId; SetLength(ReqBuf,bytesRead); Req := pointer(ReqBuf); end; ERROR_CONNECTION_INVALID: if ReqID=0 then break else // TCP connection was corrupted by the peer -> ignore + next request ReqID := 0; else break; // unhandled Err value end; until Terminated; finally Context.Free; end; end; function THttpApiServer.GetHTTPQueueLength: Cardinal; var returnLength: ULONG; begin if (Http.Version.MajorVersion<2) or (self=nil) then result := 0 else begin if fOwner<>nil then self := fOwner; if fReqQueue=0 then result := 0 else EHttpApiServer.RaiseOnError(hQueryRequestQueueProperty, Http.QueryRequestQueueProperty(fReqQueue,HttpServerQueueLengthProperty, @Result, sizeof(Result), 0, @returnLength, nil)); end; end; procedure THttpApiServer.SetHTTPQueueLength(aValue: Cardinal); begin if Http.Version.MajorVersion<2 then raise EHttpApiServer.Create(hSetRequestQueueProperty, ERROR_OLD_WIN_VERSION); if (self<>nil) and (fReqQueue<>0) then EHttpApiServer.RaiseOnError(hSetRequestQueueProperty, Http.SetRequestQueueProperty(fReqQueue,HttpServerQueueLengthProperty, @aValue, sizeof(aValue), 0, nil)); end; function THttpApiServer.GetRegisteredUrl: SockUnicode; var i: integer; begin if fRegisteredUnicodeUrl=nil then result := '' else result := fRegisteredUnicodeUrl[0]; for i := 1 to high(fRegisteredUnicodeUrl) do result := result+','+fRegisteredUnicodeUrl[i]; end; function THttpApiServer.GetCloned: boolean; begin result := (fOwner<>nil); end; procedure THttpApiServer.SetMaxBandwidth(aValue: Cardinal); var qosInfo: HTTP_QOS_SETTING_INFO; limitInfo: HTTP_BANDWIDTH_LIMIT_INFO; begin if Http.Version.MajorVersion<2 then raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); if (self<>nil) and (fUrlGroupID<>0) then begin if AValue=0 then limitInfo.MaxBandwidth := HTTP_LIMIT_INFINITE else if AValuenil then self := fOwner; if fUrlGroupID=0 then begin result := 0; exit; end; qosInfoGet.qosInfo.QosType := HttpQosSettingTypeBandwidth; qosInfoGet.qosInfo.QosSetting := @qosInfoGet.limitInfo; EHttpApiServer.RaiseOnError(hQueryUrlGroupProperty, Http.QueryUrlGroupProperty(fUrlGroupID, HttpServerQosProperty, @qosInfoGet, SizeOf(qosInfoGet))); Result := qosInfoGet.limitInfo.MaxBandwidth; end; function THttpApiServer.GetMaxConnections: Cardinal; var qosInfoGet: record qosInfo: HTTP_QOS_SETTING_INFO; limitInfo: HTTP_CONNECTION_LIMIT_INFO; end; returnLength: ULONG; begin if (Http.Version.MajorVersion<2) or (self=nil) then begin result := 0; exit; end; if fOwner<>nil then self := fOwner; if fUrlGroupID=0 then begin result := 0; exit; end; qosInfoGet.qosInfo.QosType := HttpQosSettingTypeConnectionLimit; qosInfoGet.qosInfo.QosSetting := @qosInfoGet.limitInfo; EHttpApiServer.RaiseOnError(hQueryUrlGroupProperty, Http.QueryUrlGroupProperty(fUrlGroupID, HttpServerQosProperty, @qosInfoGet, SizeOf(qosInfoGet), @returnLength)); Result := qosInfoGet.limitInfo.MaxConnections; end; procedure THttpApiServer.SetMaxConnections(aValue: Cardinal); var qosInfo: HTTP_QOS_SETTING_INFO; limitInfo: HTTP_CONNECTION_LIMIT_INFO; begin if Http.Version.MajorVersion<2 then raise EHttpApiServer.Create(hSetUrlGroupProperty, ERROR_OLD_WIN_VERSION); if (self<>nil) and (fUrlGroupID<>0) then begin if AValue = 0 then limitInfo.MaxConnections := HTTP_LIMIT_INFINITE else limitInfo.MaxConnections := aValue; limitInfo.Flags := 1; qosInfo.QosType := HttpQosSettingTypeConnectionLimit; qosInfo.QosSetting := @limitInfo; EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, Http.SetUrlGroupProperty(fUrlGroupID, HttpServerQosProperty, @qosInfo, SizeOf(qosInfo))); end; end; function THttpApiServer.HasAPI2: boolean; begin result := Http.Version.MajorVersion>=2; end; function THttpApiServer.GetLogging: boolean; begin result := (fLogData<>nil); end; procedure THttpApiServer.LogStart(const aLogFolder: TFileName; aType: THttpApiLoggingType; const aSoftwareName: TFileName; aRolloverType: THttpApiLoggingRollOver; aRolloverSize: cardinal; aLogFields: THttpApiLogFields; aFlags: THttpApiLoggingFlags); var logInfo : HTTP_LOGGING_INFO; folder,software: SockUnicode; begin if (self=nil) or (fOwner<>nil) then exit; if Http.Version.MajorVersion<2 then raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); fLogData := nil; // disable any previous logging fillchar(logInfo,SizeOf(logInfo),0); logInfo.Flags := 1; logInfo.LoggingFlags := byte(aFlags); if aLogFolder='' then raise EHttpApiServer.CreateFmt('LogStart(aLogFolder="")',[]); if length(aLogFolder)>212 then // http://msdn.microsoft.com/en-us/library/windows/desktop/aa364532 raise EHttpApiServer.CreateFmt('aLogFolder is too long for LogStart(%s)',[aLogFolder]); folder := SockUnicode(aLogFolder); software := SockUnicode(aSoftwareName); logInfo.SoftwareNameLength := length(software)*2; logInfo.SoftwareName := pointer(software); logInfo.DirectoryNameLength := length(folder)*2; logInfo.DirectoryName := pointer(folder); logInfo.Format := HTTP_LOGGING_TYPE(aType); if aType=hltNCSA then aLogFields := [hlfDate..hlfSubStatus]; logInfo.Fields := integer(aLogFields); logInfo.RolloverType := HTTP_LOGGING_ROLLOVER_TYPE(aRolloverType); if aRolloverType=hlrSize then logInfo.RolloverSize := aRolloverSize; EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, Http.SetUrlGroupProperty(fUrlGroupID, HttpServerLoggingProperty, @logInfo, SizeOf(logInfo))); // on success, update the actual log memory structure fLogData := pointer(fLogDataStorage); end; procedure THttpApiServer.RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer=1024); var i: integer; begin inherited; for i := 0 to length(fClones)-1 do fClones[i].RegisterCompress(aFunction,aCompressMinSize); end; procedure THttpApiServer.SetOnTerminate(const Event: TNotifyThreadEvent); var i: integer; begin inherited SetOnTerminate(Event); if fOwner=nil then for i := 0 to length(fClones)-1 do fClones[i].OnHttpThreadTerminate := Event; end; procedure THttpApiServer.LogStop; var i: integer; begin if (self=nil) or (fClones=nil) or (fLogData=nil) then exit; fLogData := nil; for i := 0 to length(fClones)-1 do fClones[i].fLogData := nil; end; procedure THttpApiServer.SetReceiveBufferSize(Value: cardinal); var i: integer; begin fReceiveBufferSize := Value; for i := 0 to length(fClones)-1 do fClones[i].fReceiveBufferSize := Value; end; procedure THttpApiServer.SetServerName(const aName: SockString); var i: integer; begin inherited SetServerName(aName); with PHTTP_LOG_FIELDS_DATA(fLogDataStorage)^ do begin ServerName := pointer(aName); ServerNameLength := Length(aName); end; for i := 0 to length(fClones)-1 do fClones[i].SetServerName(aName); end; procedure THttpApiServer.SetOnRequest(const aRequest: TOnHttpServerRequest); var i: integer; begin inherited SetOnRequest(aRequest); for i := 0 to length(fClones)-1 do fClones[i].SetOnRequest(aRequest); end; procedure THttpApiServer.SetOnBeforeBody(const aEvent: TOnHttpServerBeforeBody); var i: integer; begin inherited SetOnBeforeBody(aEvent); for i := 0 to length(fClones)-1 do fClones[i].SetOnBeforeBody(aEvent); end; procedure THttpApiServer.SetOnBeforeRequest(const aEvent: TOnHttpServerRequest); var i: integer; begin inherited SetOnBeforeRequest(aEvent); for i := 0 to length(fClones)-1 do fClones[i].SetOnBeforeRequest(aEvent); end; procedure THttpApiServer.SetOnAfterRequest(const aEvent: TOnHttpServerRequest); var i: integer; begin inherited SetOnAfterRequest(aEvent); for i := 0 to length(fClones)-1 do fClones[i].SetOnAfterRequest(aEvent); end; procedure THttpApiServer.SetOnAfterResponse(const aEvent: TOnHttpServerAfterResponse); var i: integer; begin inherited SetOnAfterResponse(aEvent); for i := 0 to length(fClones)-1 do fClones[i].SetOnAfterResponse(aEvent); end; procedure THttpApiServer.SetMaximumAllowedContentLength(aMax: cardinal); var i: integer; begin inherited SetMaximumAllowedContentLength(aMax); for i := 0 to length(fClones)-1 do fClones[i].SetMaximumAllowedContentLength(aMax); end; procedure THttpApiServer.SetRemoteIPHeader(const aHeader: SockString); var i: integer; begin inherited SetRemoteIPHeader(aHeader); for i := 0 to length(fClones)-1 do fClones[i].SetRemoteIPHeader(aHeader); end; procedure THttpApiServer.SetRemoteConnIDHeader(const aHeader: SockString); var i: integer; begin inherited SetRemoteConnIDHeader(aHeader); for i := 0 to length(fClones)-1 do fClones[i].SetRemoteConnIDHeader(aHeader); end; procedure THttpApiServer.SetLoggingServiceName(const aName: SockString); begin if self=nil then exit; fLoggingServiceName := aName; PHTTP_LOG_FIELDS_DATA(fLogDataStorage)^.ServiceNameLength := Length(fLoggingServiceName); PHTTP_LOG_FIELDS_DATA(fLogDataStorage)^.ServiceName := pointer(fLoggingServiceName); end; procedure THttpApiServer.SetAuthenticationSchemes(schemes: THttpApiRequestAuthentications; const DomainName, Realm: SockUnicode); var authInfo: HTTP_SERVER_AUTHENTICATION_INFO; begin if (self=nil) or (fOwner<>nil) then exit; if Http.Version.MajorVersion<2 then raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); fAuthenticationSchemes := schemes; FillChar(authInfo,SizeOf(authInfo),0); authInfo.Flags := 1; authInfo.AuthSchemes := byte(schemes); authInfo.ReceiveMutualAuth := true; if haBasic in schemes then with authInfo.BasicParams do begin RealmLength := Length(Realm); Realm := pointer(Realm); end; if haDigest in schemes then with authInfo.DigestParams do begin DomainNameLength := Length(DomainName); DomainName := pointer(DomainName); RealmLength := Length(Realm); Realm := pointer(Realm); end; EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, Http.SetUrlGroupProperty(fUrlGroupID, HttpServerAuthenticationProperty, @authInfo, SizeOf(authInfo))); end; procedure THttpApiServer.SetTimeOutLimits(aEntityBody, aDrainEntityBody, aRequestQueue, aIdleConnection, aHeaderWait, aMinSendRate: cardinal); var timeoutInfo: HTTP_TIMEOUT_LIMIT_INFO; begin if (self=nil) or (fOwner<>nil) then exit; if Http.Version.MajorVersion<2 then raise EHttpApiServer.Create(hSetUrlGroupProperty,ERROR_OLD_WIN_VERSION); FillChar(timeOutInfo,SizeOf(timeOutInfo),0); timeoutInfo.Flags := 1; timeoutInfo.EntityBody := aEntityBody; timeoutInfo.DrainEntityBody := aDrainEntityBody; timeoutInfo.RequestQueue := aRequestQueue; timeoutInfo.IdleConnection := aIdleConnection; timeoutInfo.HeaderWait := aHeaderWait; timeoutInfo.MinSendRate := aMinSendRate; EHttpApiServer.RaiseOnError(hSetUrlGroupProperty, Http.SetUrlGroupProperty(fUrlGroupID, HttpServerTimeoutsProperty, @timeoutInfo, SizeOf(timeoutInfo))); end; type WEB_SOCKET_PROPERTY_TYPE = ( WEB_SOCKET_RECEIVE_BUFFER_SIZE_PROPERTY_TYPE, //0 WEB_SOCKET_SEND_BUFFER_SIZE_PROPERTY_TYPE, WEB_SOCKET_DISABLE_MASKING_PROPERTY_TYPE, WEB_SOCKET_ALLOCATED_BUFFER_PROPERTY_TYPE, WEB_SOCKET_DISABLE_UTF8_VERIFICATION_PROPERTY_TYPE, WEB_SOCKET_KEEPALIVE_INTERVAL_PROPERTY_TYPE, WEB_SOCKET_SUPPORTED_VERSIONS_PROPERTY_TYPE ); WEB_SOCKET_ACTION_QUEUE = Cardinal; WEB_SOCKET_ACTION = ( WEB_SOCKET_NO_ACTION, //0 WEB_SOCKET_SEND_TO_NETWORK_ACTION, WEB_SOCKET_INDICATE_SEND_COMPLETE_ACTION, WEB_SOCKET_RECEIVE_FROM_NETWORK_ACTION, WEB_SOCKET_INDICATE_RECEIVE_COMPLETE_ACTION ); PWEB_SOCKET_ACTION = ^WEB_SOCKET_ACTION; WEB_SOCKET_PROPERTY = record PropType: WEB_SOCKET_PROPERTY_TYPE; pvValue: Pointer; ulValueSize: ULONG; end; PWEB_SOCKET_PROPERTY = ^WEB_SOCKET_PROPERTY; WEB_SOCKET_HTTP_HEADER = record pcName: PAnsiChar; ulNameLength: ULONG; pcValue: PAnsiChar; ulValueLength: ULONG; end; PWEB_SOCKET_HTTP_HEADER = ^WEB_SOCKET_HTTP_HEADER; WEB_SOCKET_HTTP_HEADER_ARR = array of WEB_SOCKET_HTTP_HEADER; PWEB_SOCKET_BUFFER_DATA = ^WEB_SOCKET_BUFFER_DATA; WEB_SOCKET_BUFFER_DATA = record pbBuffer: PBYTE; ulBufferLength: ULONG; Reserved1: Word; end; WEB_SOCKET_BUFFER_CLOSE_STATUS = record pbReason: PBYTE; ulReasonLength: ULONG; usStatus: WEB_SOCKET_CLOSE_STATUS; end; /// direct late-binding access to the WebSocket Protocol Component API functions TWebSocketAPI = packed record /// acces to the loaded library handle LibraryHandle: THandle; /// depends on Windows version WebSocketEnabled: Boolean; /// aborts a WebSocket session handle created by WebSocketCreateClientHandle // or WebSocketCreateServerHandle AbortHandle: procedure (hWebSocket: WEB_SOCKET_HANDLE); stdcall; /// begins the client-side handshake BeginClientHandshake: function (hWebSocket: WEB_SOCKET_HANDLE; pszSubprotocols: PAnsiChar; ulSubprotocolCount: ULONG; pszExtensions: PAnsiChar; ulExtensionCount: ULONG; const pInitialHeaders: PWEB_SOCKET_HTTP_HEADER; ulInitialHeaderCount: ULONG; out pAdditionalHeaders: PWEB_SOCKET_HTTP_HEADER; out pulAdditionalHeaderCount: ULONG): HRESULT; stdcall; /// begins the server-side handshake BeginServerHandshake: function (hWebSocket: WEB_SOCKET_HANDLE; pszSubprotocolSelected: PAnsiChar; pszExtensionSelected: PAnsiChar; ulExtensionSelectedCount: ULONG; const pRequestHeaders: PWEB_SOCKET_HTTP_HEADER; ulRequestHeaderCount: ULONG; out pResponseHeaders: PWEB_SOCKET_HTTP_HEADER; out pulResponseHeaderCount: ULONG): HRESULT; stdcall; /// completes an action started by WebSocketGetAction CompleteAction: function (hWebSocket: WEB_SOCKET_HANDLE; pvActionContext: Pointer; ulBytesTransferred: ULONG): HRESULT; stdcall; /// creates a client-side WebSocket session handle CreateClientHandle: function (const pProperties: PWEB_SOCKET_PROPERTY; ulPropertyCount: ULONG; out phWebSocket: WEB_SOCKET_HANDLE): HRESULT; stdcall; /// creates a server-side WebSocket session handle CreateServerHandle: function (const pProperties: PWEB_SOCKET_PROPERTY; ulPropertyCount: ULONG; out phWebSocket: WEB_SOCKET_HANDLE): HRESULT; stdcall; /// deletes a WebSocket session handle created by WebSocketCreateClientHandle // or WebSocketCreateServerHandle DeleteHandle: procedure (hWebSocket: WEB_SOCKET_HANDLE); stdcall; /// completes the client-side handshake EndClientHandshake: function (hWebSocket: WEB_SOCKET_HANDLE; const pResponseHeaders: PWEB_SOCKET_HTTP_HEADER; ulReponseHeaderCount: ULONG; var pulSelectedExtensions: ULONG; var pulSelectedExtensionCount: ULONG; var pulSelectedSubprotocol: ULONG): HRESULT; stdcall; /// completes the server-side handshake EndServerHandshake: function (hWebSocket: WEB_SOCKET_HANDLE): HRESULT; stdcall; /// returns an action from a call to WebSocketSend, WebSocketReceive or WebSocketCompleteAction GetAction: function (hWebSocket: WEB_SOCKET_HANDLE; eActionQueue: WEB_SOCKET_ACTION_QUEUE; pDataBuffers: Pointer {WEB_SOCKET_BUFFER_DATA}; var pulDataBufferCount: ULONG; var pAction: WEB_SOCKET_ACTION; var pBufferType: WEB_SOCKET_BUFFER_TYPE; var pvApplicationContext: Pointer; var pvActionContext: Pointer): HRESULT; stdcall; /// gets a single WebSocket property GetGlobalProperty: function (eType: WEB_SOCKET_PROPERTY_TYPE; pvValue: Pointer; var ulSize: ULONG): HRESULT ; stdcall; /// adds a receive operation to the protocol component operation queue Receive: function (hWebSocket: WEB_SOCKET_HANDLE; pBuffer: Pointer {PWEB_SOCKET_BUFFER_*}; pvContext: Pointer): HRESULT; stdcall; /// adds a send operation to the protocol component operation queue Send: function (hWebSocket: WEB_SOCKET_HANDLE; BufferType: WEB_SOCKET_BUFFER_TYPE; pBuffer: Pointer {PWEB_SOCKET_BUFFER_*}; Context: Pointer): HRESULT; stdcall; end; /// identify each TWebSocketAPI late-binding API function TWebSocketAPIs = (hAbortHandle, hBeginClientHandshake, hBeginServerHandshake, hCompleteAction, hCreateClientHandle, hCreateServerHandle, hDeleteHandle, hEndClientHandshake, hEndServerHandshake, hGetAction, hGetGlobalProperty, hReceive, hSend ); const sProtocolHeader: SockString = 'SEC-WEBSOCKET-PROTOCOL'; function HttpSys2ToWebSocketHeaders(const aHttpHeaders: HTTP_REQUEST_HEADERS): WEB_SOCKET_HTTP_HEADER_ARR; var headerCnt: Integer; i, idx: PtrInt; h: THttpHeader; p: PHTTP_UNKNOWN_HEADER; begin headerCnt := 0; for h := Low(HTTP_KNOWNHEADERS) to High(HTTP_KNOWNHEADERS) do if aHttpHeaders.KnownHeaders[h].RawValueLength <> 0 then inc(headerCnt); p := aHttpHeaders.pUnknownHeaders; if p<>nil then inc(headerCnt, aHttpHeaders.UnknownHeaderCount); SetLength(Result, headerCnt); idx := 0; for h := Low(HTTP_KNOWNHEADERS) to High(HTTP_KNOWNHEADERS) do if aHttpHeaders.KnownHeaders[h].RawValueLength<>0 then begin Result[idx].pcName := @HTTP_KNOWNHEADERS[h][1]; Result[idx].ulNameLength := ord(HTTP_KNOWNHEADERS[h][0]); Result[idx].pcValue := aHttpHeaders.KnownHeaders[h].pRawValue; Result[idx].ulValueLength := aHttpHeaders.KnownHeaders[h].RawValueLength; inc(idx); end; p := aHttpHeaders.pUnknownHeaders; if p<>nil then for i := 1 to aHttpHeaders.UnknownHeaderCount do begin Result[idx].pcName := p^.pName; Result[idx].ulNameLength := p^.NameLength; Result[idx].pcValue := p^.pRawValue; Result[idx].ulValueLength := p^.RawValueLength; inc(idx); inc(p); end; end; function WebSocketHeadersToSockString(const aHeaders: PWEB_SOCKET_HTTP_HEADER; const aHeadersCount: Integer): SockString; var i: Integer; h: PWEB_SOCKET_HTTP_HEADER; len: Integer; d : PAnsiChar; begin len := 0; h := aHeaders; for i := 1 to aHeadersCount do begin if h^.ulValueLength<>0 then inc(len, h^.ulNameLength + h^.ulValueLength + 4); inc(h); end; SetString(Result, nil, len); d := Pointer(Result); h := aHeaders; for i := 1 to aHeadersCount do begin if h^.ulValueLength<>0 then begin Move(h^.pcName^, d^, h^.ulNameLength); inc(d, h^.ulNameLength); PWord(d)^ := Ord(':') + Ord(' ') shl 8; inc(d, 2); Move(h^.pcValue^, d^, h^.ulValueLength); inc(d, h^.ulValueLength); PWord(d)^ := 13 + 10 shl 8; inc(d, 2); end; inc(h); end; Assert(d - Pointer(Result) = len); end; const WEBSOCKET_DLL = 'websocket.dll'; WebSocketNames: array [TWebSocketAPIs] of PChar = ( 'WebSocketAbortHandle', 'WebSocketBeginClientHandshake', 'WebSocketBeginServerHandshake', 'WebSocketCompleteAction', 'WebSocketCreateClientHandle', 'WebSocketCreateServerHandle', 'WebSocketDeleteHandle', 'WebSocketEndClientHandshake', 'WebSocketEndServerHandshake', 'WebSocketGetAction', 'WebSocketGetGlobalProperty', 'WebSocketReceive', 'WebSocketSend' ); WEB_SOCKET_SEND_ACTION_QUEUE = $1; WEB_SOCKET_RECEIVE_ACTION_QUEUE = $2; WEB_SOCKET_ALL_ACTION_QUEUE = WEB_SOCKET_SEND_ACTION_QUEUE or WEB_SOCKET_RECEIVE_ACTION_QUEUE; ///Context ID of WebSocket URI group WEB_SOCKET_URL_CONTEXT = 1; var WebSocketAPI: TWebSocketAPI; procedure WebSocketApiInitialize; var api: TWebSocketAPIs; P: PPointer; begin if WebSocketAPI.LibraryHandle<>0 then exit; // already loaded WebSocketAPI.WebSocketEnabled := false; WebSocketAPI.LibraryHandle := SafeLoadLibrary(WEBSOCKET_DLL); if WebSocketAPI.LibraryHandle=0 then exit; P := @@WebSocketAPI.AbortHandle; for api := low(api) to high(api) do begin P^ := GetProcAddress(WebSocketAPI.LibraryHandle,WebSocketNames[api]); if P^ = nil then begin FreeLibrary(WebSocketAPI.LibraryHandle); WebSocketAPI.LibraryHandle := 0; exit; end; inc(P); end; WebSocketAPI.WebSocketEnabled := true; end; function WinHTTP_WebSocketEnabled: boolean; begin Result := WebSocketAPI.WebSocketEnabled; end; { EWebSocketApi } type EWebSocketApi = class(ECrtSocket) protected fLastApi: TWebSocketAPIs; public class procedure RaiseOnError(api: TWebSocketAPIs; Error: integer); constructor Create(api: TWebSocketAPIs; Error: integer); reintroduce; published property LastApi: TWebSocketAPIs read fLastApi; end; class procedure EWebSocketApi.RaiseOnError(api: TWebSocketAPIs; Error: integer); begin if Error<>NO_ERROR then raise self.Create(api,Error); end; constructor EWebSocketApi.Create(api: TWebSocketAPIs; Error: integer); begin fLastError := Error; fLastApi := api; inherited CreateFmt('%s failed: %s (%d)', [WebSocketNames[api],SysErrorMessagePerModule(Error,WEBSOCKET_DLL),Error]) end; { THttpApiWebSocketServerProtocol } const WebSocketConnectionCapacity = 1000; function THttpApiWebSocketServerProtocol.AddConnection(aConn: PHttpApiWebSocketConnection): Integer; var i: integer; begin if fFirstEmptyConnectionIndex >= fConnectionsCapacity - 1 then begin inc(fConnectionsCapacity, WebSocketConnectionCapacity); ReallocMem(fConnections, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection)); Fillchar(fConnections^[fConnectionsCapacity - WebSocketConnectionCapacity], WebSocketConnectionCapacity * SizeOf(PHttpApiWebSocketConnection), 0); end; if fFirstEmptyConnectionIndex >= fConnectionsCount then fConnectionsCount := fFirstEmptyConnectionIndex + 1; fConnections[fFirstEmptyConnectionIndex] := aConn; Result := fFirstEmptyConnectionIndex; for i := fFirstEmptyConnectionIndex + 1 to fConnectionsCount do begin if fConnections[i] = nil then begin fFirstEmptyConnectionIndex := i; Break; end; end; end; function THttpApiWebSocketServerProtocol.Broadcast( aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG): boolean; var i: integer; begin EnterCriticalSection(fSafe); try for i := 0 to fConnectionsCount - 1 do if Assigned(fConnections[i]) then fConnections[i].Send(aBufferType, aBuffer, aBufferSize); finally LeaveCriticalSection(fSafe); end; result := True; end; function THttpApiWebSocketServerProtocol.Close(index: Integer; aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG): boolean; var conn: PHttpApiWebSocketConnection; begin Result := false; if (index>=0) and (indexnil) and (conn.fState = wsOpen) then begin conn.Close(aStatus, aBuffer, aBufferSize); result := True; end; end; end; constructor THttpApiWebSocketServerProtocol.Create(const aName: SockString; aManualFragmentManagement: Boolean; aServer: THttpApiWebSocketServer; aOnAccept: THttpApiWebSocketServerOnAcceptEvent; aOnMessage: THttpApiWebSocketServerOnMessageEvent; aOnConnect: THttpApiWebSocketServerOnConnectEvent; aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; aOnFragment: THttpApiWebSocketServerOnMessageEvent); begin if aManualFragmentManagement and not Assigned(aOnFragment) then raise EWebSocketApi.CreateFmt('Error register WebSocket protocol. Protocol %s does not use buffer, ' + 'but OnFragment handler is not assigned', [aName]); {$ifdef FPC} InitCriticalSection(fSafe); {$else} InitializeCriticalSection(fSafe); {$endif} fPendingForClose := {$ifdef FPC}TFPList{$else}TList{$endif}.Create; fName := aName; fManualFragmentManagement := aManualFragmentManagement; fServer := aServer; fOnAccept := aOnAccept; fOnMessage := aOnMessage; fOnConnect := aOnConnect; fOnDisconnect := aOnDisconnect; fOnFragment := aOnFragment; fConnectionsCapacity := WebSocketConnectionCapacity; fConnectionsCount := 0; fFirstEmptyConnectionIndex := 0; GetMem(fConnections, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection)); Fillchar(fConnections^, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection), 0); end; destructor THttpApiWebSocketServerProtocol.Destroy; var i: integer; conn: PHttpApiWebSocketConnection; begin EnterCriticalSection(fSafe); try for i := 0 to fPendingForClose.Count-1 do begin conn := fPendingForClose[i]; if Assigned(conn) then begin conn.DoOnDisconnect(); conn.Disconnect(); Dispose(conn); end; end; fPendingForClose.Free; finally LeaveCriticalSection(fSafe); end; {$IFDEF FPC} DoneCriticalsection(fSafe); {$ELSE} DeleteCriticalSection(fSafe); {$ENDIF} FreeMem(fConnections, fConnectionsCapacity * SizeOf(PHttpApiWebSocketConnection)); fConnections := nil; inherited; end; procedure THttpApiWebSocketServerProtocol.doShutdown; var i: Integer; conn: PHttpApiWebSocketConnection; const sReason = 'Server shutdown'; begin EnterCriticalSection(fSafe); try for i := 0 to fConnectionsCount - 1 do begin conn := fConnections[i]; if Assigned(conn) then begin RemoveConnection(i); conn.fState := wsClosedByShutdown; conn.fBuffer := sReason; conn.fCloseStatus := WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS; conn.Close(WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS, Pointer(conn.fBuffer), Length(conn.fBuffer)); // PostQueuedCompletionStatus(fServer.fThreadPoolServer.FRequestQueue, 0, 0, @conn.fOverlapped); end; end; finally LeaveCriticalSection(fSafe); end; end; procedure THttpApiWebSocketServerProtocol.RemoveConnection(index: integer); begin fPendingForClose.Add(fConnections[index]); fConnections[index] := nil; if (fFirstEmptyConnectionIndex > index) then fFirstEmptyConnectionIndex := index; end; function THttpApiWebSocketServerProtocol.Send(index: Integer; aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG): boolean; var conn: PHttpApiWebSocketConnection; begin result := false; if (index>=0) and (indexnil) and (conn.fState=wsOpen) then begin conn.Send(aBufferType, aBuffer, aBufferSize); result := True; end; end; end; { THttpApiWebSocketConnection } function THttpApiWebSocketConnection.TryAcceptConnection(aProtocol: THttpApiWebSocketServerProtocol; Ctxt: THttpServerRequest; aNeedHeader: boolean): boolean; var req: PHTTP_REQUEST; wsRequestHeaders: WEB_SOCKET_HTTP_HEADER_ARR; wsServerHeaders: PWEB_SOCKET_HTTP_HEADER; wsServerHeadersCount: ULONG; begin fState := wsConnecting; fBuffer := ''; fWSHandle := nil; fLastActionContext := nil; Fillchar(fOverlapped, SizeOf(fOverlapped), 0); fProtocol := aProtocol; req := PHTTP_REQUEST(Ctxt.HttpApiRequest); fIndex := fProtocol.fFirstEmptyConnectionIndex; fOpaqueHTTPRequestId := req^.RequestId; if (fProtocol=nil) or (Assigned(fProtocol.OnAccept) and not fProtocol.OnAccept(Ctxt, Self)) then begin result := False; exit; end; EWebSocketApi.RaiseOnError(hCreateServerHandle, WebSocketAPI.CreateServerHandle(nil, 0, fWSHandle)); wsRequestHeaders := HttpSys2ToWebSocketHeaders(req^.Headers); if aNeedHeader then result := WebSocketAPI.BeginServerHandshake(fWSHandle, Pointer(fProtocol.name), nil, 0, @wsRequestHeaders[0], Length(wsRequestHeaders), wsServerHeaders, wsServerHeadersCount) = S_OK else result := WebSocketAPI.BeginServerHandshake(fWSHandle, nil, nil, 0, @wsRequestHeaders[0], Length(wsRequestHeaders), wsServerHeaders, wsServerHeadersCount) = S_OK; if result then try Ctxt.OutCustomHeaders := WebSocketHeadersToSockString(wsServerHeaders, wsServerHeadersCount); finally result := WebSocketAPI.EndServerHandshake(fWSHandle) = S_OK; end; if not Result then Disconnect else fLastReceiveTickCount := 0; end; procedure THttpApiWebSocketConnection.DoOnMessage(aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG); procedure PushFragmentIntoBuffer; var l: Integer; begin l := Length(fBuffer); SetLength(fBuffer, l + Integer(aBufferSize)); Move(aBuffer^, fBuffer[l + 1], aBufferSize); end; begin if (fProtocol = nil) then exit; if (aBufferType=WEB_SOCKET_UTF8_FRAGMENT_BUFFER_TYPE) or (aBufferType=WEB_SOCKET_BINARY_FRAGMENT_BUFFER_TYPE) then begin // Fragment if not fProtocol.ManualFragmentManagement then PushFragmentIntoBuffer; if Assigned(fProtocol.OnFragment) then fProtocol.OnFragment(self,aBufferType,aBuffer,aBufferSize); end else begin // last Fragment if Assigned(fProtocol.OnMessage) then begin if fProtocol.ManualFragmentManagement then fProtocol.OnMessage(self,aBufferType,aBuffer,aBufferSize) else begin PushFragmentIntoBuffer; fProtocol.OnMessage(self,aBufferType,Pointer(fBuffer),Length(fBuffer)); fBuffer := ''; end; end; end; end; procedure THttpApiWebSocketConnection.DoOnConnect; begin if (fProtocol<>nil) and Assigned(fProtocol.OnConnect) then fProtocol.OnConnect(self); end; procedure THttpApiWebSocketConnection.DoOnDisconnect; begin if (fProtocol<>nil) and Assigned(fProtocol.OnDisconnect) then fProtocol.OnDisconnect(self,fCloseStatus,Pointer(fBuffer),length(fBuffer)); end; function THttpApiWebSocketConnection.ReadData(const WebsocketBufferData): integer; var Err: HRESULT; fBytesRead: cardinal; aBuf: WEB_SOCKET_BUFFER_DATA absolute WebsocketBufferData; begin Result := 0; if fWSHandle = nil then exit; Err := Http.ReceiveRequestEntityBody(fProtocol.fServer.FReqQueue, fOpaqueHTTPRequestId, 0, aBuf.pbBuffer, aBuf.ulBufferLength, fBytesRead, @self.fOverlapped); case Err of // On page reload Safari do not send a WEB_SOCKET_INDICATE_RECEIVE_COMPLETE_ACTION // with BufferType = WEB_SOCKET_CLOSE_BUFFER_TYPE, instead it send a dummy packet // (WEB_SOCKET_RECEIVE_FROM_NETWORK_ACTION) and terminate socket // see forum discussion https://synopse.info/forum/viewtopic.php?pid=27125 ERROR_HANDLE_EOF: Result := -1; ERROR_IO_PENDING: ; // NO_ERROR: ;// else // todo: close connection end; end; procedure THttpApiWebSocketConnection.WriteData(const WebsocketBufferData); var Err: HRESULT; httpSendEntity: HTTP_DATA_CHUNK_INMEMORY; bytesWrite: Cardinal; aBuf: WEB_SOCKET_BUFFER_DATA absolute WebsocketBufferData; begin if fWSHandle = nil then exit; bytesWrite := 0; httpSendEntity.DataChunkType := hctFromMemory; httpSendEntity.pBuffer := aBuf.pbBuffer; httpSendEntity.BufferLength := aBuf.ulBufferLength; Err := Http.SendResponseEntityBody(fProtocol.fServer.FReqQueue,fOpaqueHTTPRequestId, HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA or HTTP_SEND_RESPONSE_FLAG_MORE_DATA, 1, @httpSendEntity, bytesWrite, nil, nil, @fProtocol.fServer.fSendOverlaped); case Err of ERROR_HANDLE_EOF: Disconnect; ERROR_IO_PENDING: ; // NO_ERROR: ;// else // todo: close connection end; end; procedure THttpApiWebSocketConnection.CheckIsActive; var elapsed: PtrInt; const sCloseReason = 'Closed after ping timeout'; begin if (fLastReceiveTickCount>0) and (fProtocol.fServer.fPingTimeout>0) then begin elapsed := GetTick64-fLastReceiveTickCount; if elapsed>2*fProtocol.fServer.PingTimeout*1000 then begin fProtocol.RemoveConnection(fIndex); fState := wsClosedByGuard; fCloseStatus := WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS; fBuffer := sCloseReason; PostQueuedCompletionStatus( fProtocol.fServer.fThreadPoolServer.FRequestQueue, 0, 0, @fOverlapped); end else if elapsed>=fProtocol.fServer.PingTimeout * 1000 then Ping; end; end; procedure THttpApiWebSocketConnection.Disconnect; var //Err: HRESULT; //todo: handle error httpSendEntity: HTTP_DATA_CHUNK_INMEMORY; bytesWrite: Cardinal; begin WebSocketAPI.AbortHandle(fWSHandle); WebSocketAPI.DeleteHandle(fWSHandle); fWSHandle := nil; httpSendEntity.DataChunkType := hctFromMemory; httpSendEntity.pBuffer := nil; httpSendEntity.BufferLength := 0; {Err :=} Http.SendResponseEntityBody(fProtocol.fServer.fReqQueue, fOpaqueHTTPRequestId, HTTP_SEND_RESPONSE_FLAG_DISCONNECT, 1, @httpSendEntity, bytesWrite, nil, nil, nil); end; procedure THttpApiWebSocketConnection.BeforeRead; begin // if reading is in progress then try read messages else try receive new messages if fState in [wsOpen, wsClosing] then begin if Assigned(fLastActionContext) then begin EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( fWSHandle, fLastActionContext, fOverlapped.InternalHigh)); fLastActionContext := nil; end else EWebSocketApi.RaiseOnError(hReceive, WebSocketAPI.Receive(fWSHandle, nil, nil)); end else raise EWebSocketApi.CreateFmt( 'THttpApiWebSocketConnection.BeforeRead state is not wsOpen', []); end; const C_WEB_SOCKET_BUFFER_SIZE = 2; type TWebSocketBufferDataArr = array [0 .. C_WEB_SOCKET_BUFFER_SIZE - 1] of WEB_SOCKET_BUFFER_DATA; function THttpApiWebSocketConnection.ProcessActions( ActionQueue: WEB_SOCKET_ACTION_QUEUE): boolean; var ulDataBufferCount: ULONG; Action: WEB_SOCKET_ACTION; BufferType: WEB_SOCKET_BUFFER_TYPE; ApplicationContext: Pointer; ActionContext: Pointer; i: integer; Err: HRESULT; Buffer: TWebSocketBufferDataArr; procedure closeConnection(); begin EnterCriticalSection(fProtocol.fSafe); try fProtocol.RemoveConnection(fIndex); finally LeaveCriticalSection(fProtocol.fSafe); end; EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( fWSHandle, ActionContext, 0)); end; begin result := true; repeat ulDataBufferCount := Length(Buffer); EWebSocketApi.RaiseOnError(hGetAction, WebSocketAPI.GetAction(fWSHandle, ActionQueue, @Buffer[0], ulDataBufferCount, Action, BufferType, ApplicationContext, ActionContext)); case Action of WEB_SOCKET_NO_ACTION: ; WEB_SOCKET_SEND_TO_NETWORK_ACTION: begin for i := 0 to ulDataBufferCount - 1 do WriteData(Buffer[i]); if fWSHandle <> nil then begin Err := WebSocketAPI.CompleteAction(fWSHandle, ActionContext, 0); EWebSocketApi.RaiseOnError(hCompleteAction, Err); end; result := False; exit; end; WEB_SOCKET_INDICATE_SEND_COMPLETE_ACTION: ; WEB_SOCKET_RECEIVE_FROM_NETWORK_ACTION: begin for i := 0 to ulDataBufferCount - 1 do if (ReadData(Buffer[i])=-1) then begin fState := wsClosedByClient; fBuffer := ''; fCloseStatus := WEB_SOCKET_ENDPOINT_UNAVAILABLE_CLOSE_STATUS; closeConnection(); end; fLastActionContext := ActionContext; result := False; exit; end; WEB_SOCKET_INDICATE_RECEIVE_COMPLETE_ACTION: begin fLastReceiveTickCount := GetTick64; if BufferType = WEB_SOCKET_CLOSE_BUFFER_TYPE then begin if fState = wsOpen then fState := wsClosedByClient else fState := wsClosedByServer; SetString(fBuffer, PChar(Buffer[0].pbBuffer), Buffer[0].ulBufferLength); fCloseStatus := Buffer[0].Reserved1; closeConnection(); result := False; exit; end else if BufferType = WEB_SOCKET_PING_PONG_BUFFER_TYPE then begin // todo: may be answer to client's ping EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( fWSHandle, ActionContext, 0)); exit; end else if BufferType = WEB_SOCKET_UNSOLICITED_PONG_BUFFER_TYPE then begin // todo: may be handle this situation EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( fWSHandle, ActionContext, 0)); exit; end else begin DoOnMessage(BufferType, Buffer[0].pbBuffer, Buffer[0].ulBufferLength); EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction( fWSHandle, ActionContext, 0)); exit; end; end else raise EWebSocketApi.CreateFmt('Invalid WebSocket action %d', [byte(Action)]); end; Err := WebSocketAPI.CompleteAction(fWSHandle, ActionContext, 0); if ActionContext <> nil then EWebSocketApi.RaiseOnError(hCompleteAction, Err); until (Action = WEB_SOCKET_NO_ACTION); end; procedure THttpApiWebSocketConnection.InternalSend(aBufferType: WEB_SOCKET_BUFFER_TYPE; WebsocketBufferData: pointer); begin EWebSocketApi.RaiseOnError(hSend, WebSocketAPI.Send( fWSHandle, aBufferType, WebsocketBufferData, nil)); ProcessActions(WEB_SOCKET_SEND_ACTION_QUEUE); end; procedure THttpApiWebSocketConnection.Send(aBufferType: WEB_SOCKET_BUFFER_TYPE; aBuffer: Pointer; aBufferSize: ULONG); var wsSendBuf: WEB_SOCKET_BUFFER_DATA; begin if fState<>wsOpen then exit; wsSendBuf.pbBuffer := aBuffer; wsSendBuf.ulBufferLength := aBufferSize; InternalSend(aBufferType, @wsSendBuf); end; procedure THttpApiWebSocketConnection.Close(aStatus: WEB_SOCKET_CLOSE_STATUS; aBuffer: Pointer; aBufferSize: ULONG); var wsSendBuf: WEB_SOCKET_BUFFER_DATA; begin if fState=wsOpen then fState := wsClosing; wsSendBuf.pbBuffer := aBuffer; wsSendBuf.ulBufferLength := aBufferSize; wsSendBuf.Reserved1 := aStatus; InternalSend(WEB_SOCKET_CLOSE_BUFFER_TYPE, @wsSendBuf); end; procedure THttpApiWebSocketConnection.Ping; begin InternalSend(WEB_SOCKET_PING_PONG_BUFFER_TYPE, nil); end; { THttpApiWebSocketServer } constructor THttpApiWebSocketServer.Create(CreateSuspended: Boolean; aSocketThreadsCount, aPingTimeout: integer; QueueName: SockUnicode; aOnWSThreadStart: TNotifyThreadEvent; aOnWSThreadTerminate: TNotifyThreadEvent); begin inherited Create(CreateSuspended, QueueName); if not (WebSocketAPI.WebSocketEnabled) then raise ECrtSocket.Create('WebSocket is not supported'); fPingTimeout := aPingTimeout; if fPingTimeout>0 then fGuard := TSynWebSocketGuard.Create(Self); New(fRegisteredProtocols); SetLength(fRegisteredProtocols^, 0); FOnWSThreadStart := aOnWSThreadStart; FOnWSThreadTerminate := aOnWSThreadTerminate; fThreadPoolServer := TSynThreadPoolHttpApiWebSocketServer.Create(Self, aSocketThreadsCount); end; constructor THttpApiWebSocketServer.CreateClone(From: THttpApiServer); var wsServer: THttpApiWebSocketServer absolute From; begin inherited CreateClone(From); fThreadPoolServer := wsServer.fThreadPoolServer; fPingTimeout := wsServer.fPingTimeout; fRegisteredProtocols := wsServer.fRegisteredProtocols end; procedure THttpApiWebSocketServer.DestroyMainThread; var i: PtrInt; begin fGuard.Free; for i := 0 to Length(fRegisteredProtocols^) - 1 do fRegisteredProtocols^[i].doShutdown; FreeAndNil(fThreadPoolServer); for i := 0 to Length(fRegisteredProtocols^) - 1 do fRegisteredProtocols^[i].Free; fRegisteredProtocols^ := nil; Dispose(fRegisteredProtocols); fRegisteredProtocols := nil; inherited; end; procedure THttpApiWebSocketServer.DoAfterResponse(Ctxt: THttpServerRequest; const Code: cardinal); begin if Assigned(fLastConnection) then PostQueuedCompletionStatus(fThreadPoolServer.FRequestQueue, 0, 0, @fLastConnection.fOverlapped); inherited DoAfterResponse(Ctxt, Code); end; function THttpApiWebSocketServer.GetProtocol(index: integer): THttpApiWebSocketServerProtocol; begin if (index>=0) and (index<=Length(fRegisteredProtocols^)) then result := fRegisteredProtocols^[index] else result := nil; end; function THttpApiWebSocketServer.getProtocolsCount: Integer; begin if self=nil then result := 0 else result := Length(fRegisteredProtocols^); end; function THttpApiWebSocketServer.getSendResponseFlags(Ctxt: THttpServerRequest): Integer; begin if (PHTTP_REQUEST(Ctxt.HttpApiRequest)^.UrlContext=WEB_SOCKET_URL_CONTEXT) and (fLastConnection<>nil) then result := HTTP_SEND_RESPONSE_FLAG_OPAQUE or HTTP_SEND_RESPONSE_FLAG_MORE_DATA or HTTP_SEND_RESPONSE_FLAG_BUFFER_DATA else result := inherited getSendResponseFlags(Ctxt); end; function THttpApiWebSocketServer.UpgradeToWebSocket(Ctxt: THttpServerRequest): cardinal; var Protocol: THttpApiWebSocketServerProtocol; i, j: Integer; p: PHTTP_UNKNOWN_HEADER; ch, chB: PAnsiChar; aName: SockString; ProtocolHeaderFound: Boolean; label protocolFound; begin result := 404; Protocol := nil; ProtocolHeaderFound := false; p := PHTTP_REQUEST(Ctxt.HttpApiRequest)^.Headers.pUnknownHeaders; for j := 1 to PHTTP_REQUEST(Ctxt.HttpApiRequest)^.Headers.UnknownHeaderCount do begin if (p.NameLength=Length(sProtocolHeader)) and IdemPChar(p.pName,Pointer(sProtocolHeader)) then begin ProtocolHeaderFound := True; for i := 0 to Length(fRegisteredProtocols^) - 1 do begin ch := p.pRawValue; while (ch-p.pRawValue) nil then begin EnterCriticalSection(Protocol.fSafe); try New(fLastConnection); if fLastConnection.TryAcceptConnection(Protocol,Ctxt,ProtocolHeaderFound) then begin Protocol.AddConnection(fLastConnection); result := 101 end else begin Dispose(fLastConnection); fLastConnection := nil; result := 405; end; finally LeaveCriticalSection(Protocol.fSafe); end; end; end; function THttpApiWebSocketServer.AddUrlWebSocket(const aRoot, aPort: SockString; Https: boolean; const aDomainName: SockString; aRegisterURI: boolean): integer; begin result := AddUrl(aRoot, aPort, Https, aDomainName, aRegisterURI, WEB_SOCKET_URL_CONTEXT); end; procedure THttpApiWebSocketServer.RegisterProtocol(const aName: SockString; aManualFragmentManagement: Boolean; aOnAccept: THttpApiWebSocketServerOnAcceptEvent; aOnMessage: THttpApiWebSocketServerOnMessageEvent; aOnConnect: THttpApiWebSocketServerOnConnectEvent; aOnDisconnect: THttpApiWebSocketServerOnDisconnectEvent; aOnFragment: THttpApiWebSocketServerOnMessageEvent); var protocol: THttpApiWebSocketServerProtocol; begin if self=nil then exit; protocol := THttpApiWebSocketServerProtocol.Create(aName, aManualFragmentManagement, Self, aOnAccept, aOnMessage, aOnConnect, aOnDisconnect, aOnFragment); protocol.fIndex := length(fRegisteredProtocols^); SetLength(fRegisteredProtocols^, protocol.fIndex + 1); fRegisteredProtocols^[protocol.fIndex] := protocol; end; function THttpApiWebSocketServer.Request(Ctxt: THttpServerRequest): cardinal; begin if PHTTP_REQUEST(Ctxt.HttpApiRequest).UrlContext=WEB_SOCKET_URL_CONTEXT then result := UpgradeToWebSocket(Ctxt) else begin result := inherited Request(Ctxt); fLastConnection := nil; end; end; procedure THttpApiWebSocketServer.SendServiceMessage; begin PostQueuedCompletionStatus(fThreadPoolServer.FRequestQueue, 0, 0, @fServiceOverlaped); end; procedure THttpApiWebSocketServer.SetOnWSThreadStart( const Value: TNotifyThreadEvent); begin FOnWSThreadStart := Value; end; procedure THttpApiWebSocketServer.SetOnWSThreadTerminate( const Value: TNotifyThreadEvent); begin FOnWSThreadTerminate := Value; end; { TSynThreadPoolHttpApiWebSocketServer } function TSynThreadPoolHttpApiWebSocketServer.NeedStopOnIOError: Boolean; begin // If connection closed by guard than ERROR_HANDLE_EOF or ERROR_OPERATION_ABORTED // can be returned - Other connections must work normally result := False; end; procedure TSynThreadPoolHttpApiWebSocketServer.OnThreadStart(Sender: TThread); begin if Assigned(fServer.OnWSThreadStart) then fServer.OnWSThreadStart(Sender); end; procedure TSynThreadPoolHttpApiWebSocketServer.OnThreadTerminate( Sender: TThread); begin if Assigned(fServer.OnWSThreadTerminate) then fServer.OnWSThreadTerminate(Sender); end; procedure TSynThreadPoolHttpApiWebSocketServer.Task(aCaller: TSynThread; aContext: Pointer); var conn: PHttpApiWebSocketConnection; begin if aContext=@fServer.fSendOverlaped then exit; if (aContext=@fServer.fServiceOverlaped) then begin if Assigned(fServer.onServiceMessage) then fServer.onServiceMessage; exit; end; conn := PHttpApiWebSocketConnection(aContext); if conn.fState=wsConnecting then begin conn.fState := wsOpen; conn.fLastReceiveTickCount := GetTick64; conn.DoOnConnect(); end; if conn.fState in [wsOpen, wsClosing] then repeat conn.BeforeRead; until not conn.ProcessActions(WEB_SOCKET_RECEIVE_ACTION_QUEUE); if conn.fState in [wsClosedByGuard] then EWebSocketApi.RaiseOnError(hCompleteAction, WebSocketAPI.CompleteAction(conn.fWSHandle, conn.fLastActionContext, 0)); if conn.fState in [wsClosedByClient,wsClosedByServer,wsClosedByGuard,wsClosedByShutdown] then begin conn.DoOnDisconnect; if conn.fState = wsClosedByClient then conn.Close(conn.fCloseStatus, Pointer(conn.fBuffer), length(conn.fBuffer)); conn.Disconnect; EnterCriticalSection(conn.Protocol.fSafe); try conn.Protocol.fPendingForClose.Remove(conn); finally LeaveCriticalSection(conn.Protocol.fSafe); end; Dispose(conn); end; end; constructor TSynThreadPoolHttpApiWebSocketServer.Create(Server: THttpApiWebSocketServer; NumberOfThreads: Integer); begin fServer := Server; fOnThreadStart := OnThreadStart; fOnThreadTerminate := OnThreadTerminate; inherited Create(NumberOfThreads, Server.fReqQueue); end; { TSynWebSocketGuard } procedure TSynWebSocketGuard.Execute; var i, j: Integer; prot: THttpApiWebSocketServerProtocol; begin if fServer.fPingTimeout>0 then while not Terminated do begin if fServer<>nil then for i := 0 to Length(fServer.fRegisteredProtocols^)-1 do begin prot := fServer.fRegisteredProtocols^[i]; EnterCriticalSection(prot.fSafe); try for j := 0 to prot.fConnectionsCount - 1 do if Assigned(prot.fConnections[j]) then prot.fConnections[j].CheckIsActive; finally LeaveCriticalSection(prot.fSafe); end; end; i := 0; while not Terminated and (i'' then begin Headers.KnownHeaders[reqContentType].RawValueLength := length(ContentType); Headers.KnownHeaders[reqContentType].pRawValue := pointer(ContentType); end; if Content='' then exit; DataChunk.DataChunkType := hctFromMemory; DataChunk.pBuffer := pointer(Content); DataChunk.BufferLength := length(Content); EntityChunkCount := 1; pEntityChunks := @DataChunk; end; function HTTP_RESPONSE.AddCustomHeader(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs; ForceCustomHeader: boolean): PAnsiChar; const KNOWNHEADERS: array[reqCacheControl..respWwwAuthenticate] of PAnsiChar = ( 'CACHE-CONTROL:','CONNECTION:','DATE:','KEEP-ALIVE:','PRAGMA:','TRAILER:', 'TRANSFER-ENCODING:','UPGRADE:','VIA:','WARNING:','ALLOW:','CONTENT-LENGTH:', 'CONTENT-TYPE:','CONTENT-ENCODING:','CONTENT-LANGUAGE:','CONTENT-LOCATION:', 'CONTENT-MD5:','CONTENT-RANGE:','EXPIRES:','LAST-MODIFIED:', 'ACCEPT-RANGES:','AGE:','ETAG:','LOCATION:','PROXY-AUTHENTICATE:', 'RETRY-AFTER:','SERVER:','SET-COOKIE:','VARY:','WWW-AUTHENTICATE:'); var UnknownName: PAnsiChar; i: integer; begin if ForceCustomHeader then i := -1 else i := IdemPCharArray(P,KNOWNHEADERS); // WebSockets need CONNECTION as unknown header if (i>=0) and (THttpHeader(i)<>reqConnection) then with Headers.KnownHeaders[THttpHeader(i)] do begin while P^<>':' do inc(P); inc(P); // jump ':' while P^=' ' do inc(P); pRawValue := P; while P^>=' ' do inc(P); RawValueLength := P-pRawValue; end else begin UnknownName := P; while (P^>=' ') and (P^<>':') do inc(P); if P^=':' then with UnknownHeaders[Headers.UnknownHeaderCount] do begin pName := UnknownName; NameLength := P-pName; repeat inc(P) until P^<>' '; pRawValue := P; while P^>=' ' do inc(P); RawValueLength := P-pRawValue; if Headers.UnknownHeaderCount=high(UnknownHeaders) then begin SetLength(UnknownHeaders,Headers.UnknownHeaderCount+32); Headers.pUnknownHeaders := pointer(UnknownHeaders); end; inc(Headers.UnknownHeaderCount); end else while P^>=' ' do inc(P); end; result := P; end; procedure HTTP_RESPONSE.SetHeaders(P: PAnsiChar; var UnknownHeaders: HTTP_UNKNOWN_HEADERs); {$ifndef NOXPOWEREDNAME} const XPN: PAnsiChar = XPOWEREDNAME; XPV: PAnsiChar = XPOWEREDVALUE; {$endif} begin Headers.pUnknownHeaders := pointer(UnknownHeaders); {$ifdef NOXPOWEREDNAME} Headers.UnknownHeaderCount := 0; {$else} with UnknownHeaders[0] do begin pName := XPN; NameLength := length(XPOWEREDNAME); pRawValue := XPV; RawValueLength := length(XPOWEREDVALUE); end; Headers.UnknownHeaderCount := 1; {$endif} if P<>nil then repeat while ord(P^) in [10,13] do inc(P); if P^=#0 then break; P := AddCustomHeader(P,UnknownHeaders,false); until false; end; procedure HTTP_RESPONSE.SetStatus(code: integer; var OutStatus: SockString); begin StatusCode := code; OutStatus := StatusCodeToReason(code); ReasonLength := length(OutStatus); pReason := pointer(OutStatus); end; const HTTP_LOG_FIELD_TEST_SUB_STATUS: THttpApiLogFields = [hlfSubStatus]; {$endif MSWINDOWS} // encapsulate whole http.sys / HTTP API process { THttpRequest } function THttpRequest.RegisterCompress(aFunction: THttpSocketCompress; aCompressMinSize: integer): boolean; begin result := RegisterCompressFunc(fCompress,aFunction,fCompressAcceptEncoding,aCompressMinSize)<>''; end; constructor THttpRequest.Create(const aServer, aPort: SockString; aHttps: boolean; const aProxyName,aProxyByPass: SockString; ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD; aLayer: TCrtSocketLayer); begin fLayer := aLayer; if fLayer<>cslUNIX then begin fPort := GetCardinal(pointer(aPort)); if fPort=0 then if aHttps then fPort := 443 else fPort := 80; end; fServer := aServer; fHttps := aHttps; fProxyName := aProxyName; fProxyByPass := aProxyByPass; fExtendedOptions.UserAgent := DefaultUserAgent(self); if ConnectionTimeOut=0 then ConnectionTimeOut := HTTP_DEFAULT_CONNECTTIMEOUT; if SendTimeout=0 then SendTimeout := HTTP_DEFAULT_SENDTIMEOUT; if ReceiveTimeout=0 then ReceiveTimeout := HTTP_DEFAULT_RECEIVETIMEOUT; InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout); // raise an exception on error end; constructor THttpRequest.Create(const aURI, aProxyName,aProxyByPass: SockString; ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD; aIgnoreSSLCertificateErrors: boolean); var URI: TURI; begin if not URI.From(aURI) then raise ECrtSocket.CreateFmt('%.Create: invalid aURI=%', [ClassName, aURI]); IgnoreSSLCertificateErrors := aIgnoreSSLCertificateErrors; Create(URI.Server,URI.Port,URI.Https,aProxyName,aProxyByPass, ConnectionTimeOut,SendTimeout,ReceiveTimeout,URI.Layer); end; class function THttpRequest.InternalREST(const url,method,data,header: SockString; aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; outStatus: PInteger): SockString; var URI: TURI; oh: SockString; status: integer; begin result := ''; with URI do if From(url) then try with self.Create(Server,Port,Https,'','',0,0,0,Layer) do try IgnoreSSLCertificateErrors := aIgnoreSSLCertificateErrors; status := Request(Address,method,0,header,data,'',oh,result); if outStatus<>nil then outStatus^ := status; if outHeaders<>nil then outHeaders^ := oh; finally Free; end; except result := ''; end; end; class function THttpRequest.Get(const aURI,aHeader: SockString; aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; outStatus: PInteger): SockString; begin result := InternalREST(aURI,'GET','',aHeader, aIgnoreSSLCertificateErrors,outHeaders,outStatus); end; class function THttpRequest.Post(const aURI, aData, aHeader: SockString; aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; outStatus: PInteger): SockString; begin result := InternalREST(aURI,'POST',aData,aHeader, aIgnoreSSLCertificateErrors,outHeaders,outStatus); end; class function THttpRequest.Put(const aURI, aData, aHeader: SockString; aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; outStatus: PInteger): SockString; begin result := InternalREST(aURI,'PUT',aData,aHeader, aIgnoreSSLCertificateErrors,outHeaders,outStatus); end; class function THttpRequest.Delete(const aURI, aHeader: SockString; aIgnoreSSLCertificateErrors: boolean; outHeaders: PSockString; outStatus: PInteger): SockString; begin result := InternalREST(aURI,'DELETE','',aHeader, aIgnoreSSLCertificateErrors,outHeaders,outStatus); end; function THttpRequest.Request(const url, method: SockString; KeepAlive: cardinal; const InHeader, InData, InDataType: SockString; out OutHeader, OutData: SockString): integer; var aData, aDataEncoding, aAcceptEncoding, aURL: SockString; i: integer; begin if (url='') or (url[1]<>'/') then aURL := '/'+url else // need valid url according to the HTTP/1.1 RFC aURL := url; fKeepAlive := KeepAlive; InternalCreateRequest(method,aURL); // should raise an exception on error try // common headers InternalAddHeader(InHeader); if InDataType<>'' then InternalAddHeader(SockString('Content-Type: ')+InDataType); // handle custom compression aData := InData; if integer(fCompressAcceptHeader)<>0 then begin aDataEncoding := CompressDataAndGetHeaders(fCompressAcceptHeader,fCompress, InDataType,aData); if aDataEncoding<>'' then InternalAddHeader(SockString('Content-Encoding: ')+aDataEncoding); end; if fCompressAcceptEncoding<>'' then InternalAddHeader(fCompressAcceptEncoding); // send request to remote server InternalSendRequest(method, aData); // retrieve status and headers result := InternalRetrieveAnswer(OutHeader,aDataEncoding,aAcceptEncoding,OutData); // handle incoming answer compression if OutData<>'' then begin if aDataEncoding<>'' then for i := 0 to high(fCompress) do with fCompress[i] do if Name=aDataEncoding then if Func(OutData,false)='' then raise ECrtSocket.CreateFmt('%s uncompress',[Name]) else break; // successfully uncompressed content if aAcceptEncoding<>'' then fCompressAcceptHeader := ComputeContentEncoding(fCompress,pointer(aAcceptEncoding)); end; finally InternalCloseRequest; end; end; {$ifdef USEWININET} { ************ WinHttp / WinINet HTTP clients } { TWinHttpAPI } const // while reading an HTTP response, read it in blocks of this size. 8K for now HTTP_RESP_BLOCK_SIZE = 8*1024; function TWinHttpAPI.InternalRetrieveAnswer( var Header, Encoding, AcceptEncoding, Data: SockString): integer; var Bytes, ContentLength, Read: DWORD; tmp: SockString; begin // HTTP_QUERY* and WINHTTP_QUERY* do match -> common to TWinINet + TWinHTTP result := InternalGetInfo32(HTTP_QUERY_STATUS_CODE); Header := InternalGetInfo(HTTP_QUERY_RAW_HEADERS_CRLF); Encoding := InternalGetInfo(HTTP_QUERY_CONTENT_ENCODING); AcceptEncoding := InternalGetInfo(HTTP_QUERY_ACCEPT_ENCODING); // retrieve received content (if any) Read := 0; ContentLength := InternalGetInfo32(HTTP_QUERY_CONTENT_LENGTH); if Assigned(fOnDownload) then begin // download per-chunk using calback event Bytes := fOnDownloadChunkSize; if Bytes<=0 then Bytes := 65536; // 64KB seems fair enough by default SetLength(tmp,Bytes); repeat Bytes := InternalQueryDataAvailable; if Bytes=0 then break; if Integer(Bytes) > Length(tmp) then SetLength(tmp, Bytes); Bytes := InternalReadData(tmp,0,Bytes); if Bytes=0 then break; inc(Read,Bytes); if not fOnDownload(self,Read,ContentLength,Bytes,pointer(tmp)^) then break; // returned false = aborted if Assigned(fOnProgress) then fOnProgress(self,Read,ContentLength); until false; end else if ContentLength<>0 then begin // optimized version reading "Content-Length: xxx" bytes SetLength(Data,ContentLength); repeat Bytes := InternalQueryDataAvailable; if Bytes=0 then begin SetLength(Data,Read); // truncated content break; end; Bytes := InternalReadData(Data,Read,Bytes); if Bytes=0 then begin SetLength(Data,Read); // truncated content break; end; inc(Read,Bytes); if Assigned(fOnProgress) then fOnProgress(self,Read,ContentLength); until Read=ContentLength; end else begin // Content-Length not set: read response in blocks of HTTP_RESP_BLOCK_SIZE repeat Bytes := InternalQueryDataAvailable; if Bytes=0 then break; SetLength(Data,Read+Bytes{HTTP_RESP_BLOCK_SIZE}); Bytes := InternalReadData(Data,Read,Bytes); if Bytes=0 then break; inc(Read,Bytes); if Assigned(fOnProgress) then fOnProgress(self,Read,ContentLength); until false; SetLength(Data,Read); end; end; class function TWinHttpAPI.IsAvailable: boolean; begin result := true; // both WinINet and WinHTTP are statically linked end; { EWinINet } constructor EWinINet.Create; var dwError, tmpLen: DWORD; msg, tmp: string; begin // see http://msdn.microsoft.com/en-us/library/windows/desktop/aa383884 fLastError := GetLastError; msg := SysErrorMessagePerModule(fLastError,'wininet.dll'); if fLastError=ERROR_INTERNET_EXTENDED_ERROR then begin InternetGetLastResponseInfo({$ifdef FPC}@{$endif}dwError,nil,tmpLen); if tmpLen > 0 then begin SetLength(tmp,tmpLen); InternetGetLastResponseInfo({$ifdef FPC}@{$endif}dwError,PChar(tmp),tmpLen); msg := msg+' ['+tmp+']'; end; end; inherited CreateFmt('%s (%d)',[msg,fLastError]); end; { TWinINet } destructor TWinINet.Destroy; begin if fConnection<>nil then InternetCloseHandle(FConnection); if fSession<>nil then InternetCloseHandle(FSession); inherited; end; procedure TWinINet.InternalAddHeader(const hdr: SockString); begin if (hdr<>'') and not HttpAddRequestHeadersA(fRequest, Pointer(hdr), length(hdr), HTTP_ADDREQ_FLAG_COALESCE) then raise EWinINet.Create; end; procedure TWinINet.InternalCloseRequest; begin if fRequest<>nil then begin InternetCloseHandle(fRequest); fRequest := nil; end; end; procedure TWinINet.InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); var OpenType: integer; begin if fProxyName='' then OpenType := INTERNET_OPEN_TYPE_PRECONFIG else OpenType := INTERNET_OPEN_TYPE_PROXY; fSession := InternetOpenA(Pointer(fExtendedOptions.UserAgent), OpenType, pointer(fProxyName), pointer(fProxyByPass), 0); if fSession=nil then raise EWinINet.Create; InternetSetOption(fConnection,INTERNET_OPTION_CONNECT_TIMEOUT, @ConnectionTimeOut,SizeOf(ConnectionTimeOut)); InternetSetOption(fConnection,INTERNET_OPTION_SEND_TIMEOUT, @SendTimeout,SizeOf(SendTimeout)); InternetSetOption(fConnection,INTERNET_OPTION_RECEIVE_TIMEOUT, @ReceiveTimeout,SizeOf(ReceiveTimeout)); fConnection := InternetConnectA(fSession, pointer(fServer), fPort, nil, nil, INTERNET_SERVICE_HTTP, 0, 0); if fConnection=nil then raise EWinINet.Create; end; function TWinINet.InternalGetInfo(Info: DWORD): SockString; var dwSize, dwIndex: DWORD; begin result := ''; dwSize := 0; dwIndex := 0; if not HttpQueryInfoA(fRequest, Info, nil, dwSize, dwIndex) and (GetLastError=ERROR_INSUFFICIENT_BUFFER) then begin SetLength(result,dwSize-1); if not HttpQueryInfoA(fRequest, Info, pointer(result), dwSize, dwIndex) then result := ''; end; end; function TWinINet.InternalGetInfo32(Info: DWORD): DWORD; var dwSize, dwIndex: DWORD; begin dwSize := sizeof(result); dwIndex := 0; Info := Info or HTTP_QUERY_FLAG_NUMBER; if not HttpQueryInfoA(fRequest, Info, @result, dwSize, dwIndex) then result := 0; end; function TWinINet.InternalQueryDataAvailable: DWORD; begin if not InternetQueryDataAvailable(fRequest, Result, 0, 0) then raise EWinINet.Create; end; function TWinINet.InternalReadData(var Data: SockString; Read: integer; Size: cardinal): cardinal; begin if not InternetReadFile(fRequest, @PByteArray(Data)[Read], Size, result) then raise EWinINet.Create; end; procedure TWinINet.InternalCreateRequest(const aMethod,aURL: SockString); const ALL_ACCEPT: array[0..1] of PAnsiChar = ('*/*',nil); ACCEPT_TYPES: array[boolean] of PLPSTR = (@ALL_ACCEPT,nil); var Flags: DWORD; begin Flags := INTERNET_FLAG_HYPERLINK or INTERNET_FLAG_PRAGMA_NOCACHE or INTERNET_FLAG_RESYNCHRONIZE; // options for a true RESTful request if fKeepAlive<>0 then Flags := Flags or INTERNET_FLAG_KEEP_CONNECTION; if fHttps then Flags := Flags or INTERNET_FLAG_SECURE; FRequest := HttpOpenRequestA(FConnection,Pointer(aMethod),Pointer(aURL), nil,nil,ACCEPT_TYPES[fNoAllAccept],Flags,0); if FRequest=nil then raise EWinINet.Create; end; procedure TWinINet.InternalSendRequest(const aMethod,aData: SockString); var buff: TInternetBuffersA; datapos, datalen, max, Bytes, BytesWritten: DWORD; begin datalen := length(aData); if (datalen>0) and Assigned(fOnUpload) then begin FillChar(buff,SizeOf(buff),0); buff.dwStructSize := SizeOf(buff); buff.dwBufferTotal := Length(aData); if not HttpSendRequestExA(fRequest,@buff,nil,0,0) then raise EWinINet.Create; datapos := 0; while dataposmax then Bytes := max; if not InternetWriteFile(fRequest,@PByteArray(aData)[datapos],Bytes,BytesWritten) then raise EWinINet.Create; inc(datapos, BytesWritten); if not fOnUpload(Self,datapos,datalen) then raise EWinINet.CreateFmt('OnUpload Canceled %s',[aMethod]); end; if not HttpEndRequest(fRequest, nil, 0, 0) then raise EWinINet.Create; end else // blocking send with no callback if not HttpSendRequestA(fRequest,nil,0,pointer(aData),length(aData)) then raise EWinINet.Create; end; { TWinHTTP } const winhttpdll = 'winhttp.dll'; WINHTTP_ACCESS_TYPE_DEFAULT_PROXY = 0; WINHTTP_ACCESS_TYPE_NO_PROXY = 1; WINHTTP_ACCESS_TYPE_NAMED_PROXY = 3; WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY = 4; // Windows 8.1 and newer WINHTTP_FLAG_BYPASS_PROXY_CACHE = $00000100; // add "pragma: no-cache" request header WINHTTP_FLAG_REFRESH = WINHTTP_FLAG_BYPASS_PROXY_CACHE; WINHTTP_FLAG_SECURE = $00800000; // use SSL if applicable (HTTPS) WINHTTP_ADDREQ_FLAG_COALESCE = $40000000; WINHTTP_QUERY_FLAG_NUMBER = $20000000; // taken from http://www.tek-tips.com/faqs.cfm?fid=7493 // status manifests for WinHttp status callback WINHTTP_CALLBACK_STATUS_RESOLVING_NAME = $00000001; WINHTTP_CALLBACK_STATUS_NAME_RESOLVED = $00000002; WINHTTP_CALLBACK_STATUS_CONNECTING_TO_SERVER = $00000004; WINHTTP_CALLBACK_STATUS_CONNECTED_TO_SERVER = $00000008; WINHTTP_CALLBACK_STATUS_SENDING_REQUEST = $00000010; WINHTTP_CALLBACK_STATUS_REQUEST_SENT = $00000020; WINHTTP_CALLBACK_STATUS_RECEIVING_RESPONSE = $00000040; WINHTTP_CALLBACK_STATUS_RESPONSE_RECEIVED = $00000080; WINHTTP_CALLBACK_STATUS_CLOSING_CONNECTION = $00000100; WINHTTP_CALLBACK_STATUS_CONNECTION_CLOSED = $00000200; WINHTTP_CALLBACK_STATUS_HANDLE_CREATED = $00000400; WINHTTP_CALLBACK_STATUS_HANDLE_CLOSING = $00000800; WINHTTP_CALLBACK_STATUS_DETECTING_PROXY = $00001000; WINHTTP_CALLBACK_STATUS_REDIRECT = $00004000; WINHTTP_CALLBACK_STATUS_INTERMEDIATE_RESPONSE = $00008000; WINHTTP_CALLBACK_STATUS_SECURE_FAILURE = $00010000; WINHTTP_CALLBACK_STATUS_HEADERS_AVAILABLE = $00020000; WINHTTP_CALLBACK_STATUS_DATA_AVAILABLE = $00040000; WINHTTP_CALLBACK_STATUS_READ_COMPLETE = $00080000; WINHTTP_CALLBACK_STATUS_WRITE_COMPLETE = $00100000; WINHTTP_CALLBACK_STATUS_REQUEST_ERROR = $00200000; WINHTTP_CALLBACK_STATUS_SENDREQUEST_COMPLETE = $00400000; WINHTTP_CALLBACK_FLAG_RESOLVE_NAME = (WINHTTP_CALLBACK_STATUS_RESOLVING_NAME or WINHTTP_CALLBACK_STATUS_NAME_RESOLVED); WINHTTP_CALLBACK_FLAG_CONNECT_TO_SERVER = (WINHTTP_CALLBACK_STATUS_CONNECTING_TO_SERVER or WINHTTP_CALLBACK_STATUS_CONNECTED_TO_SERVER); WINHTTP_CALLBACK_FLAG_SEND_REQUEST = (WINHTTP_CALLBACK_STATUS_SENDING_REQUEST or WINHTTP_CALLBACK_STATUS_REQUEST_SENT); WINHTTP_CALLBACK_FLAG_RECEIVE_RESPONSE = (WINHTTP_CALLBACK_STATUS_RECEIVING_RESPONSE or WINHTTP_CALLBACK_STATUS_RESPONSE_RECEIVED); WINHTTP_CALLBACK_FLAG_CLOSE_CONNECTION = (WINHTTP_CALLBACK_STATUS_CLOSING_CONNECTION or WINHTTP_CALLBACK_STATUS_CONNECTION_CLOSED); WINHTTP_CALLBACK_FLAG_HANDLES = (WINHTTP_CALLBACK_STATUS_HANDLE_CREATED or WINHTTP_CALLBACK_STATUS_HANDLE_CLOSING); WINHTTP_CALLBACK_FLAG_DETECTING_PROXY = WINHTTP_CALLBACK_STATUS_DETECTING_PROXY; WINHTTP_CALLBACK_FLAG_REDIRECT = WINHTTP_CALLBACK_STATUS_REDIRECT; WINHTTP_CALLBACK_FLAG_INTERMEDIATE_RESPONSE = WINHTTP_CALLBACK_STATUS_INTERMEDIATE_RESPONSE; WINHTTP_CALLBACK_FLAG_SECURE_FAILURE = WINHTTP_CALLBACK_STATUS_SECURE_FAILURE; WINHTTP_CALLBACK_FLAG_SENDREQUEST_COMPLETE = WINHTTP_CALLBACK_STATUS_SENDREQUEST_COMPLETE; WINHTTP_CALLBACK_FLAG_HEADERS_AVAILABLE = WINHTTP_CALLBACK_STATUS_HEADERS_AVAILABLE; WINHTTP_CALLBACK_FLAG_DATA_AVAILABLE = WINHTTP_CALLBACK_STATUS_DATA_AVAILABLE; WINHTTP_CALLBACK_FLAG_READ_COMPLETE = WINHTTP_CALLBACK_STATUS_READ_COMPLETE; WINHTTP_CALLBACK_FLAG_WRITE_COMPLETE = WINHTTP_CALLBACK_STATUS_WRITE_COMPLETE; WINHTTP_CALLBACK_FLAG_REQUEST_ERROR = WINHTTP_CALLBACK_STATUS_REQUEST_ERROR; WINHTTP_CALLBACK_FLAG_ALL_COMPLETIONS = (WINHTTP_CALLBACK_STATUS_SENDREQUEST_COMPLETE or WINHTTP_CALLBACK_STATUS_HEADERS_AVAILABLE or WINHTTP_CALLBACK_STATUS_DATA_AVAILABLE or WINHTTP_CALLBACK_STATUS_READ_COMPLETE or WINHTTP_CALLBACK_STATUS_WRITE_COMPLETE or WINHTTP_CALLBACK_STATUS_REQUEST_ERROR); WINHTTP_CALLBACK_FLAG_ALL_NOTIFICATIONS = $ffffffff; WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 = $00000008; WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 = $00000020; WINHTTP_FLAG_SECURE_PROTOCOL_TLS1 = $00000080; // tls 1.1 & 1.2 const from here: // https://github.com/nihon-tc/Rtest/blob/master/header/Microsoft%20SDKs/Windows/v7.0A/Include/winhttp.h WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1 = $00000200; WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2 = $00000800; // Sets an unsigned long integer value that specifies which secure protocols are acceptable. // By default only SSL3 and TLS1 are enabled in Windows 7 and Windows 8. // By default only SSL3, TLS1.0, TLS1.1, and TLS1.2 are enabled in Windows 8.1 and Windows 10. WINHTTP_OPTION_SECURE_PROTOCOLS = 84; // Instructs the stack to start a WebSocket handshake process with WinHttpSendRequest. // This option takes no parameters. WINHTTP_OPTION_UPGRADE_TO_WEB_SOCKET = 114; // if the following value is returned by WinHttpSetStatusCallback, then // probably an invalid (non-code) address was supplied for the callback WINHTTP_INVALID_STATUS_CALLBACK = -1; WINHTTP_OPTION_DISABLE_FEATURE = 63; // values for WINHTTP_OPTION_DISABLE_FEATURE WINHTTP_DISABLE_COOKIES = $00000001; WINHTTP_DISABLE_REDIRECTS = $00000002; WINHTTP_DISABLE_AUTHENTICATION = $00000004; WINHTTP_DISABLE_KEEP_ALIVE = $00000008; WINHTTP_OPTION_ENABLE_FEATURE = 79; // values for WINHTTP_OPTION_ENABLE_FEATURE WINHTTP_ENABLE_SSL_REVOCATION = $00000001; WINHTTP_ENABLE_SSL_REVERT_IMPERSONATION = $00000002; type WINHTTP_STATUS_CALLBACK = procedure(hInternet: HINTERNET; dwContext: PDWORD; dwInternetStatus: DWORD; lpvStatusInformation: pointer; dwStatusInformationLength: DWORD); stdcall; PWINHTTP_STATUS_CALLBACK = ^WINHTTP_STATUS_CALLBACK; /// direct late-binding access to the WinHTTP API // - note: WebSocket* API calls require Windows 8 and later TWinHTTPBinding = packed record /// access to the winhttp.dll loaded library LibraryHandle: THandle; /// depends on the published .dll functions WebSocketEnabled: Boolean; /// Initializes an application's use of the WinHTTP functions. Open: function(pwszUserAgent: PWideChar; dwAccessType: DWORD; pwszProxyName, pwszProxyBypass: PWideChar; dwFlags: DWORD): HINTERNET; stdcall; /// Sets up a callback function that WinHTTP can call as progress is made during an operation. SetStatusCallback: function(hSession: HINTERNET; lpfnInternetCallback: WINHTTP_STATUS_CALLBACK; dwNotificationFlags: DWORD; dwReserved: PDWORD): WINHTTP_STATUS_CALLBACK; stdcall; /// Specifies the initial target server of an HTTP request. Connect: function(hSession: HINTERNET; pswzServerName: PWideChar; nServerPort: INTERNET_PORT; dwReserved: DWORD): HINTERNET; stdcall; /// Creates an HTTP request handle. OpenRequest: function(hConnect: HINTERNET; pwszVerb: PWideChar; pwszObjectName: PWideChar; pwszVersion: PWideChar; pwszReferer: PWideChar; ppwszAcceptTypes: PLPWSTR; dwFlags: DWORD): HINTERNET; stdcall; /// Closes a single HINTERNET handle. CloseHandle: function(hInternet: HINTERNET): BOOL; stdcall; /// Adds one or more HTTP request headers to the HTTP request handle. AddRequestHeaders: function(hRequest: HINTERNET; pwszHeaders: PWideChar; dwHeadersLength: DWORD; dwModifiers: DWORD): BOOL; stdcall; /// Sends the specified request to the HTTP server. SendRequest: function(hRequest: HINTERNET; pwszHeaders: PWideChar; dwHeadersLength: DWORD; lpOptional: Pointer; dwOptionalLength: DWORD; dwTotalLength: DWORD; dwContext: DWORD): BOOL; stdcall; /// Ends an HTTP request that is initiated by WinHttpSendRequest. ReceiveResponse: function(hRequest: HINTERNET; lpReserved: Pointer): BOOL; stdcall; /// Retrieves header information associated with an HTTP request. QueryHeaders: function(hRequest: HINTERNET; dwInfoLevel: DWORD; pwszName: PWideChar; lpBuffer: Pointer; var lpdwBufferLength, lpdwIndex: DWORD): BOOL; stdcall; /// Returns the amount of data, in bytes, available to be read with WinHttpReadData. QueryDataAvailable: function(hRequest: HINTERNET; var lpdwNumberOfBytesAvailable: DWORD): BOOL; stdcall; /// Reads data from a handle opened by the WinHttpOpenRequest function. ReadData: function(hRequest: HINTERNET; lpBuffer: Pointer; dwNumberOfBytesToRead: DWORD; var lpdwNumberOfBytesRead: DWORD): BOOL; stdcall; /// Sets the various time-outs that are involved with HTTP transactions. SetTimeouts: function(hInternet: HINTERNET; dwResolveTimeout: DWORD; dwConnectTimeout: DWORD; dwSendTimeout: DWORD; dwReceiveTimeout: DWORD): BOOL; stdcall; /// Sets an Internet option. SetOption: function(hInternet: HINTERNET; dwOption: DWORD; lpBuffer: Pointer; dwBufferLength: DWORD): BOOL; stdcall; /// Passes the required authorization credentials to the server. SetCredentials: function(hRequest: HINTERNET; AuthTargets: DWORD; AuthScheme: DWORD; pwszUserName: PWideChar; pwszPassword: PWideChar; pAuthParams: Pointer) : BOOL; stdcall; /// Completes a WebSocket handshake started by WinHttpSendRequest. WebSocketCompleteUpgrade: function(hRequest: HINTERNET; lpReserved: Pointer): HINTERNET; stdcall; /// Closes a WebSocket connection. WebSocketClose: function(hWebSocket: HINTERNET; usStatus: Word; pvReason: Pointer; dwReasonLength: DWORD): DWORD; stdcall; /// Retrieves the close status sent by a server WebSocketQueryCloseStatus: function(hWebSocket: HINTERNET; out usStatus: Word; pvReason: Pointer; dwReasonLength: DWORD; out dwReasonLengthConsumed: DWORD): DWORD; stdcall; /// Sends data over a WebSocket connection. WebSocketSend: function(hWebSocket: HINTERNET; eBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE; pvBuffer: Pointer; dwBufferLength: DWORD): DWORD; stdcall; /// Receives data from a WebSocket connection. WebSocketReceive: function(hWebSocket: HINTERNET; pvBuffer: Pointer; dwBufferLength: DWORD; out dwBytesRead: DWORD; out eBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE): DWORD; stdcall; /// Writes data to a handle opened by the WinHttpOpenRequest function. WriteData: function(hRequest: HINTERNET; lpBuffer: Pointer; dwNumberOfBytesToWrite: DWORD; var lpdwNumberOfBytesWritten: DWORD): BOOL; stdcall; end; var WinHttpAPI: TWinHTTPBinding; type TWinHttpAPIs = (hOpen, hSetStatusCallback, hConnect, hOpenRequest, hCloseHandle, hAddRequestHeaders, hSendRequest, hReceiveResponse, hQueryHeaders, hQueryDataAvailable, hReadData, hSetTimeouts, hSetOption, hSetCredentials, hWebSocketCompleteUpgrade, hWebSocketClose, hWebSocketQueryCloseStatus, hWebSocketSend, hWebSocketReceive, hWriteData); const hWebSocketApiFirst = hWebSocketCompleteUpgrade; const WinHttpNames: array[TWinHttpAPIs] of PChar = ( 'WinHttpOpen', 'WinHttpSetStatusCallback', 'WinHttpConnect', 'WinHttpOpenRequest', 'WinHttpCloseHandle', 'WinHttpAddRequestHeaders', 'WinHttpSendRequest', 'WinHttpReceiveResponse', 'WinHttpQueryHeaders', 'WinHttpQueryDataAvailable', 'WinHttpReadData', 'WinHttpSetTimeouts', 'WinHttpSetOption', 'WinHttpSetCredentials', 'WinHttpWebSocketCompleteUpgrade', 'WinHttpWebSocketClose', 'WinHttpWebSocketQueryCloseStatus', 'WinHttpWebSocketSend', 'WinHttpWebSocketReceive', 'WinHttpWriteData'); procedure WinHttpAPIInitialize; var api: TWinHttpAPIs; P: PPointer; begin if WinHttpAPI.LibraryHandle<>0 then exit; // already loaded WinHttpAPI.LibraryHandle := SafeLoadLibrary(winhttpdll); WinHttpAPI.WebSocketEnabled := true; // WebSocketEnabled if all functions are available if WinHttpAPI.LibraryHandle=0 then raise ECrtSocket.CreateFmt('Unable to load library %s',[winhttpdll]); P := @@WinHttpAPI.Open; for api := low(api) to high(api) do begin P^ := GetProcAddress(WinHttpAPI.LibraryHandle,WinHttpNames[api]); if P^=nil then if apinil then WinHttpAPI.CloseHandle(fConnection); if fSession<>nil then WinHttpAPI.CloseHandle(fSession); inherited; end; procedure TWinHTTP.InternalAddHeader(const hdr: SockString); begin if (hdr<>'') and not WinHttpAPI.AddRequestHeaders( FRequest, Pointer(Ansi7ToUnicode(hdr)), length(hdr), WINHTTP_ADDREQ_FLAG_COALESCE) then RaiseLastModuleError(winhttpdll,EWinHTTP); end; procedure TWinHTTP.InternalCloseRequest; begin if fRequest<>nil then begin WinHttpAPI.CloseHandle(fRequest); FRequest := nil; end; end; procedure WinHTTPSecurityErrorCallback(hInternet: HINTERNET; dwContext: PDWORD; dwInternetStatus: DWORD; lpvStatusInformation: pointer; dwStatusInformationLength: DWORD); stdcall; var err: string; code: DWORD; begin code := PDWORD(lpvStatusInformation)^; if code and $00000001<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_REV_FAILED'; if code and $00000002<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CERT'; if code and $00000004<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_REVOKED'; if code and $00000008<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_INVALID_CA'; if code and $00000010<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_CN_INVALID'; if code and $00000020<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_DATE_INVALID'; if code and $00000040<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_CERT_WRONG_USAGE'; if code and $80000000<>0 then err := err+' WINHTTP_CALLBACK_STATUS_FLAG_SECURITY_CHANNEL_ERROR'; // in case lpvStatusInformation^=-2147483648 this is attempt to connect to // non-https socket wrong port - perhaps must be 443? raise EWinHTTP.CreateFmt('WinHTTP security error. Status %d, StatusInfo: %d ($%x%s)', [dwInternetStatus, code, code, err]); end; {$ifndef UNICODE} type /// not defined in older Delphi versions TOSVersionInfoEx = record dwOSVersionInfoSize: DWORD; dwMajorVersion: DWORD; dwMinorVersion: DWORD; dwBuildNumber: DWORD; dwPlatformId: DWORD; szCSDVersion: array[0..127] of char; wServicePackMajor: WORD; wServicePackMinor: WORD; wSuiteMask: WORD; wProductType: BYTE; wReserved: BYTE; end; function GetVersionEx(var lpVersionInformation: TOSVersionInfoEx): BOOL; stdcall; external kernel32 name 'GetVersionExA'; {$endif} var // raw OS call, to avoid dependency to SynCommons.pas unit OSVersionInfo: TOSVersionInfoEx; function TWinHTTP.InternalGetProtocols: cardinal; begin // WINHTTP_FLAG_SECURE_PROTOCOL_SSL2 and WINHTTP_FLAG_SECURE_PROTOCOL_SSL3 // are unsafe, disabled at Windows level, therefore never supplied result := WINHTTP_FLAG_SECURE_PROTOCOL_TLS1; // Windows 7 and newer support TLS 1.1 & 1.2 if (OSVersionInfo.dwMajorVersion>6) or ((OSVersionInfo.dwMajorVersion=6) and (OSVersionInfo.dwMinorVersion>=1)) then result := result or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_1 or WINHTTP_FLAG_SECURE_PROTOCOL_TLS1_2; end; procedure TWinHTTP.InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); var OpenType: integer; Callback: WINHTTP_STATUS_CALLBACK; CallbackRes: PtrInt absolute Callback; // for FPC compatibility protocols: DWORD; begin if OSVersionInfo.dwOSVersionInfoSize=0 then begin // API call once OSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo); GetVersionEx(OSVersionInfo); end; if fProxyName='' then if (OSVersionInfo.dwMajorVersion>6) or ((OSVersionInfo.dwMajorVersion=6) and (OSVersionInfo.dwMinorVersion>=3)) then OpenType := WINHTTP_ACCESS_TYPE_AUTOMATIC_PROXY else // Windows 8.1 and newer OpenType := WINHTTP_ACCESS_TYPE_NO_PROXY else OpenType := WINHTTP_ACCESS_TYPE_NAMED_PROXY; fSession := WinHttpAPI.Open(pointer(Ansi7ToUnicode(fExtendedOptions.UserAgent)), OpenType, pointer(Ansi7ToUnicode(fProxyName)), pointer(Ansi7ToUnicode(fProxyByPass)), 0); if fSession=nil then RaiseLastModuleError(winhttpdll,EWinHTTP); // cf. http://msdn.microsoft.com/en-us/library/windows/desktop/aa384116 if not WinHttpAPI.SetTimeouts(fSession,HTTP_DEFAULT_RESOLVETIMEOUT, ConnectionTimeOut,SendTimeout,ReceiveTimeout) then RaiseLastModuleError(winhttpdll,EWinHTTP); if fHTTPS then begin protocols := InternalGetProtocols; if not WinHttpAPI.SetOption(fSession, WINHTTP_OPTION_SECURE_PROTOCOLS, @protocols, SizeOf(protocols)) then RaiseLastModuleError(winhttpdll,EWinHTTP); Callback := WinHttpAPI.SetStatusCallback(fSession, WinHTTPSecurityErrorCallback, WINHTTP_CALLBACK_FLAG_SECURE_FAILURE, nil); if CallbackRes=WINHTTP_INVALID_STATUS_CALLBACK then RaiseLastModuleError(winhttpdll,EWinHTTP); end; fConnection := WinHttpAPI.Connect(fSession, pointer(Ansi7ToUnicode(FServer)), fPort, 0); if fConnection=nil then RaiseLastModuleError(winhttpdll,EWinHTTP); end; function TWinHTTP.InternalGetInfo(Info: DWORD): SockString; var dwSize, dwIndex: DWORD; tmp: SockString; i: integer; begin result := ''; dwSize := 0; dwIndex := 0; if not WinHttpAPI.QueryHeaders(fRequest, Info, nil, nil, dwSize, dwIndex) and (GetLastError=ERROR_INSUFFICIENT_BUFFER) then begin SetLength(tmp,dwSize); if WinHttpAPI.QueryHeaders(fRequest, Info, nil, pointer(tmp), dwSize, dwIndex) then begin dwSize := dwSize shr 1; SetLength(result,dwSize); for i := 0 to dwSize-1 do // fast ANSI 7 bit conversion PByteArray(result)^[i] := PWordArray(tmp)^[i]; end; end; end; function TWinHTTP.InternalGetInfo32(Info: DWORD): DWORD; var dwSize, dwIndex: DWORD; begin dwSize := sizeof(result); dwIndex := 0; Info := Info or WINHTTP_QUERY_FLAG_NUMBER; if not WinHttpAPI.QueryHeaders(fRequest, Info, nil, @result, dwSize, dwIndex) then result := 0; end; function TWinHTTP.InternalQueryDataAvailable: DWORD; begin if not WinHttpAPI.QueryDataAvailable(fRequest, result) then RaiseLastModuleError(winhttpdll,EWinHTTP); end; function TWinHTTP.InternalReadData(var Data: SockString; Read: integer; Size: cardinal): cardinal; begin if not WinHttpAPI.ReadData(fRequest, @PByteArray(Data)[Read], Size, result) then RaiseLastModuleError(winhttpdll,EWinHTTP); end; procedure TWinHTTP.InternalCreateRequest(const aMethod,aURL: SockString); const ALL_ACCEPT: array[0..1] of PWideChar = ('*/*',nil); ACCEPT_TYPES: array[boolean] of PLPWSTR = (@ALL_ACCEPT,nil); var Flags: DWORD; begin Flags := WINHTTP_FLAG_REFRESH; // options for a true RESTful request if fHttps then Flags := Flags or WINHTTP_FLAG_SECURE; fRequest := WinHttpAPI.OpenRequest(fConnection,pointer(Ansi7ToUnicode(aMethod)), pointer(Ansi7ToUnicode(aURL)),nil,nil,ACCEPT_TYPES[fNoAllAccept],Flags); if fRequest=nil then RaiseLastModuleError(winhttpdll,EWinHTTP); if fKeepAlive = 0 then begin Flags := WINHTTP_DISABLE_KEEP_ALIVE; if not WinHttpAPI.SetOption(fRequest, WINHTTP_OPTION_DISABLE_FEATURE, @Flags, sizeOf(Flags)) then RaiseLastModuleError(winhttpdll,EWinHTTP); end; end; const // from http://www.tek-tips.com/faqs.cfm?fid=7493 WINHTTP_OPTION_SECURITY_FLAGS = 31; WINHTTP_OPTION_CLIENT_CERT_CONTEXT = $0000002F; WINHTTP_NO_CLIENT_CERT_CONTEXT = $00000000; ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED = $00002F0C; SECURITY_FLAG_IGNORE_UNKNOWN_CA = $00000100; SECURITY_FLAG_IGNORE_CERT_DATE_INVALID = $00002000; // expired X509 Cert. SECURITY_FLAG_IGNORE_CERT_CN_INVALID = $00001000; // bad common name in X509 Cert. SECURITY_FLAG_IGNORE_CERT_WRONG_USAGE = $00000200; SECURITY_FLAT_IGNORE_CERTIFICATES: DWORD = SECURITY_FLAG_IGNORE_UNKNOWN_CA or SECURITY_FLAG_IGNORE_CERT_DATE_INVALID or SECURITY_FLAG_IGNORE_CERT_CN_INVALID or SECURITY_FLAG_IGNORE_CERT_WRONG_USAGE; WINHTTP_AUTH_TARGET_SERVER = 0; WINHTTP_AUTH_TARGET_PROXY = 1; WINHTTP_AUTH_SCHEME_BASIC = $00000001; WINHTTP_AUTH_SCHEME_NTLM = $00000002; WINHTTP_AUTH_SCHEME_PASSPORT = $00000004; WINHTTP_AUTH_SCHEME_DIGEST = $00000008; WINHTTP_AUTH_SCHEME_NEGOTIATE = $00000010; procedure TWinHTTP.InternalSendRequest(const aMethod,aData: SockString); function _SendRequest(L: DWORD): Boolean; var Bytes, Current, Max, BytesWritten: DWORD; begin if Assigned(fOnUpload) and (SameText(aMethod,'POST') or SameText(aMethod,'PUT')) then begin result := WinHttpAPI.SendRequest(fRequest,nil,0,nil,0,L,0); if result then begin Current := 0; while CurrentMax then Bytes := Max; if not WinHttpAPI.WriteData(fRequest, @PByteArray(aData)[Current],Bytes,BytesWritten) then RaiseLastModuleError(winhttpdll,EWinHTTP); inc(Current,BytesWritten); if not fOnUpload(Self,Current,L) then raise EWinHTTP.CreateFmt('OnUpload Canceled %s',[aMethod]); end; end; end else result := WinHttpAPI.SendRequest(fRequest,nil,0,pointer(aData),L,L,0); end; var L: integer; winAuth: DWORD; begin with fExtendedOptions do if AuthScheme<>wraNone then begin case AuthScheme of wraBasic: winAuth := WINHTTP_AUTH_SCHEME_BASIC; wraDigest: winAuth := WINHTTP_AUTH_SCHEME_DIGEST; wraNegotiate: winAuth := WINHTTP_AUTH_SCHEME_NEGOTIATE; else raise EWinHTTP.CreateFmt('Unsupported AuthScheme=%d',[ord(AuthScheme)]); end; if not WinHttpAPI.SetCredentials(fRequest,WINHTTP_AUTH_TARGET_SERVER, winAuth,pointer(AuthUserName),pointer(AuthPassword),nil) then RaiseLastModuleError(winhttpdll,EWinHTTP); end; if fHTTPS and IgnoreSSLCertificateErrors then if not WinHttpAPI.SetOption(fRequest, WINHTTP_OPTION_SECURITY_FLAGS, @SECURITY_FLAT_IGNORE_CERTIFICATES, SizeOf(SECURITY_FLAT_IGNORE_CERTIFICATES)) then RaiseLastModuleError(winhttpdll,EWinHTTP); L := length(aData); if not _SendRequest(L) or not WinHttpAPI.ReceiveResponse(fRequest,nil) then if fHTTPS and (GetLastError=ERROR_WINHTTP_CLIENT_AUTH_CERT_NEEDED) and IgnoreSSLCertificateErrors then begin if not WinHttpAPI.SetOption(fRequest,WINHTTP_OPTION_SECURITY_FLAGS, @SECURITY_FLAT_IGNORE_CERTIFICATES,SizeOf(SECURITY_FLAT_IGNORE_CERTIFICATES)) then RaiseLastModuleError(winhttpdll,EWinHTTP); if not WinHttpAPI.SetOption(fRequest,WINHTTP_OPTION_CLIENT_CERT_CONTEXT, pointer(WINHTTP_NO_CLIENT_CERT_CONTEXT),0) then RaiseLastModuleError(winhttpdll,EWinHTTP); if not _SendRequest(L) or not WinHttpAPI.ReceiveResponse(fRequest,nil) then RaiseLastModuleError(winhttpdll,EWinHTTP); end else RaiseLastModuleError(winhttpdll,EWinHTTP); end; { TWinHTTPUpgradeable } constructor TWinHTTPUpgradeable.Create(const aServer, aPort: SockString; aHttps: boolean; const aProxyName, aProxyByPass: SockString; ConnectionTimeOut, SendTimeout, ReceiveTimeout: DWORD; aLayer: TCrtSocketLayer); begin inherited; fSocket := nil; end; function TWinHTTPUpgradeable.InternalRetrieveAnswer(var Header, Encoding, AcceptEncoding, Data: SockString): integer; begin result := inherited InternalRetrieveAnswer(Header, Encoding, AcceptEncoding, Data); fSocket := WinHttpAPI.WebSocketCompleteUpgrade(fRequest, nil); if fSocket=nil then raise EWinHTTP.Create('Error upgrading socket'); end; procedure TWinHTTPUpgradeable.InternalSendRequest(const aMethod,aData: SockString); begin if not WinHttpAPI.SetOption(fRequest,WINHTTP_OPTION_UPGRADE_TO_WEB_SOCKET,nil,0) then raise EWinHTTP.Create('Error upgrading socket'); inherited; end; { TWinHTTPWinSocketClient } function TWinHTTPWebSocketClient.CheckSocket: Boolean; begin result := fSocket <> nil; end; function TWinHTTPWebSocketClient.CloseConnection(const aCloseReason: SockString): DWORD; begin if not CheckSocket then result := ERROR_INVALID_HANDLE else result := WinHttpAPI.WebSocketClose(fSocket, WEB_SOCKET_SUCCESS_CLOSE_STATUS, Pointer(aCloseReason), Length(aCloseReason)); if (Result = NO_ERROR) then fSocket := nil; end; constructor TWinHTTPWebSocketClient.Create(const aServer, aPort: SockString; aHttps: boolean; const url, aSubProtocol, aProxyName, aProxyByPass: SockString; ConnectionTimeOut, SendTimeout, ReceiveTimeout: DWORD); var _http: TWinHTTPUpgradeable; inH, outH, outD: SockString; begin fSocket := nil; _http := TWinHTTPUpgradeable.Create(aServer, aPort, aHttps, aProxyName, aProxyByPass, ConnectionTimeOut, SendTimeout, ReceiveTimeout); try // WebSocketAPI.BeginClientHandshake() if aSubProtocol <> '' then inH := sProtocolHeader + ': '+aSubProtocol else inH := ''; if _http.Request(url, 'GET', 0, inH, '', '', outH, outD) = 101 then fSocket := _http.fSocket else raise ECrtSocket.Create('WebSocketClient creation fail'); finally _http.Free; end; end; destructor TWinHTTPWebSocketClient.Destroy; const CloseReason: SockString = 'object is destroyed'; var status: Word; reason: SockString; reasonLength: DWORD; begin if CheckSocket then begin // todo: check result WinHttpAPI.WebSocketClose(fSocket, WEB_SOCKET_ABORTED_CLOSE_STATUS, Pointer(CloseReason), Length(CloseReason)); SetLength(reason, WEB_SOCKET_MAX_CLOSE_REASON_LENGTH); WinHttpAPI.WebSocketQueryCloseStatus(fSocket, status, Pointer(reason), WEB_SOCKET_MAX_CLOSE_REASON_LENGTH, reasonLength); WinHttpAPI.CloseHandle(fSocket); end; inherited; end; function TWinHTTPWebSocketClient.Receive(aBuffer: pointer; aBufferLength: DWORD; out aBytesRead: DWORD; out aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE): DWORD; begin if not CheckSocket then result := ERROR_INVALID_HANDLE else result := WinHttpAPI.WebSocketReceive(fSocket, aBuffer, aBufferLength, aBytesRead, aBufferType); end; function TWinHTTPWebSocketClient.Send(aBufferType: WINHTTP_WEB_SOCKET_BUFFER_TYPE; aBuffer: pointer; aBufferLength: DWORD): DWORD; begin if not CheckSocket then result := ERROR_INVALID_HANDLE else result := WinHttpAPI.WebSocketSend(fSocket, aBufferType, aBuffer, aBufferLength); end; {$endif USEWININET} {$ifdef USELIBCURL} { ************ libcurl implementation } { TCurlHTTP } procedure TCurlHTTP.InternalConnect(ConnectionTimeOut,SendTimeout,ReceiveTimeout: DWORD); const HTTPS: array[boolean] of string = ('','s'); begin if not IsAvailable then raise ECrtSocket.CreateFmt('No available %s',[LIBCURL_DLL]); fHandle := curl.easy_init; if curl.globalShare <> nil then curl.easy_setopt(fHandle,coShare,curl.globalShare); curl.easy_setopt(fHandle,coConnectTimeoutMs,ConnectionTimeOut); // default=300 ! if SendTimeout0 then // prevent send+receive forever curl.easy_setopt(fHandle,coTimeoutMs,SendTimeout); if fLayer=cslUNIX then fRootURL := 'http://localhost' else // see CURLOPT_UNIX_SOCKET_PATH doc fRootURL := AnsiString(Format('http%s://%s:%d',[HTTPS[fHttps],fServer,fPort])); end; destructor TCurlHTTP.Destroy; begin if fHandle<>nil then curl.easy_cleanup(fHandle); inherited; end; function TCurlHTTP.GetCACertFile: SockString; begin Result := fSSL.CACertFile; end; procedure TCurlHTTP.SetCACertFile(const aCertFile: SockString); begin fSSL.CACertFile := aCertFile; end; procedure TCurlHTTP.UseClientCertificate( const aCertFile, aCACertFile, aKeyName, aPassPhrase: SockString); begin fSSL.CertFile := aCertFile; fSSL.CACertFile := aCACertFile; fSSL.KeyName := aKeyName; fSSL.PassPhrase := aPassPhrase; end; procedure TCurlHTTP.InternalCreateRequest(const aMethod,aURL: SockString); const CERT_PEM: SockString = 'PEM'; begin fIn.URL := fRootURL+aURL; curl.easy_setopt(fHandle,coFollowLocation,1); // url redirection (as TWinHTTP) //curl.easy_setopt(fHandle,coTCPNoDelay,0); // disable Nagle if fLayer=cslUNIX then curl.easy_setopt(fHandle,coUnixSocketPath,pointer(fServer)); curl.easy_setopt(fHandle,coURL,pointer(fIn.URL)); if fProxyName<>'' then curl.easy_setopt(fHandle,coProxy,pointer(fProxyName)); if fHttps then if IgnoreSSLCertificateErrors then begin curl.easy_setopt(fHandle,coSSLVerifyPeer,0); curl.easy_setopt(fHandle,coSSLVerifyHost,0); //curl.easy_setopt(fHandle,coProxySSLVerifyPeer,0); //curl.easy_setopt(fHandle,coProxySSLVerifyHost,0); end else begin // see https://curl.haxx.se/libcurl/c/simplessl.html if fSSL.CertFile<>'' then begin curl.easy_setopt(fHandle,coSSLCertType,pointer(CERT_PEM)); curl.easy_setopt(fHandle,coSSLCert,pointer(fSSL.CertFile)); if fSSL.PassPhrase<>'' then curl.easy_setopt(fHandle,coSSLCertPasswd,pointer(fSSL.PassPhrase)); curl.easy_setopt(fHandle,coSSLKeyType,nil); curl.easy_setopt(fHandle,coSSLKey,pointer(fSSL.KeyName)); curl.easy_setopt(fHandle,coCAInfo,pointer(fSSL.CACertFile)); curl.easy_setopt(fHandle,coSSLVerifyPeer,1); end else if fSSL.CACertFile<>'' then curl.easy_setopt(fHandle,coCAInfo,pointer(fSSL.CACertFile)); end; curl.easy_setopt(fHandle,coUserAgent,pointer(fExtendedOptions.UserAgent)); curl.easy_setopt(fHandle,coWriteFunction,@CurlWriteRawByteString); curl.easy_setopt(fHandle,coHeaderFunction,@CurlWriteRawByteString); fIn.Method := UpperCase(aMethod); if fIn.Method = '' then fIn.Method := 'GET'; if fIn.Method = 'GET' then fIn.Headers := nil else // disable Expect 100 continue in libcurl fIn.Headers := curl.slist_append(nil,'Expect:'); Finalize(fOut); end; procedure TCurlHTTP.InternalAddHeader(const hdr: SockString); var P: PAnsiChar; s: SockString; begin P := pointer(hdr); while P<>nil do begin GetNextLine(P,s); if s<>'' then // nil would reset the whole list fIn.Headers := curl.slist_append(fIn.Headers,pointer(s)); end; end; class function TCurlHTTP.IsAvailable: boolean; begin Result := CurlIsAvailable; end; procedure TCurlHTTP.InternalSendRequest(const aMethod,aData: SockString); begin // see http://curl.haxx.se/libcurl/c/CURLOPT_CUSTOMREQUEST.html if fIn.Method='HEAD' then // the only verb what do not expect body in answer is HEAD curl.easy_setopt(fHandle,coNoBody,1) else curl.easy_setopt(fHandle,coNoBody,0); curl.easy_setopt(fHandle,coCustomRequest,pointer(fIn.Method)); curl.easy_setopt(fHandle,coPostFields,pointer(aData)); curl.easy_setopt(fHandle,coPostFieldSize,length(aData)); curl.easy_setopt(fHandle,coHTTPHeader,fIn.Headers); curl.easy_setopt(fHandle,coFile,@fOut.Data); curl.easy_setopt(fHandle,coWriteHeader,@fOut.Header); end; function TCurlHTTP.InternalRetrieveAnswer(var Header, Encoding, AcceptEncoding, Data: SockString): integer; var res: TCurlResult; P: PAnsiChar; s: SockString; i: integer; rc: longint; // needed on Linux x86-64 begin res := curl.easy_perform(fHandle); if res<>crOK then raise ECurlHTTP.CreateFmt('libcurl error %d (%s) on %s %s', [ord(res), curl.easy_strerror(res), fIn.Method, fIn.URL]); rc := 0; curl.easy_getinfo(fHandle,ciResponseCode,rc); result := rc; Header := Trim(fOut.Header); if IdemPChar(pointer(Header),'HTTP/') then begin i := 6; while Header[i]>=' ' do inc(i); while ord(Header[i]) in [10,13] do inc(i); system.Delete(Header,1,i-1); // trim leading 'HTTP/1.1 200 OK'#$D#$A end; P := pointer(Header); while P<>nil do begin GetNextLine(P,s); if IdemPChar(pointer(s),'ACCEPT-ENCODING:') then trimcopy(s,17,100,AcceptEncoding) else if IdemPChar(pointer(s),'CONTENT-ENCODING:') then trimcopy(s,18,100,Encoding); end; Data := fOut.Data; end; procedure TCurlHTTP.InternalCloseRequest; begin if fIn.Headers<>nil then begin curl.slist_free_all(fIn.Headers); fIn.Headers := nil; end; Finalize(fIn); fIn.DataOffset := 0; Finalize(fOut); end; {$endif USELIBCURL} { TSimpleHttpClient } constructor TSimpleHttpClient.Create(aOnlyUseClientSocket: boolean); begin fOnlyUseClientSocket := aOnlyUseClientSocket; inherited Create; end; destructor TSimpleHttpClient.Destroy; begin FreeAndNil(fHttp); FreeAndNil(fHttps); inherited Destroy; end; function TSimpleHttpClient.RawRequest(const Uri: TURI; const Method, Header, Data, DataType: SockString; KeepAlive: cardinal): integer; begin result := 0; if (Uri.Https or (Proxy <> '')) and not fOnlyUseClientSocket then try if (fHttps = nil) or (fHttps.Server <> Uri.Server) or (integer(fHttps.Port) <> Uri.PortInt) then begin FreeAndNil(fHttp); FreeAndNil(fHttps); // need a new HTTPS connection fHttps := MainHttpClass.Create(Uri.Server,Uri.Port,Uri.Https,Proxy,'',5000,5000,5000); fHttps.IgnoreSSLCertificateErrors := fIgnoreSSLCertificateErrors; if fUserAgent<>'' then fHttps.UserAgent := fUserAgent; end; result := fHttps.Request(Uri.Address,Method,KeepAlive, header,data,datatype,fHeaders,fBody); if KeepAlive = 0 then FreeAndNil(fHttps); except FreeAndNil(fHttps); end else try if (fHttp = nil) or (fHttp.Server <> Uri.Server) or (fHttp.Port <> Uri.Port) or (connectionClose in fHttp.HeaderFlags) then begin FreeAndNil(fHttps); FreeAndNil(fHttp); // need a new HTTP connection fHttp := THttpClientSocket.Open(Uri.Server,Uri.Port,cslTCP,5000,Uri.Https); if fUserAgent<>'' then fHttp.UserAgent := fUserAgent; end; if not fHttp.SockConnected then exit else result := fHttp.Request(Uri.Address,Method,KeepAlive,header,data,datatype,true); fBody := fHttp.Content; fHeaders := fHttp.HeaderGetText; if KeepAlive = 0 then FreeAndNil(fHttp); except FreeAndNil(fHttp); end; end; function TSimpleHttpClient.Request(const uri,method,header,data,datatype: SockString; keepalive: cardinal): integer; var u: TURI; begin if u.From(uri) then result := RawRequest(u,method,header,data,datatype,keepalive) else result := STATUS_NOTFOUND; end; { ************ socket polling for optimized multiple connections } { TPollSocketAbstract } {.$define USEWSAPOLL} // you may try it - but seems slightly SLOWER under Windows 7 function PollSocketClass: TPollSocketClass; begin {$ifdef LINUXNOTBSD} result := TPollSocketEpoll; // the preferred way for our purpose {$else} {$ifdef MSWINDOWS} {$ifdef USEWSAPOLL} if Win32MajorVersion>=6 then // WSAPoll() not available before Vista result := TPollSocketPoll else {$endif USEWSAPOLL} result := TPollSocketSelect; // Select() is FASTER than WSAPoll() :( {$else} result := TPollSocketPoll; // available on all POSIX systems {$endif MSWINDOWS} {$endif LINUXNOTBSD} end; constructor TPollSocketAbstract.Create; begin inherited Create; end; class function TPollSocketAbstract.New: TPollSocketAbstract; begin result := PollSocketClass.Create; end; {$ifdef MSWINDOWS} { TPollSocketSelect } constructor TPollSocketSelect.Create; begin inherited Create; fMaxSockets := FD_SETSIZE; // 64 end; function TPollSocketSelect.Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; begin result := false; if (self=nil) or (socket=0) or (byte(events)=0) or (fCount=fMaxSockets) then exit; if pseRead in events then FD_SET(socket, fRead); if pseWrite in events then FD_SET(socket, fWrite); fTag[fCount].socket := socket; fTag[fCount].tag := tag; inc(fCount); if socket>fHighestSocket then fHighestSocket := socket; result := true; end; function TPollSocketSelect.Unsubscribe(socket: TSocket): boolean; var i: integer; begin result := false; if (self<>nil) and (socket<>0) then for i := 0 to fCount-1 do if fTag[i].socket=socket then begin FD_CLR(socket,fRead); FD_CLR(socket,fWrite); dec(fCount); if i0 then begin rd := fRead; rdp := @rd; end else rdp := nil; if fWrite.fd_count>0 then begin wr := fWrite; wrp := @wr; end else wrp := nil; tv.tv_sec := timeoutMS div 1000; tv.tv_usec := (timeoutMS mod 1000)*1000; result := Select(fHighestSocket+1,rdp,wrp,nil,@tv); if result<=0 then exit; result := 0; for i := 0 to fCount-1 do with fTag[i] do begin byte(ev) := 0; if (rdp<>nil) and FD_ISSET(socket,rd) then begin if (IoctlSocket(socket,FIONREAD,pending)=0) and (pending=0) then // socket closed gracefully - see TCrtSocket.SockReceivePending include(ev,pseClosed) else include(ev,pseRead); end; if (wrp<>nil) and FD_ISSET(socket,wr) then include(ev,pseWrite); if byte(ev)<>0 then begin tmp[result].events := ev; tmp[result].tag := tag; inc(result); end; end; SetLength(results,result); move(tmp,results[0],result*sizeof(tmp[0])); end; {$endif MSWINDOWS} { TPollSocketPoll } constructor TPollSocketPoll.Create; begin inherited Create; {$ifdef MSWINDOWS} // some practical values fMaxSockets := 1024; {$else} fMaxSockets := 20000; {$endif} end; function TPollSocketPoll.Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; var i, n, e, fd: integer; begin result := false; if (self=nil) or (socket=0) or (byte(events)=0) or (fCount=fMaxSockets) then exit; if pseRead in events then e := POLLIN else e := 0; if pseWrite in events then e := e or POLLOUT; if fFDCount=fCount then begin // no void entry for i := 0 to fFDCount-1 do if fFD[i].fd=socket then // already subscribed exit; end else for i := 0 to fFDCount-1 do begin fd := fFD[i].fd; if fd=socket then // already subscribed exit else if fd<0 then begin // found void entry fTags[i] := tag; with fFD[i] do begin fd := socket; events := e; revents := 0; end; inc(fCount); result := true; exit; end; end; if fFDCount=length(fFD) then begin // add new entry to the array n := fFDCount+128+fFDCount shr 3; if n>fMaxSockets then n := fMaxSockets; SetLength(fFD,n); SetLength(fTags,n); end; with fFD[fFDCount] do begin fd := socket; events := e; revents := 0; end; fTags[fFDCount] := tag; inc(fFDCount); inc(fCount); result := true; end; procedure TPollSocketPoll.FDVacuum; var n, i: integer; begin n := 0; for i := 0 to fFDCount-1 do if fFD[i].fd>0 then begin if i<>n then begin fFD[n] := fFD[i]; fTags[n] := fTags[i]; end; inc(n); end; fFDCount := n; end; function TPollSocketPoll.Unsubscribe(socket: TSocket): boolean; var i: integer; begin for i := 0 to fFDCount-1 do if fFD[i].fd=socket then begin fFD[i].fd := -1; // mark entry as void dec(fCount); if fCount<=fFDCount shr 1 then FDVacuum; // avoid too many void entries result := true; exit; end; result := false; end; function TPollSocketPoll.WaitForModified(out results: TPollSocketResults; timeoutMS: integer): integer; var e: TPollSocketEvents; i, ev, d: integer; begin result := -1; // error if (self=nil) or (fCount=0) then exit; result := poll(pointer(fFD),fFDCount,timeoutMS); if result<=0 then exit; SetLength(results,result); d := 0; for i := 0 to fFDCount-1 do if fFD[i].fd>0 then begin ev := fFD[i].revents; if ev<>0 then begin byte(e) := 0; if ev and POLLIN<>0 then include(e,pseRead); if ev and POLLOUT<>0 then include(e,pseWrite); if ev and POLLERR<>0 then include(e,pseError); if ev and POLLHUP<>0 then include(e,pseClosed); results[d].events := e; results[d].tag := fTags[i]; inc(d); fFD[i].revents := 0; // reset result flags for reuse end; end; if d<>result then raise ECrtSocket.CreateFmt('TPollSocketPoll: result=%d d=%d',[result,d]); end; {$ifdef LINUXNOTBSD} { TPollSocketEpoll } constructor TPollSocketEpoll.Create; begin inherited Create; fEPFD := epoll_create($cafe); fMaxSockets := 20000; SetLength(fResults,fMaxSockets); end; destructor TPollSocketEpoll.Destroy; begin epoll_close(fEPFD); inherited; end; function TPollSocketEpoll.Subscribe(socket: TSocket; events: TPollSocketEvents; tag: TPollSocketTag): boolean; var e: TEPollEvent; begin result := false; if (self=nil) or (socket=0) or (socket=fEPFD) or (byte(events)=0) or (fCount=fMaxSockets) then exit; e.data.ptr := pointer(tag); if pseRead in events then e.events := EPOLLIN else e.events := 0; if pseWrite in events then e.events := e.events or EPOLLOUT; // EPOLLERR and EPOLLHUP are always implicitly defined result := epoll_ctl(fEPFD,EPOLL_CTL_ADD,socket,@e)=0; if result then inc(fCount); end; function TPollSocketEpoll.Unsubscribe(socket: TSocket): boolean; var e: TEPollEvent; // should be there even if not used begin if (self=nil) or (socket=0) or (socket=fEPFD) then result := false else begin result := epoll_ctl(fEPFD,EPOLL_CTL_DEL,socket,@e)=0; if result then dec(fCount); end; end; function TPollSocketEpoll.WaitForModified(out results: TPollSocketResults; timeoutMS: integer): integer; var e: TPollSocketEvents; i, ev: integer; begin result := -1; // error if (self=nil) or (fCount=0) then exit; result := epoll_wait(fEPFD,pointer(fResults),fMaxSockets,timeoutMS); if result<=0 then exit; SetLength(results,result); for i := 0 to result-1 do begin ev := fResults[i].events; byte(e) := 0; if ev and EPOLLIN<>0 then include(e,pseRead); if ev and EPOLLOUT<>0 then include(e,pseWrite); if ev and EPOLLERR<>0 then include(e,pseError); if ev and EPOLLHUP<>0 then include(e,pseClosed); results[i].events := e; results[i].tag := TPollSocketTag(fResults[i].data.ptr); end; end; {$endif LINUXNOTBSD} { TPollSockets } constructor TPollSockets.Create(aPollClass: TPollSocketClass=nil); begin inherited Create; InitializeCriticalSection(fPendingLock); InitializeCriticalSection(fPollLock); if aPollClass=nil then fPollClass := PollSocketClass else fPollClass := aPollClass; {$ifndef MSWINDOWS} SetFileOpenLimit(GetFileOpenLimit(true)); // set soft limit to hard value {$endif MSWINDOWS} end; destructor TPollSockets.Destroy; var p: integer; begin for p := 0 to high(fPoll) do fPoll[p].Free; DeleteCriticalSection(fPendingLock); DeleteCriticalSection(fPollLock); inherited Destroy; end; function TPollSockets.Subscribe(socket: TSocket; tag: TPollSocketTag; events: TPollSocketEvents): boolean; var p,n: integer; poll: TPollSocketAbstract; begin result := false; if (self=nil) or (socket=0) or (events=[]) then exit; EnterCriticalSection(fPollLock); try poll := nil; n := length(fPoll); for p := 0 to n-1 do if fPoll[p].Count0 then begin // void e.g. after Unsubscribe() result := true; exit; end; if fPending=nil then break; // end of list end; finally LeaveCriticalSection(fPendingLock); end; end; function TPollSockets.GetOne(timeoutMS: integer; out notif: TPollSocketResult): boolean; function PollAndSearchWithinPending(p: integer): boolean; begin if not fTerminated and (fPoll[p].WaitForModified(fPending,{timeout=}0)>0) then begin result := GetOneWithinPending(notif); if result then fPollIndex := p; // next call to continue from fPoll[fPollIndex+1] end else result := false; end; var p,n: integer; elapsed,start: Int64; begin result := false; byte(notif.events) := 0; if (timeoutMS<0) or fTerminated then exit; start := {$ifdef MSWINDOWS}GetTick64{$else}0{$endif}; repeat // non-blocking search within fPoll[] EnterCriticalSection(fPollLock); try // check if some already notified as pending in fPoll[] if GetOneWithinPending(notif) then exit; // calls fPoll[].WaitForModified({timeout=}0) to refresh pending state n := length(fPoll); if n>0 then begin for p := fPollIndex+1 to n-1 do // search from fPollIndex = last found if PollAndSearchWithinPending(p) then exit; for p := 0 to fPollIndex do // search from beginning up to fPollIndex if PollAndSearchWithinPending(p) then exit; end; finally LeaveCriticalSection(fPollLock); result := byte(notif.events)<>0; // exit would comes here and set result end; // wait a little for something to happen if fTerminated or (timeoutMS=0) then exit; {$ifndef MSWINDOWS} if start=0 then // measure time elapsed only if we wait start := GetTick64 else {$endif} begin elapsed := GetTick64-start; // allow multi-threaded process if elapsed>timeoutMS then exit else if elapsed>300 then SleepHiRes(50) else if elapsed>50 then SleepHiRes(10) else SleepHiRes(1); end; until fTerminated; end; procedure TPollSockets.Terminate; begin if self<>nil then fTerminated := true; end; { TPollSocketsSlot } function TPollSocketsSlot.Lock(writer: boolean): boolean; begin result := InterlockedIncrement(lockcounter[writer])=1; if not result then InterlockedDecrement(lockcounter[writer]); end; procedure TPollSocketsSlot.Unlock(writer: boolean); begin if @self<>nil then InterlockedDecrement(lockcounter[writer]); end; function TPollSocketsSlot.TryLock(writer: boolean; timeoutMS: cardinal): boolean; var endtix: Int64; ms: integer; begin result := (@self<>nil) and (socket<>0); if not result then exit; // socket closed result := Lock(writer); if result or (timeoutMS=0) then exit; // we acquired the slot, or we don't want to wait endtix := GetTick64+timeoutMS; // never wait forever ms := 0; repeat SleepHiRes(ms); ms := ms xor 1; // 0,1,0,1,0,1... if socket=0 then exit; // no socket to lock for result := Lock(writer); if result then begin result := socket<>0; if not result then UnLock(writer); exit; // acquired or socket closed end; until GetTick64>=endtix; end; { TPollAsynchSockets } constructor TPollAsynchSockets.Create; var c: TPollSocketClass; begin inherited Create; c := PollSocketClass; fRead := TPollSockets.Create(c); {$ifdef LINUXNOTBSD} c := TPollSocketPoll; // epoll is overkill for short-living writes {$endif} fWrite := TPollSockets.Create(c); end; destructor TPollAsynchSockets.Destroy; begin if not fRead.Terminated then Terminate(5000); inherited Destroy; fRead.Free; fWrite.Free; end; function TPollAsynchSockets.Start(connection: TObject): boolean; var slot: PPollSocketsSlot; begin result := false; if (fRead.Terminated) or (connection=nil) then exit; InterlockedIncrement(fProcessing); try slot := SlotFromConnection(connection); if (slot=nil) or (slot.socket=0) then exit; if not AsynchSocket(slot.socket) then exit; // we expect non-blocking mode on a real working socket result := fRead.Subscribe(slot.socket,TPollSocketTag(connection),[pseRead]); // now, ProcessRead will handle pseRead + pseError/pseClosed on this socket finally InterlockedDecrement(fProcessing); end; end; function TPollAsynchSockets.Stop(connection: TObject): boolean; var slot: PPollSocketsSlot; sock: TSocket; endtix: Int64; lock: set of (r,w); begin result := false; if fRead.Terminated or (connection=nil) then exit; InterlockedIncrement(fProcessing); try slot := SlotFromConnection(connection); if slot=nil then exit; sock := slot.socket; if sock<>0 then try slot.socket := 0; // notify ProcessRead/ProcessWrite to abort slot.lastWSAError := WSAErrorAtShutdown(sock); fRead.Unsubscribe(sock,TPollSocketTag(connection)); fWrite.Unsubscribe(sock,TPollSocketTag(connection)); result := true; finally DirectShutdown(sock); endtix := GetTick64+10000; lock := []; repeat // acquire locks to avoid OnClose -> Connection.Free -> GPF if not(r in lock) and slot.Lock(false) then include(lock,r); if not(w in lock) and slot.Lock(true) then include(lock,w); if lock=[r,w] then break; SleepHiRes(0); // 10 microsecs on POSIX until GetTick64>=endtix; end; finally InterlockedDecrement(fProcessing); end; end; function TPollAsynchSockets.GetCount: integer; begin if self=nil then result := 0 else result := fRead.Count; end; procedure TPollAsynchSockets.Terminate(waitforMS: integer); var endtix: Int64; begin fRead.Terminate; fWrite.Terminate; if waitforMS<=0 then exit; endtix := GetTick64+waitforMS; repeat SleepHiRes(1); if fProcessing=0 then break; until GetTick64>endtix; end; function TPollAsynchSockets.WriteString(connection: TObject; const data: SockString): boolean; begin if self=nil then result := false else result := Write(connection,pointer(data)^,length(data)); end; procedure AppendData(var buf: SockString; const data; datalen: PtrInt); var buflen: PtrInt; begin if datalen>0 then begin buflen := length(buf); SetLength(buf,buflen+datalen); move(data,PByteArray(buf)^[buflen],datalen); end; end; function TPollAsynchSockets.Write(connection: TObject; const data; datalen, timeout: integer): boolean; var tag: TPollSocketTag; slot: PPollSocketsSlot; P: PByte; res,previous: integer; begin result := false; if (datalen<=0) or (connection=nil) or fWrite.Terminated then exit; InterlockedIncrement(fProcessing); try tag := TPollSocketTag(connection); slot := SlotFromConnection(connection); if (slot=nil) or (slot.socket=0) then exit; if slot.TryLock(true,timeout) then // try and wait for another ProcessWrite try P := @data; previous := length(slot.writebuf); if (previous=0) and not (paoWritePollOnly in fOptions) then repeat // try to send now in non-blocking mode (works most of the time) if fWrite.Terminated or (slot.socket=0) then exit; res := AsynchSend(slot.socket,P,datalen); if slot.socket=0 then exit; // Stop() called if (res<0) and not WSAIsFatalError then break; // fails now -> retry later in ProcessWrite if res<=0 then exit; // connection closed or broken -> abort inc(fWriteCount); inc(fWriteBytes,res); dec(datalen,res); if datalen=0 then begin try // notify everything written AfterWrite(connection); result := true; except result := false; end; exit; end; inc(P,res); until false; // use fWrite output polling for the remaining data in ProcessWrite AppendData(slot.writebuf,P^,datalen); if previous>0 then // already subscribed result := slot.socket<>0 else if fWrite.Subscribe(slot.socket,tag,[pseWrite]) then result := slot.socket<>0 else slot.writebuf := ''; // subscription error -> abort finally slot.UnLock({writer=}true); end; finally InterlockedDecrement(fProcessing); end; end; procedure TPollAsynchSockets.ProcessRead(timeoutMS: integer); var notif: TPollSocketResult; connection: TObject; slot: PPollSocketsSlot; res,added: integer; temp: array[0..$7fff] of byte; // read up to 32KB per chunk procedure CloseConnection(withinreadlock: boolean); begin if withinreadlock then slot.UnLock({writer=}false); // Stop() will try to acquire this lock Stop(connection); // shutdown and set socket:=0 + acquire locks try OnClose(connection); // now safe to perform connection.Free except connection := nil; // user code may be unstable end; slot := nil; // ignore pseClosed and slot.Unlock(false) end; begin if (self=nil) or fRead.Terminated then exit; InterlockedIncrement(fProcessing); try if not fRead.GetOne(timeoutMS,notif) then exit; connection := TObject(notif.tag); slot := SlotFromConnection(connection); if (slot=nil) or (slot.socket=0) then exit; if pseError in notif.events then if not OnError(connection,notif.events) then begin // false = shutdown CloseConnection({withinlock=}false); exit; end; if pseRead in notif.events then begin if slot.Lock({writer=}false) then // paranoid thread-safe read try added := 0; repeat if fRead.Terminated or (slot.socket=0) then exit; res := AsynchRecv(slot.socket,@temp,sizeof(temp)); if slot.socket=0 then exit; // Stop() called if (res<0) and not WSAIsFatalError then break; // may block, try later if res<=0 then begin CloseConnection(true); exit; // socket closed gracefully or unrecoverable error -> abort end; AppendData(slot.readbuf,temp,res); inc(added,res); until false; if added>0 then try inc(fReadCount); inc(fReadBytes,added); if OnRead(connection)=sorClose then CloseConnection(true); except CloseConnection(true); // force socket shutdown end; finally slot.UnLock(false); // CloseConnection may set slot=nil end; end; if (slot<>nil) and (slot.socket<>0) and (pseClosed in notif.events) then begin CloseConnection(false); exit; end; finally InterlockedDecrement(fProcessing); end; end; procedure TPollAsynchSockets.ProcessWrite(timeoutMS: integer); var notif: TPollSocketResult; connection: TObject; slot: PPollSocketsSlot; buf: PByte; buflen,res,sent: integer; begin if (self=nil) or fWrite.Terminated then exit; InterlockedIncrement(fProcessing); try if not fWrite.GetOne(timeoutMS,notif) then exit; if notif.events<>[pseWrite] then exit; // only try if we are sure the socket is writable and safe connection := TObject(notif.tag); slot := SlotFromConnection(connection); if (slot=nil) or (slot.socket=0) then exit; if slot.Lock({writer=}true) then // paranoid check try buflen := length(slot.writebuf); if buflen<>0 then begin buf := pointer(slot.writebuf); sent := 0; repeat if fWrite.Terminated or (slot.socket=0) then exit; res := AsynchSend(slot.socket,buf,buflen); if slot.socket=0 then exit; // Stop() called if (res<0) and not WSAIsFatalError then break; // may block, try later if res<=0 then exit; // socket closed gracefully or unrecoverable error -> abort inc(fWriteCount); inc(sent,res); inc(buf,res); dec(buflen,res); until buflen=0; inc(fWriteBytes,sent); delete(slot.writebuf,1,sent); end; if slot.writebuf='' then begin // no data any more to be sent fWrite.Unsubscribe(slot.socket,notif.tag); try AfterWrite(connection); except end; end; finally slot.UnLock(true); end; finally InterlockedDecrement(fProcessing); end; end; var _MainHttpClass: THttpRequestClass; function MainHttpClass: THttpRequestClass; begin if _MainHttpClass = nil then begin {$ifdef USEWININET} _MainHttpClass := TWinHTTP; {$else} {$ifdef USELIBCURL} _MainHttpClass := TCurlHTTP {$else} raise ECrtSocket.Create('No THttpRequest class known!'); {$endif} {$endif} end; result := _MainHttpClass; end; procedure ReplaceMainHttpClass(aClass: THttpRequestClass); begin _MainHttpClass := aClass; end; procedure Initialize; var i: integer; begin for i := 0 to high(NormToUpper) do NormToUpper[i] := i; for i := ord('a') to ord('z') do dec(NormToUpper[i],32); IP4local := '127.0.0.1'; // use var string with refcount=1 to avoid allocation JSON_CONTENT_TYPE_VAR := 'application/json; charset=UTF-8'; {$ifdef MSWINDOWS} Assert( {$ifdef CPU64} (sizeof(HTTP_REQUEST)=864) and (sizeof(HTTP_SSL_INFO)=48) and (sizeof(HTTP_DATA_CHUNK_INMEMORY)=32) and (sizeof(HTTP_DATA_CHUNK_FILEHANDLE)=32) and (sizeof(HTTP_REQUEST_HEADERS)=688) and (sizeof(HTTP_RESPONSE_HEADERS)=512) and (sizeof(HTTP_COOKED_URL)=40) and (sizeof(HTTP_RESPONSE)=568) and {$else} (sizeof(HTTP_REQUEST)=472) and (sizeof(HTTP_SSL_INFO)=28) and (sizeof(HTTP_DATA_CHUNK_INMEMORY)=24) and (sizeof(HTTP_DATA_CHUNK_FILEHANDLE)=32) and (sizeof(HTTP_RESPONSE)=288) and (sizeof(HTTP_REQUEST_HEADERS)=344) and (sizeof(HTTP_RESPONSE_HEADERS)=256) and (sizeof(HTTP_COOKED_URL)=24) and {$endif CPU64} (ord(reqUserAgent)=40) and (ord(respLocation)=23) and (sizeof(THttpHeader)=4) and (integer(HTTP_LOG_FIELD_TEST_SUB_STATUS)=HTTP_LOG_FIELD_SUB_STATUS)); GetTick64 := GetProcAddress(GetModuleHandle(kernel32),'GetTickCount64'); if not Assigned(GetTick64) then // fallback before Vista GetTick64 := @GetTick64ForXP; {$ifdef USEWININET} FillChar(WinHttpAPI, SizeOf(WinHttpAPI), 0); WinHttpAPIInitialize; {$endif} {$endif MSWINDOWS} FillChar(WsaDataOnce,sizeof(WsaDataOnce),0); if InitSocketInterface then WSAStartup(WinsockLevel, WsaDataOnce); end; initialization Initialize; finalization if WsaDataOnce.wVersion<>0 then try {$ifdef MSWINDOWS} if Assigned(WSACleanup) then WSACleanup; {$endif} finally fillchar(WsaDataOnce,sizeof(WsaDataOnce),0); end; {$ifdef MSWINDOWS} if Http.Module<>0 then begin FreeLibrary(Http.Module); Http.Module := 0; end; {$endif} DestroySocketInterface; end.