Vichingo455-RePacks
/
xtool
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases 1 Wiki Activity
xtool/contrib/mORMot/SynCrtSock.pas

13145 lines
483 KiB
ObjectPascal
Raw Permalink Blame History

/// 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+'&lt;';
'>': result := result+'&gt;';
'&': result := result+'&amp;';
'"': result := result+'&quot;';
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+'&lt;';
'>': result := result+'&gt;';
'&': result := result+'&amp;';
'"': result := result+'&quot;';
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 count<L then
L := count;
while L>0 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 P<PEnd do begin
c := byte(P^)-48;
if c>9 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 t32<t64.Lo then
inc(t64.Hi); // wrap-up overflow after 49 days
t64.Lo := t32;
GetTickXP := t64; // (almost) atomic write
end; // warning: FPC's GetTickCount64 doesn't handle 49 days wrap :(
{$else}
function GetTick64: Int64;
begin
result := {$ifdef FPC}SynFPCLinux.{$endif}GetTickCount64;
end;
{$endif MSWINDOWS}
var // GetIPAddressesText(Sep=' ') cache
IPAddressesText: array[boolean] of SockString;
IPAddressesTix: array[boolean] of integer;
function GetIPAddressesText(const Sep: SockString; PublicOnly: boolean): SockString;
var ip: TSockStringDynArray;
tix, i: integer;
begin
result := '';
if Sep=' ' then begin
tix := GetTick64 shr 16; // refresh every minute
if tix<>IPAddressesTix[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 InputBufferSize<SOCKMINBUFSIZE then
InputBufferSize := SOCKMINBUFSIZE;
GetMem(fSockIn,sizeof(TTextRec)+InputBufferSize);
fillchar(SockIn^,sizeof(TTextRec),0);
with TTextRec(SockIn^) do begin
PCrtSocket(@UserData)^ := self;
Mode := fmClosed;
BufSize := InputBufferSize;
BufPtr := pointer(PAnsiChar(SockIn)+sizeof(TTextRec)); // ignore Buffer[] (Delphi 2009+)
OpenFunc := @OpenSock;
Handle := -1;
end;
{$ifndef DELPHI5OROLDER}
SetLineBreakStyle(SockIn^,LineBreak); // http does break lines with #13#10
{$endif}
Reset(SockIn^);
end;
procedure TCrtSocket.CreateSockOut(OutputBufferSize: Integer);
begin
if SockOut<>nil then
exit; // initialization already occured
if OutputBufferSize<SOCKMINBUFSIZE then
OutputBufferSize := SOCKMINBUFSIZE;
GetMem(fSockOut,sizeof(TTextRec)+OutputBufferSize);
fillchar(SockOut^,sizeof(TTextRec),0);
with TTextRec(SockOut^) do begin
PCrtSocket(@UserData)^ := self;
Mode := fmClosed;
BufSize := OutputBufferSize;
BufPtr := pointer(PAnsiChar(SockIn)+sizeof(TTextRec)); // ignore Buffer[] (Delphi 2009+)
OpenFunc := @OpenSock;
Handle := -1;
end;
{$ifndef DELPHI5OROLDER}
SetLineBreakStyle(SockOut^,tlbsCRLF); // force e.g. for Linux platforms
{$endif}
Rewrite(SockOut^);
end;
procedure TCrtSocket.CloseSockIn;
begin
if (self<>nil) 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<available then
SetLength(result,resultlen); // e.g. Read=0 may happen
SleepHiRes(0); // 10 microsecs on POSIX
until false;
end;
{ THttpClientSocket }
constructor THttpClientSocket.Create(aTimeOut: PtrInt);
begin
if aTimeOut=0 then
aTimeOut := HTTP_DEFAULT_RECEIVETIMEOUT;
inherited Create(aTimeOut);
fUserAgent := DefaultUserAgent(self);
end;
function THttpClientSocket.Delete(const url: SockString; KeepAlive: cardinal;
const header: SockString): integer;
begin
result := Request(url,'DELETE',KeepAlive,header,'','',false);
end;
function THttpClientSocket.Get(const url: SockString; KeepAlive: cardinal=0; const header: SockString=''): integer;
begin
result := Request(url,'GET',KeepAlive,header,'','',false);
end;
function AuthorizationBearer(const AuthToken: SockString): SockString;
begin
if AuthToken='' then
result := '' else
result := 'Authorization: Bearer '+AuthToken;
end;
function THttpClientSocket.GetAuth(const url, AuthToken: SockString; KeepAlive: cardinal=0): integer;
begin
result := Get(url,KeepAlive,AuthorizationBearer(AuthToken));
end;
function THttpClientSocket.Head(const url: SockString; KeepAlive: cardinal;
const header: SockString): integer;
begin
result := Request(url,'HEAD',KeepAlive,header,'','',false);
end;
function THttpClientSocket.Post(const url, Data, DataType: SockString; KeepAlive: cardinal;
const header: SockString): integer;
begin
result := Request(url,'POST',KeepAlive,header,Data,DataType,false);
end;
function THttpClientSocket.Put(const url, Data, DataType: SockString;
KeepAlive: cardinal; const header: SockString): integer;
begin
result := Request(url,'PUT',KeepAlive,header,Data,DataType,false);
end;
procedure THttpClientSocket.RequestSendHeader(const url, method: SockString);
begin
if fSock<=0 then
exit;
if SockIn=nil then // done once
CreateSockIn; // use SockIn by default if not already initialized: 2x faster
if TCPPrefix<>'' 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<STATUS_SUCCESS) or (ClientSock.Headers='') then
Code := STATUS_NOTFOUND;
reason := StatusCodeToReason(Code);
if ErrorMsg<>'' then begin
ctxt.OutCustomHeaders := '';
ctxt.OutContentType := 'text/html; charset=utf-8'; // create message to display
ctxt.OutContent := {$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(
format('<body style="font-family:verdana">'#10+
'<h1>%s Server Error %d</h1><hr><p>HTTP %d %s<p>%s<p><small>%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)<cardinal(length(fCompress)) then
if fCompress[fContentCompress].Func(Content,false)='' then
// invalid content
raise ECrtSocket.CreateFmt('%s uncompress',[fCompress[fContentCompress].Name]);
ContentLength := length(Content); // update Content-Length
{$ifdef SYNCRTDEBUGLOW}
TSynLog.Add.Log(sllCustom2,'GetBody sock=% pending=% sockin=% len=% %',
[fSock, SockInPending(0), PTextRec(SockIn)^.BufEnd-PTextRec(SockIn)^.bufpos,
ContentLength, LogEscapeFull(Content)], self);
{$endif}
if SockIn<>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 (GetTick64<endtix) do
SleepHiRes(5);
for i := 0 to fWorkThreadCount-1 do
fWorkThread[i].Free;
finally
{$ifdef USE_WINIOCP}
CloseHandle(fRequestQueue);
{$else}
DeleteCriticalSection(fSafe);
{$endif USE_WINIOCP}
end;
inherited Destroy;
end;
function TSynThreadPool.Push(aContext: pointer; aWaitOnContention: boolean): boolean;
{$ifdef USE_WINIOCP}
function Enqueue: boolean;
begin // IOCP has its own queue
result := PostQueuedCompletionStatus(fRequestQueue,0,0,aContext);
end;
{$else}
function Enqueue: boolean;
var i, n: integer;
found: TSynThreadPoolWorkThread;
thread: ^TSynThreadPoolWorkThread;
begin
result := false; // queue is full
found := nil;
EnterCriticalsection(fSafe);
try
thread := pointer(fWorkThread);
for i := 1 to fWorkThreadCount do
if thread^.fProcessingContext=nil then begin
found := thread^;
found.fProcessingContext := aContext;
result := true; // found one available thread
exit;
end else
inc(thread);
if not fQueuePendingContext then
exit;
n := fPendingContextCount;
if n+fWorkThreadCount>QueueLength 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.Count<THREADPOOL_MAXWORKTHREADS) and
(ServerSock.KeepAliveClient or
(ServerSock.ContentLength>THREADPOOL_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 api<hHttpApi2First then
raise ECrtSocket.CreateFmt('Unable to find %s() in %s',[HttpNames[api],HTTPAPI_DLL]) else
Http.Version.MajorVersion := 1; // e.g. Windows XP or Server 2003
inc(P);
end;
except
on E: Exception do begin
if Http.Module>255 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(
'<html><body style="font-family:verdana;"><h1>Server Error %d: %s</h1><p>',
[StatusCode,OutStatus]);
if E<>nil then
Msg := Msg+string(E.ClassName)+' Exception raised:<br>';
Resp^.SetContent(DataChunkInMemory,UTF8String(Msg)+HtmlEncode(
{$ifdef UNICODE}UTF8String{$else}UTF8Encode{$endif}(ErrorMsg))
{$ifndef NOXPOWEREDNAME}+'</p><p><small>'+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<DataChunkFile.ByteRange.Length.QuadPart then
// "bytes=0-499" -> 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 InContentLengthRead<InContentLength then
SetLength(Context.fInContent,InContentLengthRead);
Err := NO_ERROR;
break; // should loop until returns ERROR_HANDLE_EOF
end;
if Err<>NO_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 AValue<HTTP_MIN_ALLOWED_BANDWIDTH_THROTTLING_RATE then
limitInfo.MaxBandwidth := HTTP_MIN_ALLOWED_BANDWIDTH_THROTTLING_RATE else
limitInfo.MaxBandwidth := aValue;
limitInfo.Flags := 1;
qosInfo.QosType := HttpQosSettingTypeBandwidth;
qosInfo.QosSetting := @limitInfo;
EHttpApiServer.RaiseOnError(hSetServerSessionProperty,
Http.SetServerSessionProperty(fServerSessionID, HttpServerQosProperty,
@qosInfo, SizeOf(qosInfo)));
EHttpApiServer.RaiseOnError(hSetUrlGroupProperty,
Http.SetUrlGroupProperty(fUrlGroupID, HttpServerQosProperty,
@qosInfo, SizeOf(qosInfo)));
end;
end;
function THttpApiServer.GetMaxBandwidth: Cardinal;
var qosInfoGet: record
qosInfo: HTTP_QOS_SETTING_INFO;
limitInfo: HTTP_BANDWIDTH_LIMIT_INFO;
end;
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 := 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 (index<fConnectionsCount) then begin
conn := fConnections^[index];
if (conn<>nil) 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 (index<fConnectionsCount) then begin
conn := fConnections^[index];
if (conn<>nil) 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)<P.RawValueLength do begin
while ((ch-p.pRawValue)<P.RawValueLength) and (ch^ in [',', ' ']) do inc(ch);
chB := ch;
while ((ch-p.pRawValue)<P.RawValueLength) and not (ch^ in [',']) do inc(ch);
SetString(aName, chB, ch - chB);
if aName = fRegisteredProtocols^[i].name then begin
Protocol := fRegisteredProtocols^[i];
goto protocolFound;
end;
end;
end;
end;
inc(p);
end;
if not ProtocolHeaderFound and (Protocol=nil) and (Length(fRegisteredProtocols^)=1) then
Protocol := fRegisteredProtocols^[0];
protocolFound:
if Protocol <> 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<fServer.fPingTimeout) do begin
Sleep(1000);
inc(i);
end;
end
else
Terminate;
end;
constructor TSynWebSocketGuard.Create(Server: THttpApiWebSocketServer);
begin
fServer := Server;
inherited Create(false);
end;
{ HTTP_RESPONSE }
procedure HTTP_RESPONSE.SetContent(var DataChunk: HTTP_DATA_CHUNK_INMEMORY;
const Content, ContentType: SockString);
begin
fillchar(DataChunk,sizeof(DataChunk),0);
if ContentType<>'' 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 datapos<datalen do begin
Bytes := fOnDownloadChunkSize;
if Bytes<=0 then
Bytes := 65536; // 64KB seems fair enough by default
max := datalen-datapos;
if Bytes>max 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 api<hWebSocketApiFirst then begin
FreeLibrary(WinHttpAPI.LibraryHandle);
WinHttpAPI.LibraryHandle := 0;
raise ECrtSocket.CreateFmt('Unable to find %s() in %s',[WinHttpNames[api], winhttpdll]);
end else
WinHttpAPI.WebSocketEnabled := false; // e.g. version is lower than Windows 8
inc(P);
end;
if WinHttpAPI.WebSocketEnabled then
WebSocketApiInitialize else
WebSocketAPI.WebSocketEnabled := false;
end;
destructor TWinHTTP.Destroy;
begin
if fConnection<>nil 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 Current<L do begin
Bytes := fOnDownloadChunkSize;
if Bytes<=0 then
Bytes := 65536; // 64KB seems fair enough by default
Max := L-Current;
if Bytes>Max 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 SendTimeout<ReceiveTimeout then
SendTimeout := ReceiveTimeout;
if SendTimeout<>0 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 i<fCount then
move(fTag[i+1],fTag[i],(fCount-i)*sizeof(fTag[i]));
if fCount=0 then
fHighestSocket := 0;
result := true;
exit;
end;
end;
function TPollSocketSelect.WaitForModified(out results: TPollSocketResults;
timeoutMS: integer): integer;
var tv: TTimeVal;
rd,wr: TFDSet;
rdp,wrp: PFDSet;
ev: TPollSocketEvents;
i, pending: integer;
tmp: array[0..FD_SETSIZE-1] of TPollSocketResult;
begin
result := -1; // error
if (self=nil) or (fCount=0) then
exit;
if fRead.fd_count>0 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].Count<fPoll[p].MaxSockets then begin
poll := fPoll[p]; // stil some place in this poll instance
break;
end;
if poll=nil then begin
poll := fPollClass.Create;
SetLength(fPoll,n+1);
fPoll[n] := poll;
end;
result := poll.Subscribe(socket,events,tag);
if result then
inc(fCount);
finally
LeaveCriticalSection(fPollLock);
end;
end;
function TPollSockets.Unsubscribe(socket: TSocket; tag: TPollSocketTag): boolean;
var p: integer;
begin
result := false;
EnterCriticalSection(fPendingLock);
try
for p := fPendingIndex to high(fPending) do
if fPending[p].tag=tag then
byte(fPending[p].events) := 0; // tag to be ignored in future GetOne
finally
LeaveCriticalSection(fPendingLock);
end;
EnterCriticalSection(fPollLock);
try
for p := 0 to high(fPoll) do
if fPoll[p].Unsubscribe(socket) then begin
dec(fCount);
result := true;
exit;
end;
finally
LeaveCriticalSection(fPollLock);
end;
end;
function TPollSockets.GetOneWithinPending(out notif: TPollSocketResult): boolean;
var last,index: integer;
begin
result := false;
if fTerminated then
exit;
EnterCriticalSection(fPendingLock);
try
index := fPendingIndex;
last := high(fPending);
while index<=last do begin
notif := fPending[index]; // return notified events
if index<last then begin
inc(index);
fPendingIndex := index;
end else begin
fPending := nil;
fPendingIndex := 0;
end;
if byte(notif.events)<>0 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.
Reference in New Issue View Git Blame Copy Permalink