{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Author: Angus Robertson, Magenta Systems Ltd Description: IP Streaming Log Component Creation: Nov 2006 Updated: May 2026 Version: V9.7 EMail: francois.piette@overbyte.be http://www.overbyte.be Support: https://en.delphipraxis.net/forum/37-ics-internet-component-suite/ Legal issues: Copyright (C) 2006-2026 by Angus Robertson, Magenta Systems Ltd, Croydon, England. delphi@magsys.co.uk, https://www.magsys.co.uk/delphi/ This software is provided 'as-is', without any express or implied warranty. In no event will the author be held liable for any damages arising from the use of this software. Permission is granted to anyone to use this software for any purpose, including commercial applications, and to alter it and redistribute it freely, subject to the following restrictions: 1. The origin of this software must not be misrepresented, you must not claim that you wrote the original software. If you use this software in a product, an acknowledgment in the product documentation would be appreciated but is not required. 2. Altered source versions must be plainly marked as such, and must not be misrepresented as being the original software. 3. This notice may not be removed or altered from any source distribution. 4. You must register this software by sending a picture postcard to the author. Use a nice stamp and mention your name, street address, EMail address and any comment you like to say. TIcsIpStrmLog is designed for IP stream logging, using TCP Client, TCP Server, UDP Client or UDP Server protocols, sending simple text lines across a network so they may be displayed or written to disk remotely. The component allows two way communication with TCP and UDP, so may also be used for simple protocols such as communication between two applications. The component supports multiple client sockets so may be used to send data to two or more different remote servers at the same time. For TCP and UDP clients, the component will optionally ping the remote computer first before opening an IP connection to allow faster failure retries and some confirmation that UDP may work. TCP client provides repeated connection retry attempts, including re-establishing a lost connection. UDP client will optionally keep pinging the remote during a connection to ensure it's still there. UDP server sends data to the IP address and port from which it last received data. TCP server supports multiple remote clients connecting, and can send lines to just one or all of the remore connections. TCP Client and Server support SSL/TLS if required, with the server creating local certificates or ordering public certificates from Let's Encrypt. Received data is parsed for various line endings optionally removing control characters and triggering an event for a received line. The only other two events are optional, one for state changed when starting and stopping, the second offering progress information and errors. The component supports both IPv4 and IPv6, host name lookup for TCP and UDP Client, and SSL connections for TCP Client and TCP Server, including remote server certificate checking using either a built in PEM bundle. A demo application OverbyteIcsIpStmLogTst illustrates use of TIcsIpStrmLog as a TCP or UDP client or server, and both in the same program sending data locally. The same component may be used in a client or server application, to send or receive. Multiple instances of the component may be used on different IP addresses and/or ports, for multiple different streams. Using TIcsIpStrmLog: 1 - Drop the component onto a form (or create it in code, see testiplog.exe). 2 - Specify LogProtocol as one of logprotUdpClient, logprotUdpServer, logprotTcpServer, logprotTcpClient. 3 - For client protocols, specify RemoteHost (name or IP address) and RemoteIpPort, CheckPing true if ping to be used, RetryAttempts to non-zero if continual retries not needed, -1 for no retries, RetryWaitSecs for delay between retries. 4 - For server protocols, LocalIpAddress is 0.0.0.0 to listen on all local addresses, LocalIpPort must be non-zero. 5 - For sending data, AddCRLF to false if line already have terminating characters, UdpNoCRLF to false if UDP should send CRLF. 6 - For receiving data, LineEndType to one of lineendCR, lineendLF, lineendCustom (set in hex in CustomLineEnd) or lineendPacket (for UDP), then MaxLineLen if a line should be returned before lineend is found, normally non-ASCII characters are removed, set StripControls to false if they should be replaced by spaces, RawData to true if CR, LF, FF and control characters should not be removed. 6a - Line end may also be forced once MaxRecvData of data has been received for binary protocols or those with content length headers (like HTTP). 7 - Assign onLogRecvEvent if data is to be received, onLogChangeEvent if tracking of start and stop is needed, onLogProgEvent if progress information is needed for logging. 8 - Call StartLogging. The LogChangeEvent and LogProgEvent will trigger when LogState changes to logstateOK when data may be sent. 9 - To send a line, if function GetAnyStateOK is true, call SendLogLine. MaxSendBuffer specifies the amount of data that can be buffered otherwise SendLogLine will fail. 10 - Received data will trigger LogRecvEvent once per line. 11 - Call StopLogging to stop. Buffered data may continue to be sent after close, keep calling CheckStopped until true when it's really finished and component may be destroyed. 12 - To send an unlimited size stream, create a stream in the application with TBufferedFileStream or TFileStream, and pass it to SendStream. LogState changes to logstateOKStream while it's being sent, then back to logstateOK as it finishes, the application should then free the stream. 13 - There is no specific handling for receiving a stream, textual data will be handled according to the normal line end properties, and can be saved to another stream in LogRecvEvent. Binary data is more problematic, set RawData to true and MaxLineLen to get a buffer load at a time, but the last buffer load will need to be extracted with GetPartialLine using a timeout, this is called automatically when the connection is closed. 14 - To send to multiple TCP or UDP Clients, set MaxSockets to the number needed, then use the function SetRemotes to specify the remote host and port for each socket number, base 0. The events all return Socnr to indicate which socket. For TCP Serever, MaxSockets specifies how many remote clients can connect to TCP Server, and the events return a sequential ClientId number (base 1) to uniquely identify remote clients, which can be used to send data back to just one of those clients. 22nd Nov 2006 - baseline - v1.0 3rd Dec 2006 - using OverbyteIcsFtpSrvT instead of OverbyteIcsLibrary 1st Feb 2007 - UDP receive packets may be from multiple hosts, always keep IP 5th Aug 2008 - 1.2 - made compatible with ICS V7 and Delphi 2009 Note - only sends and receives ANSI text 20th Aug 2009 - 1.3 - fixed problem with MaxSockets being reported as closed in the event when only one was open, tested with Delphi 2010 9th Aug 2010 - 1.4 - removed cast warnings with Delphi 2009 and later 22nd Sept 2011 - 1.5 - added SndBufSize and RcvBufSize to increase buffer sizes and speed 11th Sept 2012 - 1.6 - better error for too many clients with server added CurSockets property for current number of server sockets 7th July 2014 - 2.0 - ICS 8 and later, using new ICS ping added IPv6 and SSL support, including server certificate checking added host name support for UDP and TCP client with DNS lookup added LogProtocols suffixed 6 for IPv6 cleaned up some progress messages, identify error progress events removed line length limit of 1024 that was not checked added send a stream of unlimited length get buffered partial received line during close default line end is LF instead of CR so UNIX files are processed 23rd July 2014 - 2.1 - SSL logging improvements 13th July 2015 - 2.2 - added better SSL handshake error reporting added lineendCRLF, only support FF as lineend if using CR retry on SSL handshake errors added RetryNoImm true to stop immediate reconnect attempts on abnormal disconnect 23rd Oct 2015 - 2.3 - better SSL client and server certificate reporting 8th July 2016 - 2.4 - fixed certificate reporting typo added SrvTimeoutSecs to close idle server sessions added Socket property to get current socket, mainly for statistics 23rd Nov 2016 - 2.5 - added GetSendWaiting to check how many bytes of send data not yet sent increased default MaxSendBuffer size to 64K added property TotRecvData total data received since connection, or when method ResetRecvData was called added property MaxRecvData which causes onLogRecvEvent to be called when that length has been received. May be used for fixed length binary packets or where received data contains a content length such as a HTTP response header followed by binary data server takes exclusive access of addr/port fixed bug with multiple clients not using correct port added SSL Server Name Indication support check multiple client SSL host names correctly removed USE_SSL so SSL is always supported removed TX509Ex now using TX509Base using OpenSSL certificate verification host checking 7th March 2017 - 2.6 - set IcsLogger for context so it logs more stuff simplified reporting SSL certs in client handshake improved validation of server certificates use threaded DNS lookup 19th June 2018 - 2.7 - support TLSv1.3, no real changes... don't start SSL handshake twice cleaned up SSL error handling 22 Feb 2019 - V8.60 - Adapted for main ICS packages and FMX support. Renamed from TMagIpLog to TIcsIpStrmLog. Major rewrite, not directly compatible with 2.7 and earlier. Use IcsHost interface to set-up TCP server. Allow TCP server to automatically order SSL certificates. SslContext now internal to component and set-up here. Now SSL only, not sure earlier versions worked without SSL. Client6 and Server6 gone, use SocketFamily for IPv4/v6 Added SslCliSecurity to set client security level. Allow SSL certificates to be ordered and installed automatically by RecheckSslCerts if SslCertAutoOrder=True and so specified in IcsHosts, if a TSslX509Certs component is attached and a certificate supplier account has been created (by the OverbyteIcsX509CertsTst sample application). AUTO_X509_CERTS define can be disabled to remove a lot of units if automatic SSL/TLS ordering is not required, saves up to 1 meg of code. 07 Aug 2019 - V8.62 - TCP server now uses root bundle correctly and reports certificate chain and bindings. Ensure all listeners started for TCP Server, if more than one. Builds without USE_SSL. 13 Nov 2019 - V8.63 - SrvValidateHosts and SrvRecheckSslCerts have new AllowSelfSign to stop errors with self signed certificates. Allow TCP server to start with certificate warnings. 27 Apr 2020 - V8.64 - If TCP Server listening on port 0, log random port allocated. Don't start TCP Server if validation failed. TCP Server shows listening ports. 09 Dec 2020 - V8.65 - Only increase TCP buffer size, don't reduce it below default of 64K, generally better to let Windows TCP autotuning set size. Changes for Posix support. If SSL handshake fails due to bad certificate or chain, remove SSL session from cache so an immediate retry does not succeed by skipping the certificate checks. Renamed Ics.Posix.Messages.pas to Ics.Posix.PXMessages.pas. Jun 01, 2021 - V8.67 Replaced Stream.Seek with Stream.Position. For Send errors, use LastError instead of GetLastError. May 26, 2022 - V8.69 Previously the LogSslRevocation property was only effective when checking the windows certificate store, now it also works with bundle files using the TOcspHttp component and OCSP stapling if available. RetryAttempts -1 means no retry attempts, 0 mean try for ever. After failure to connect, change state to Stopping, then None since it never really started. Changed FSendBuffer to TBytes, use SendTB methods with TBytes. Oct 11, 2022 - V8.70 Added UseUtf8 flag that converts received lines from UTF-8 to Unicode with unicode compilers (as String) and converts sent data to UTF-8. Changed FRxBuffer to Tbytes, use ReceiveTB methods with TBytes. Added SendLogLine(Line: UnicodeString), send as UTF-8. Added SendLogLine(Line: TBytes), send raw. Break receive loop if continually receiving non-acceptable characters. Jan 26, 2023 - V8.71 Ensure inherited destroy called. Using Int64 ticks. Aug 08, 2023 V9.0 Updated version to major release 9. Dec 18, 2023 V9.1 TOcspHttp now in OverbyteIcsSslUtils rather than OverbyteIcsSslHttpRest to ease linking. Added OverbyteIcsSslBase which now includes TX509Base and TX509List. SslContext now uses public IcsSslRootCAStore and ignores root bundle. Apr 25, 2024 V9.2 Correctly count failed client connection attempts if ping is not used first to check the remote IP address. Sep 19, 2024 V9.3 Using define MSCRYPT_Clients instead of MSWINDOWS to define whether the Windows Store can be used for SSL certificate verification. Using OverbyteIcsTypes for consolidated types and constants, allowing other import units to be removed. Major rewrite of TCP Server code so the TStrmChanInfo record is now part of TWSocketClient to avoid issues with the server accepting multiple connections that came and went, so the application could get confused over which client was sending data. For TCP/Server, events now return a sequential ClientId number (base 1) instead of current socket number (base 0) to uniquely identify remote clients. Beware server clients may have disconnected. SendLogLine has an optional ClientId argument allowing a line to be sent to a single remote client, instead of all the clients. Added CloseSrvCli method to close a single TCP Server remote client connection by ClientId. UDP Server allowed to listen for broadcasts in multiple apps on same PC by reusing IP/port. Not sure it works yet. Added SrvClientSoc property to get TIpServerClient. Restrict MaxLineLen to DefMaxIpLogLine which is 4096 characters, although should be about 1400 for UDP packets to be sent correcly. Try to stop repeated errors when connections fail. Added a way for applications to check SSL certificate chains themselves, ignoring OpenSSL bundle checks, usually for self signed private certificates. if LogSslVerMethod = logSslVerOwnEvent, during OnSslHandshakeDone the component calls a new event OnSslCertVerifyEvent where the application can check the chain and change the verify result appropriately. Maybe checking certificate serials, names or public key. Jan 22, 2025 V9.4 Added ListenStates which for logprotUdpServer and logprotTcpServer returns a multiline string listing the IP, port, SSL and state of all socket listeners. CurSockets property now reflects actual TCP Server clients. Feb 04, 2026 V9.6 Using new onDebugDisplay event to display messages from TWSocket, controlled by TWSDebugOptions, replaces some logging here and.SSL handshake checking. OCSP, DHParams and IcsLogger gone. Only log SSL version once. May 06, 2026 V9.7 wsoIcsDnsLookup and wsoAsyncDnsLookup gone. * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {$IFNDEF ICS_INCLUDE_MODE} unit OverbyteIcsIpStreamLog; {$ENDIF} {$I Include\OverbyteIcsDefs.inc} {$IFDEF COMPILER14_UP} {$IFDEF NO_EXTENDED_RTTI} {$RTTI EXPLICIT METHODS([]) FIELDS([]) PROPERTIES([])} {$ENDIF} {$ENDIF} {$B-} { Enable partial boolean evaluation } {$T-} { Untyped pointers } {$X+} { Enable extended syntax } {$H+} { Use long strings } {$IFDEF BCB} {$ObjExportAll On} {$ENDIF} interface {$IFDEF USE_SSL} uses {$IFDEF MSWINDOWS} {$IFDEF RTL_NAMESPACES}Winapi.Messages{$ELSE}Messages{$ENDIF}, {$IFDEF RTL_NAMESPACES}Winapi.Windows{$ELSE}Windows{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.TypInfo{$ELSE}TypInfo{$ENDIF}, {$IFDEF RTL_NAMESPACES}System.IniFiles{$ELSE}IniFiles{$ENDIF}, // OverbyteIcsWinsock, {$ENDIF} {$IFDEF POSIX} Posix.Time, Posix.SysSocket, Ics.Posix.WinTypes, Ics.Posix.PXMessages, {$ENDIF} {$Ifdef Rtl_Namespaces}System.Classes{$Else}Classes{$Endif}, {$Ifdef Rtl_Namespaces}System.Sysutils{$Else}Sysutils{$Endif}, {$IFDEF Rtl_Namespaces}System.StrUtils{$ELSE}StrUtils{$ENDIF}, {$IFDEF FMX} Ics.Fmx.OverbyteIcsWndControl, Ics.Fmx.OverbyteIcsWSocket, Ics.Fmx.OverbyteIcsWSocketS, Ics.Fmx.OverbyteIcsSslSessionCache, Ics.Fmx.OverbyteIcsSslUtils, { V9.1 } Ics.Fmx.OverbyteIcsSslBase, { V9.1 TX509Base } Ics.Fmx.OverbyteIcsSslX509Utils, {$IFDEF AUTO_X509_CERTS} Ics.Fmx.OverbyteIcsSslX509Certs, {$ENDIF} // AUTO_X509_CERTS Ics.Fmx.OverbyteIcsPing, Ics.Fmx.OverbyteIcsIcmp, {$ELSE} OverbyteIcsWndControl, OverbyteIcsWSocket, OverbyteIcsWSocketS, OverbyteIcsSslSessionCache, OverbyteIcsSslUtils, { V9.1 } OverbyteIcsSslBase, { V9.1 TX509Base } OverbyteIcsSslX509Utils, {$IFDEF AUTO_X509_CERTS} OverbyteIcsSslX509Certs, {$ENDIF} // AUTO_X509_CERTS OverbyteIcsPing, OverbyteIcsIcmp, {$ENDIF FMX} OverbyteIcsTypes, OverbyteIcsUtils, OverbyteIcsTicks64; { V8.71 } { NOTE - these components only build with SSL, there is no non-SSL option, although SSL use is optional } const CopyRight : String = ' TIcsIpStrmLog (c) 2026 V9.7 '; DefMaxIpLogLine = 4096; { V9.3, but defaults to 132 } type TStrmLogProtocol = (logprotUdpClient, logprotUdpServer, logprotTcpServer, logprotTcpClient); TStrmLogState = (logstateNone, logstateStart, logstateHandshake, logstateOK, logstateOKStream, logstateStopping, logstateError) ; { V9.3 added error } TStrmLineEnd = (lineendCR, lineendLF, lineendCustom, lineendPacket, lineendCRLF) ; TStrmVerifyMethod = (logSslVerNone, logSslVerBundle, logSslVerWinStore, logSslVerOwnEvent); { V9.3 added OwnEvent } TStrmLogRecvEvent = procedure (Sender: TObject; Socnr: integer; const Line: string) of object; TStrmLogProgEvent = procedure (Sender: TObject; Socnr: integer; LogOption: TLogOption; const Msg: string) of object; TStrmLogChangeEvent = procedure (Sender: TObject; Socnr: integer; LogState: TStrmLogState) of object; const StrmLogStateNames: array [TStrmLogState] of PChar = ('None', 'Start', 'Handshake', 'OK', 'Streaming', 'Closing', 'Error'); type TStrmChanInfo = record SendSocket: TSslWSocket; // for UDP Server/Client and TCP Client WaitTimer: TIcsTimer; // delay before next connect attempt LogState: TStrmLogState ; // current connect state AttemptNr: integer ; // failed connect attempts UnexpectedCount: integer ; // unexpected connect failures RemHost: string ; // remote IP address or host RemIP: string ; // remote IP address looked-up 2 July 2014 RemLookup: boolean ; // false if pending DNS host name look-up 2 July 2014 RemPort: string ; // remote IP port PeerIpAddr: string ; // IP address from UDP remote computer sending us data PeerIpPort: string ; // ditto port BindIpAddr: string ; // local IP address socket is bound to BindIpPort: string ; // ditto port BindFamily: TSocketFamily ; // socket family 7 Oct 2013 SocRemAddr: TSockAddrIn; // internal structure for remote UDP IPv4 address/port SocRemAddr6: TSockAddrIn6; // internal structure for remote UDP IPv6 address/port 7 Oct 2013 RxLineData: AnsiString; // received partial data line, Dec 2013 was fixed size and overflowed RxLineLen: integer ; // received data length LastLine: AnsiString ; // received last full line TotRecvData: int64 ; // 13 Sept 2016 how much data has been received and sent to LogRecvEvent event StreamFlag: boolean ; // stream currently being sent, 3 July 2014 StreamNr: integer ; // how many bytes of stream have been sent 3 July 2014 ClientId: Integer ; // server socket CliId for validation V9.3 end ; PStrmChanInfo = ^TStrmChanInfo; { V9.3 } type TIpServerClient = class(TSslWSocketClient) { V9.3 for TCP/Server, use local TStrmChanInfo } private public CliChanInfo: TStrmChanInfo; constructor Create(AOwner: TComponent); override; destructor Destroy; override; end; TIcsIpStrmLog = class(TIcsWndControl) private { Private declarations } protected { Protected declarations } FListenSocket: TSslWSocketServer ; FChanInfo: array of TStrmChanInfo ; FTotSockets: integer ; FMaxSockets: integer ; FLogActive: boolean ; FRemoteHost: string ; FRemoteIpPort: string ; FLocalIpAddr: string ; FLocalIpPort: string ; FSocFamily: TSocketFamily ; // 7 Oct 2013 FForceSsl: boolean ; // 7 Oct 2013 FPingWaitSecs: integer; FCheckPing: boolean ; FRetryAttempts: integer ; FRetryWaitSecs: integer ; FRetryNoImm: boolean ; // 7 July 2015 FAutoReconnect: boolean ; FLogProtocol: TStrmLogProtocol ; FKeepAliveSecs: integer ; FUdpNoCRLF: boolean ; FAddCRLF: boolean ; FLineEndType: TStrmLineEnd ; FCustomLineEnd: string ; // hex version FLineEndChar: AnsiChar ; // char version FMaxLineLen: integer ; FStripControls: boolean ; FRawData: boolean ; FLastErrorStr: string ; FMultipleRemotes: boolean ; FLogTitle: string ; FCurTitle: string ; FMaxSendBuffer: integer ; FSendBuffer: TBytes ; { 3 July 2014 used for send stream block reading, V8.69 was AnsiString } FSendStream: TStream ; FRxBuffer: TBytes ; { array [0..2048] of Byte; { V8.69 was AnsiChar, V8.70 now TBytes } FSndBufSize: integer; // 1.5 socket send buffer size FRcvBufSize: integer; // 1.5 socket Recv buffer size // FCurSockets: integer ; // 1.6 current sockets for server, gone V9.4 FSrvTimeoutSecs: integer ; // 5 July 2016 server idle timeout FServerTimer: TIcsTimer; // 5 July 2016 timer to check for idle timeouts FHeartBeatBusy: Boolean ; // 5 July 2016 FMaxRecvData: int64 ; // 13 Sept 2016 maximum data to receive before triggering LogRecvEvent event FCliSslContext: TSslContext; FSslSessCache: boolean; FExternalSslSessCache: TSslAvlSessionCache; FLogTrustedList: String; FLogSslVerMethod: TStrmVerifyMethod; FLogSslRevocation: boolean; FUseUtf8: Boolean; { V8.70 send and receive lines as utf8 } FSslVerLogged: Boolean; { V9.6 only log SSL version once } FWSDebugOptions: TWSDebugOptions; { V9.6 } FLogSslReportChain: boolean ; FLogSslRootFile: string; // Jan 2019 FLogSslCliSecurity: TSslCliSecurity; FLogSslCliCerts: String; FonLogRecvEvent: TStrmLogRecvEvent ; FonLogProgEvent: TStrmLogProgEvent ; FonLogChangeEvent: TStrmLogChangeEvent ; FOnHandshakeDone: TSslHandshakeDoneEvent; FOnVerifyPeer: TSslVerifyPeerEvent; FOnSslCertVerifyEvent: TSslCertVerifyEvent; { V9.3 } procedure SocketBgException(Sender: TObject; E: Exception; var CanClose: Boolean); procedure ServerClientCreate(Sender : TObject; Client : TWSocketClient); virtual; procedure ServerClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word); virtual; procedure ServerClientDisconnect(Sender: TObject; Client: TWSocketClient; Error: Word); procedure SocketSessionConnected(Sender: TObject; Error: Word); procedure SocketSessionClosed(Sender: TObject; Error: Word); procedure SocketDataAvailable(Sender: TObject; Error: Word); procedure SocketDataDnsLookupDone (Sender: TObject; Error: Word); // 2 July 2014 procedure SocketDataSent(Sender: TObject; ErrCode : word); // 3 July 2014 procedure SocketDataConnect (Socnr: integer); procedure PingThreadDone(Sender: TObject); procedure WaitTimerTimer(Sender: TObject); function GeTStrmChanInfo (Index: integer): TStrmChanInfo ; function GetState (Index: integer): TStrmLogState ; function GetAnyStateOK: boolean ; procedure IcsLogEvent (Sender: TObject; LogOption: TLogOption; const Msg : String); procedure LogProgEvent (Socnr: integer; const Msg : String); procedure LogErrEvent (Socnr: integer; const Msg : String); procedure LogChangeState (Socnr: integer; NewState: TStrmLogState) ; function PingStart (Socnr: integer): boolean ; procedure SetMaxSockets (Tot: integer) ; procedure SetRemoteHost (const NewRemHost: string) ; // procedure CheckServerSockets ; { V9.3 gone } procedure ServerTimerTimer(Sender: TObject); function GetSocket (Index: integer): TWSocket; // 7 July 2016 function GetTotRecvData (socnr: integer): int64 ; // 13 Sept 2016 procedure TlsSslNewSession(Sender: TObject; SslSession: Pointer; WasReused: Boolean; var IncRefCount : Boolean); procedure TlsSslGetSession(Sender: TObject; var SslSession: Pointer; var FreeSession : Boolean); procedure TlsSslVerifyPeer(Sender: TObject; var Ok : Integer; Cert: TX509Base); procedure TlsSslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect : Boolean); procedure TlsSslProtoMsgEvent(Sender: TObject; Info: String; Sending: integer; Version: integer; ContentType: integer; Buffer: PAnsiChar; BuffSize: integer) ; procedure SetSslCliSecurity(Value: TSslCliSecurity); // Dec 2018 function GetIcsHosts: TIcsHostCollection; // Dec 2018 procedure SetIcsHosts(const Value: TIcsHostCollection); // Dec 2018 // function GetDHParams: String; // Dec 2018 // procedure SetDHParams(const Value: String); // Dec 2018 {$IFDEF AUTO_X509_CERTS} function GetSslX509Certs: TSslX509Certs; // Dec 2018 procedure SetSslX509Certs(const Value : TSslX509Certs); // Dec 2018 {$ENDIF} // AUTO_X509_CERTS function GetSslCliCertMethod: TSslCliCertMethod; // Dec 2018 procedure SetSslCliCertMethod(const Value : TSslCliCertMethod); // Dec 2018 function GetCertExpireDays: Integer; // Dec 2018 procedure SetCertExpireDays(const Value : Integer); // Dec 2018 function GetSslCertAutoOrder: Boolean; // Dec 2018 procedure SetSslCertAutoOrder(const Value : Boolean); // Dec 2018 procedure SetLogSslRootFile(const Value: String); // May 2019 function GetSrvCliSoc(Index: integer): TIpServerClient; { V9.3 } function GetCurSockets: Integer; { V9.4 } procedure ClientDebugDisplay(Sender: TObject; const Msg: String); virtual; { V9.6 } procedure ServerDebugDisplay(Sender: TObject; const Msg: String); virtual; { V9.6 } public LogRcvdCerts: boolean ; constructor Create(AOwner: TComponent); override; destructor Destroy; override; function StartLogging: boolean ; function StopLogging: boolean ; function CheckStopped: boolean ; function SendLogLine (const Line: AnsiString; ClientId: Integer = 0): boolean ; overload; // 8 Aug 2010, V9.3 ClientId function SendLogLine (const Line: UnicodeString; ClientId: Integer = 0): boolean ; overload ; { V8.70 } function SendLogLine (const Line: TBytes; ClientId: Integer = 0): boolean ; overload ; { V8.70 } function CloseSrvCli (ClientId: Integer): boolean ; { V9.3 } function SendStream (MyStream: TStream; ClientId: Integer = 0): boolean ; // 3 Jul 2014 function SetRemotes (Socnr: integer; const NewRemHost, NewRemPort: string): boolean ; procedure ClearLine (Socnr: integer) ; procedure ResetRecvData (Socnr: integer) ; // 13 Sept 2016 function GetPartialLine (Socnr: integer): string ; function GetSendWaiting (Socnr: integer): integer ; // 6 Sept 2016 function SrvValidateHosts(Stop1stErr: Boolean=True; NoExceptions: Boolean=False; AllowSelfSign: Boolean=False): String; { V8.63 } function SrvRecheckSslCerts(var CertsInfo: String; Stop1stErr: Boolean=True; NoExceptions: Boolean=False; AllowSelfSign: Boolean=False): Boolean; { V8.63 } function GetChanInfo(Socnr: integer): PStrmChanInfo; { V9.3 } function ChanInfofromSocket(MySocket: TWSocket; var ChanInfo: PStrmChanInfo): Integer; { V9.3 } function SocnrfromSocket(MySocket: TWSocket): Integer; { V9.3 } function GetSrvSocNr(ClientId: Integer): Integer; { V9.3 } function ListenStates: String; { V9.4 } property ChanInfos [Index: integer]: TStrmChanInfo read GeTStrmChanInfo ; property States [Index: integer]: TStrmLogState read GetState ; property LogActive: boolean read FLogActive ; property AnyStateOK: boolean read GetAnyStateOK ; property TotSockets: integer read FTotSockets ; property CurSockets: integer read GetCurSockets ; // 1.6, V9.4 get dynamically property LastErrorStr: string read FLastErrorStr ; property Socket [Index: integer]: TWSocket read GetSocket; // 7 July 2016 property TotRecvData [Index: integer]: int64 read GetTotRecvData ; // 13 Sept 2016 how much data has been received and sent to LogRecvEvent event property CliSslContext: TSslContext read FCliSslContext; // Jan 2019 read only property SrvClientSoc [Index: integer]: TIpServerClient read GetSrvCliSoc; { V9.3 } published property MaxSockets: integer read FMaxSockets write SetMaxSockets ; property RemoteHost: string read FRemoteHost write SetRemoteHost ; property RemoteIpPort: string read FRemoteIpPort write FRemoteIpPort ; property SocFamily: TSocketFamily read FSocFamily write FSocFamily ; // Dec 2018 was read only property LocalIpAddr: string read FLocalIpAddr write FLocalIpAddr ; property LocalIpPort: string read FLocalIpPort write FLocalIpPort ; property SrvIcsHosts : TIcsHostCollection read GetIcsHosts write SetIcsHosts; // Dec 2019 property ForceSsl: boolean read FForceSsl write FForceSsl ; // 7 Oct 2013 property PingWaitSecs: integer read FPingWaitSecs write FPingWaitSecs ; property CheckPing: boolean read FCheckPing write FCheckPing ; property RetryAttempts: integer read FRetryAttempts write FRetryAttempts ; property RetryWaitSecs: integer read FRetryWaitSecs write FRetryWaitSecs ; property RetryNoImm: boolean read FRetryNoImm write FRetryNoImm ; // 7 July 2015 property AutoReconnect: boolean read FAutoReconnect write FAutoReconnect ; property LogProtocol: TStrmLogProtocol read FLogProtocol write FLogProtocol ; property KeepAliveSecs: integer read FKeepAliveSecs write FKeepAliveSecs ; property UdpNoCRLF: boolean read FUdpNoCRLF write FUdpNoCRLF ; property AddCRLF: boolean read FAddCRLF write FAddCRLF ; property LineEndType: TStrmLineEnd read FLineEndType write FLineEndType ; property CustomLineEnd: string read FCustomLineEnd write FCustomLineEnd ; property MaxLineLen: integer read FMaxLineLen write FMaxLineLen ; property StripControls: boolean read FStripControls write FStripControls ; property RawData: boolean read FRawData write FRawData ; property LogTitle: string read FLogTitle write FLogTitle ; property MaxSendBuffer: integer read FMaxSendBuffer write FMaxSendBuffer ; property SndBufSize: integer read FSndBufSize write FSndBufSize ; property RcvBufSize: integer read FRcvBufSize write FRcvBufSize ; property SrvTimeoutSecs: integer read FSrvTimeoutSecs write FSrvTimeoutSecs ; // 5 July 2016 property MaxRecvData: int64 read FMaxRecvData write FMaxRecvData ; // 13 Sept 2016 property LogSslCliSecurity: TSslCliSecurity read FLogSslCliSecurity write SetSslCliSecurity; property LogSslCliCerts: String read FLogSslCliCerts write FLogSslCliCerts; // Jan 2019 property SslSessCache: boolean read FSslSessCache write FSslSessCache; property ExternalSslSessCache: TSslAvlSessionCache read FExternalSslSessCache write FExternalSslSessCache; property LogTrustedList: String read FLogTrustedList write FLogTrustedList; property LogSslVerMethod: TStrmVerifyMethod read FLogSslVerMethod write FLogSslVerMethod; property LogSslRevocation: boolean read FLogSslRevocation write FLogSslRevocation; property LogSslReportChain: boolean read FLogSslReportChain write FLogSslReportChain; property LogSslRootFile: string read FLogSslRootFile write SetLogSslRootFile; // property SrvDHParams : String read GetDHParams // write SetDHParams; property SrvCertAutoOrder: Boolean read GetSslCertAutoOrder write SetSslCertAutoOrder; property CertExpireDays: Integer read GetCertExpireDays write SetCertExpireDays; property UseUtf8: Boolean read FUseUtf8 write FUseUtf8; { V8.70 } property WSDebugOptions: TWSDebugOptions read FWSDebugOptions { V9.6 Debug Log Options for OnDebugDisplay event } write FWSDebugOptions; {$IFDEF AUTO_X509_CERTS} property SrvX509Certs: TSslX509Certs read GetSslX509Certs write SetSslX509Certs; {$ENDIF} // AUTO_X509_CERTS property onLogRecvEvent: TStrmLogRecvEvent read FonLogRecvEvent write FonLogRecvEvent ; property onLogChangeEvent: TStrmLogChangeEvent read FonLogChangeEvent write FonLogChangeEvent ; property onLogProgEvent: TStrmLogProgEvent read FonLogProgEvent write FonLogProgEvent ; property OnLogVerifyPeer: TSslVerifyPeerEvent read FOnVerifyPeer write FOnVerifyPeer; property OnLogHandshakeDone: TSslHandshakeDoneEvent read FOnHandshakeDone write FOnHandshakeDone; property OnSslCertVerifyEvent: TSslCertVerifyEvent read FOnSslCertVerifyEvent write FOnSslCertVerifyEvent; { V9.3 } end; {$ENDIF USE_SSL} implementation {$IFDEF USE_SSL} constructor TIcsIpStrmLog.Create(AOwner: TComponent); begin FCliSslContext := TSslContext.Create (self) ; // Dec 2018 // create TCP Server FListenSocket := TSslWSocketServer.Create(Self); FListenSocket.SslMode := sslModeServer ; FListenSocket.ClientClass := TIpServerClient ; { V9.3 } FListenSocket.OnSslHandshakeDone := TlsSslHandshakeDone ; FListenSocket.OnDebugDisplay := ServerDebugDisplay; { V9.6 } FListenSocket.SslEnable := False; // defaulted to true, must reset AllocateHWnd; FServerTimer := TIcsTimer.Create (Self); // 5 July 2016 timer to check for idle timeouts FServerTimer.Interval := 5000 ; // 5 seconds FServerTimer.OnTimer := ServerTimerTimer ; FServerTimer.Enabled := false ; FTotSockets := 0 ; FMaxSockets := 1 ; SetMaxSockets (FMaxSockets) ; FLogActive := false ; FRemoteIpPort := '514' ; FLocalIpAddr := ICS_ANY_HOST_V4 ; FLocalIpPort := '0' ; FSocFamily := sfIpV4 ; FForceSsl := false ; FPingWaitSecs := 5 ; FCheckPing := false ; FRetryAttempts := 0 ; // 0 means try forever, -1 means none FRetryWaitSecs := 10 ; FAutoReconnect := true ; FLogProtocol := logprotUdpClient ; FKeepAliveSecs := 120 ; FUdpNoCRLF := false ; FAddCRLF := true ; FLineEndType := lineendLF ; // 4 July 2014 was CR FCustomLineEnd := '$03' ; FMaxLineLen := 132 ; FStripControls := true ; FRawData := false ; FMultipleRemotes := false ; FLogTitle := '' ; FCurTitle := 'None' ; FMaxSendBuffer := 65536 ; // 7 Sept 2016, was 16384, now same size as Windows FSndBufSize := FMaxSendBuffer ; // 1.5 socket send buffer size FRcvBufSize := FMaxSendBuffer ; // 1.5 socket Recv buffer size FSrvTimeoutSecs := 0 ; // 5 July 2016 server idle timeout FMaxRecvData := 0 ; // 13 Sept 2016 maximum data to receive before triggering LogRecvEvent event FLogSslVerMethod := logSslVerNone; FLogSslRootFile := 'RootCaCertsBundle.pem'; // blank will use internal bundle FLogSslCliSecurity := sslCliSecDefault; FSslSessCache := true; FExternalSslSessCache := nil; FWSDebugOptions := [wsdlogConnWS, wsdlogListen, wsdlogAccept, wsdlogInfo, wsdlogErrs, wsdlogDns, wsdlogSsl]; { V9.6 } inherited Create(AOwner); end; destructor TIcsIpStrmLog.Destroy; var I: integer ; begin { V8.71 Ensure inherited destroy called } try StopLogging ; FreeAndNil (FServerTimer) ; // 5 July 2016 if FTotSockets > 0 then begin for I := 0 to Pred (FTotSockets) do begin with FChanInfo [I] do begin try FreeAndNil (SendSocket) ; except end ; FreeAndNil (WaitTimer) ; end ; end ; end ; FTotSockets := 0 ; SetLength (FChanInfo, 0) ; try FreeAndNil (FListenSocket) ; except end ; FreeAndNil (FCliSslContext) ; finally inherited Destroy; end; end; constructor TIpServerClient.Create(AOwner: TComponent); { V9.3 } begin inherited Create(AOwner); end; destructor TIpServerClient.Destroy; { V9.3 } begin inherited Destroy; end; procedure TIcsIpStrmLog.SetMaxSockets (Tot: integer) ; begin FMaxSockets := Tot ; if (FLogProtocol = logprotTcpServer) then { V9.3 } Exit; // FChanInfo not actually used if Tot > FTotSockets then begin SetLength (FChanInfo, Tot) ; end ; while FTotSockets < Tot do begin with FChanInfo [FTotSockets] do begin LogState := logstateNone ; ClientId := FTotSockets; { V9.3 effectively Socnr } SendSocket := Nil ; if NOT (FLogProtocol = logprotTcpServer) then // 5 July 2016 begin WaitTimer := TIcsTimer.Create (Self) ; WaitTimer.Enabled := false ; WaitTimer.OnTimer := WaitTimerTimer ; end; end ; inc (FTotSockets) ; end ; end ; procedure TIcsIpStrmLog.IcsLogEvent (Sender: TObject; LogOption: TLogOption; const Msg : String); var socnr: integer ; begin if Sender is TWSocket then begin if (FLogProtocol = logprotTcpServer) then { V9.3 } socnr := (Sender as TIpServerClient).Cliid else socnr := (Sender as TWSocket).Tag; end else socnr := 0; if Assigned (FonLogProgEvent) then FonLogProgEvent (Self, Socnr, LogOption, FCurTitle + ' ' + Msg) ; end ; procedure TIcsIpStrmLog.LogProgEvent (Socnr: integer; const Msg : String); begin if Assigned (FonLogProgEvent) then FonLogProgEvent (Self, Socnr, loProtSpecInfo, Msg) ; end ; procedure TIcsIpStrmLog.LogErrEvent (Socnr: integer; const Msg : String); begin if Assigned (FonLogProgEvent) then FonLogProgEvent (Self, Socnr, loProtSpecErr, Msg) ; end ; procedure TIcsIpStrmLog.LogChangeState (Socnr: integer; NewState: TStrmLogState) ; var MyChanInfo: PStrmChanInfo; begin MyChanInfo := GetChanInfo(Socnr); if MyChanInfo = Nil then Exit; with MyChanInfo^ do begin if LogState = NewState then exit ; LogState := NewState ; end; if Assigned (FonLogChangeEvent) then FonLogChangeEvent (Self, Socnr, NewState) ; end ; // TCP client only function TIcsIpStrmLog.SetRemotes (Socnr: integer; const NewRemHost, NewRemPort: string): boolean ; var MyFamily: TSocketFamily; begin result := false ; if (Socnr < 0) or (Socnr >= FTotSockets) then begin FLastErrorStr := FCurTitle + ' Insufficient Sockets Configured' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; FMultipleRemotes := true ; with FChanInfo [Socnr] do begin RemHost := '' ; RemPort := '' ; if atoi (NewRemPort) <= 0 then begin FLastErrorStr := FCurTitle + ' No Remote Port Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if NewRemHost = '' then begin FLastErrorStr := FCurTitle + ' No Remote Host Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; RemHost := NewRemHost ; RemPort := NewRemPort ; { Dec 2018 If the address is either a valid IPv4 or IPv6 address, change current SocketFamily } if WSocketIsIP(NewRemHost, MyFamily) then begin if (MyFamily = sfIPv4) or (IsIPv6APIAvailable) then BindFamily := MyFamily ; end; end ; if Socnr = 0 then begin FRemoteHost := NewRemHost ; FRemoteIpPort := NewRemPort ; // Nov 2016 end; result := true ; end; procedure TIcsIpStrmLog.SetRemoteHost (const NewRemHost: string) ; var I: integer ; begin if FMultipleRemotes then begin for I := 0 to Pred (FTotSockets) do FChanInfo [I].RemHost := '' ; FMultipleRemotes := false ; end ; FRemoteHost := NewRemHost ; end ; procedure TIcsIpStrmLog.SetLogSslRootFile(const Value: String); // May 2019 var rootfname: String; begin if Value = FLogSslRootFile then Exit; FLogSslRootFile := Value; if FLogProtocol = logprotTcpServer then begin rootfname := FLogSslRootFile; if rootfname <> '' then begin if (Pos (':', rootfname) = 0) then rootfname := ExtractFileDir (ParamStr (0)) + '\' + rootfname ; if FileExists (rootfname) then FListenSocket.RootCA := rootfname; end; end; end; // V9.3 find TCP Server client number from ClientId function TIcsIpStrmLog.GetSrvSocNr(ClientId: Integer): Integer; var I: Integer; begin Result := -1; if FLogProtocol <> logprotTcpServer then Exit; if FListenSocket.ClientCount = 0 then Exit; for I := 0 to Pred (FListenSocket.ClientCount) do begin if FListenSocket.Client [I].CliId = ClientId then begin Result := I; Exit; end; end; end; { V9.3 Socnr from Socket } function TIcsIpStrmLog.SocnrfromSocket(MySocket: TWSocket): Integer; begin // Result := -1; try if (FLogProtocol = logprotTcpServer) then begin Result := (MySocket as TIpServerClient).CliId; end else begin Result := MySocket.Tag; if (Result >= FTotSockets) then Result := -1; end; except Result := -1; FLastErrorStr := FCurTitle + ' Error Find Socnr - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end; { V9.3 TCP server has channel info in client, not table, so set pointer to correct location } { returns Socnr and pointer to ChanInfo } function TIcsIpStrmLog.ChanInfofromSocket(MySocket: TWSocket; var ChanInfo: PStrmChanInfo): Integer; begin // Result := -1; ChanInfo := Nil; try if (FLogProtocol = logprotTcpServer) then begin ChanInfo := @(MySocket as TIpServerClient).CliChanInfo; Result := (MySocket as TIpServerClient).CliId; end else begin Result := MySocket.Tag; if (Result >= 0) and (Result < FTotSockets) then ChanInfo := @FChanInfo [Result]; end; if Assigned(ChanInfo) then begin if ChanInfo^.ClientId <> Result then begin // raise exception if channel information not found FLastErrorStr := 'Pointer Error'; Result := -1; end; end; except ChanInfo := Nil; Result := -1; FLastErrorStr := FCurTitle + ' Error Find Channel Info - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end; // V9.3 get a pointer to channel information record, either from array or server client } function TIcsIpStrmLog.GetChanInfo(Socnr: integer): PStrmChanInfo; { V9.3 } var I: Integer; begin Result := Nil; if (FLogProtocol = logprotTcpServer) then begin if Socnr < 1 then Exit; I := GetSrvSocNr(Socnr); if I >= 0 then Result := @(FListenSocket.Client[I] as TIpServerClient).CliChanInfo; end else begin if (Socnr >= 0) or (Socnr < FTotSockets) then Result := @FChanInfo [Socnr]; end; if (FLastErrorStr <> '') then LogErrEvent(0, FLastErrorStr) ; end; function TIcsIpStrmLog.GetStrmChanInfo (Index: integer): TStrmChanInfo ; var MyChanInfo: PStrmChanInfo; begin MyChanInfo := GetChanInfo(Index); { V9.3 using ClientId for server } if MyChanInfo <> Nil then Result := MyChanInfo^; end; function TIcsIpStrmLog.GetState (Index: integer): TStrmLogState ; var MyChanInfo: PStrmChanInfo; begin Result := logstateNone; MyChanInfo := GetChanInfo(Index); { V9.3 using ClientId for server } if MyChanInfo <> Nil then result := MyChanInfo^.LogState ; end; // 7 July 2016 get current socket function TIcsIpStrmLog.GetSocket (Index: integer): TWSocket; var I: Integer; begin Result := nil ; if FLogProtocol = logprotTcpServer then begin if Index < 1 then Exit; I := GetSrvSocNr(Index); { V9.3 using ClientId for server } if I >= 0 then Result := FListenSocket.Client[I] as TWSocket ; end else begin if (Index < 0) or (Index >= FTotSockets) then Index := 0 ; Result := FChanInfo [Index].SendSocket ; end; end; // get current server client socket, TCP Server only function TIcsIpStrmLog.GetSrvCliSoc(Index: integer): TIpServerClient; { V9.3 } var I: Integer; begin Result := nil ; if Index < 1 then Exit; if FLogProtocol = logprotTcpServer then begin I := GetSrvSocNr(Index); if I >= 0 then Result := FListenSocket.Client[I] as TIpServerClient; end; end; // check if any socket is connected and able to send data or stream // but not if a stream is still being sent function TIcsIpStrmLog.GetAnyStateOK: boolean ; var I: integer ; begin result := false ; if FMaxSockets <= 0 then exit ; if FLogProtocol = logprotTcpServer then begin { V9.1 server clients have own chaninfo } if FListenSocket.ClientCount = 0 then Exit; for I := 0 to FListenSocket.ClientCount - 1 do begin if TIpServerClient(FListenSocket.Client[I]).CliChanInfo.LogState = logstateOK then result := true ; end; end else begin for I := 0 to Pred (FMaxSockets) do begin if (FChanInfo [I].LogState = logstateOKStream) then begin // send a stream result := false ; exit ; end; if (FChanInfo [I].LogState = logstateOK) then result := true ; end ; end; end; // list states of server listen sockets function TIcsIpStrmLog.ListenStates: String; { V9.4 } var I: Integer; begin Result := ''; if NOT FLogActive then Exit; if FLogProtocol = logprotUdpServer then begin if (FTotSockets > 0) then begin for I := 0 to FTotSockets - 1 do with FChanInfo [I].SendSocket do begin Result := Result + 'Socket ' + IntToStr(I - 1) + ' State: ' + SocketStateNames[State] + ' ' + SocketFamilyNames [SocketFamily] + ' on ' + Addr + ' port ' + Port + IcsCRLF; end; end; end else if FLogProtocol = logprotTcpServer then Result := FListenSocket.ListenStates; end; // start logging, open various sockets and starts connections, but // connection may not be completed when this function exits, keep calling // GetAnyStateOK to see if any sockets are connected or trigger from // onLogChangeEvent with LogState = logstateOK function TIcsIpStrmLog.StartLogging: boolean ; var I, tothosts: integer ; MyFamily: TSocketFamily; begin result := false ; FLastErrorStr := '' ; if (NOT FMultipleRemotes) or (FLogProtocol = logprotUdpServer) then tothosts := 1 else tothosts := FMaxSockets ; if Length (FCustomLineEnd) >= 1 then begin if '$' = FCustomLineEnd [1] then FLineEndChar := AnsiChar (StrToIntDef (Copy (FCustomLineEnd, 1, 3), 0)) else FLineEndChar := AnsiChar (FCustomLineEnd [1]) ; end ; if FMaxLineLen > DefMaxIpLogLine then { V9.3 sanity check } FMaxLineLen := DefMaxIpLogLine; if FLogActive then begin FLastErrorStr := FCurTitle + ' Log Client Already Busy' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; // Dec 2018, load DLLs before cert functions if FForceSsl and (FLogProtocol in [logprotTcpServer, logprotTcpClient]) then begin try if NOT FSslVerLogged then begin { V9.6 only once } FSslVerLogged := True; IcsSslRootCAStore.Initialise; { V9.1 if OpenSSL and internal not loaded, do it } LogProgEvent (0, 'SSL/TLS DLL: ' + IcsReportOpenSSLVer(True)); { V9.1 simplify } end; except FLastErrorStr := FCurTitle + ' Error Starting SSL - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; exit ; end; end; // validate some settings, Oct 2015 was after SSL stuff if FLogProtocol in [logprotUdpClient, logprotTcpClient] then begin if FLogTitle <> '' then FCurTitle := FLogTitle else begin if FLogProtocol in [logprotUdpClient] then FCurTitle := 'UDP/Client' else FCurTitle := 'TCP/Client' ; end ; if tothosts = 1 then begin if atoi (FRemoteIpPort) <= 0 then begin FLastErrorStr := FCurTitle + ' No Remote Port Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if FRemoteHost = '' then begin FLastErrorStr := FCurTitle + ' No Remote Host Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; // Dec 2018 If the address is either a valid IPv4 or IPv6 address, change current SocketFamily if WSocketIsIP(FRemoteHost, MyFamily) then begin if (MyFamily = sfIPv4) or (IsIPv6APIAvailable) then FSocFamily := MyFamily ; end; end else begin for I := 0 to Pred (tothosts) do // Nov 2016 check all clients begin with FChanInfo [I] do begin if atoi (RemPort) <= 0 then begin FLastErrorStr := FCurTitle + ' No Remote Port Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if RemHost = '' then begin FLastErrorStr := FCurTitle + ' No Remote Host Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; // Dec 2018 If the address is either a valid IPv4 or IPv6 address, change current SocketFamily if WSocketIsIP(RemHost, MyFamily) then begin if (MyFamily = sfIPv4) or (IsIPv6APIAvailable) then BindFamily := MyFamily ; end; end; end; end; end else if FLogProtocol in [logprotUdpServer] then begin if atoi (FLocalIpPort) <= 0 then begin FLastErrorStr := FCurTitle + ' No Local Port Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if FLogTitle <> '' then FCurTitle := FLogTitle else FCurTitle := 'UDP/Server' ; end // note all TCP/IP Server IcsHosts must be setup before starting in // application, with SSL certificates and bindings else if FLogProtocol in [logprotTcpServer] then begin if FListenSocket.IcsHosts.Count = 0 then // Dec 2018 begin FLastErrorStr := FCurTitle + ' No Server Hosts Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; FListenSocket.WSDebugOptions := FWSDebugOptions; { V9.6 } if FLogSslReportChain then FListenSocket.WSDebugOptions := FListenSocket.WSDebugOptions + [wsdlogCerts]; FLastErrorStr := FListenSocket.ValidateHosts(True, True, True); { V8.63 allow self sign } if (NOT FListenSocket.Validated) or { V8.64 stop if not validated } (FListenSocket.IcsHosts [0].CertValRes = chainFail) then { V8.63 don't stop on warning, only fatal error } begin FLastErrorStr := FCurTitle + ' ' + FLastErrorStr ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if FLogTitle <> '' then FCurTitle := FLogTitle else FCurTitle := 'TCP/Server' ; if FForceSsl and FLogSslReportChain then begin for I := 0 to Pred(FListenSocket.IcsHosts.Count) do begin if FListenSocket.IcsHosts [I].CertValRes = chainFail then { V8.63 any other failures } begin FLastErrorStr := FCurTitle + FLastErrorStr; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if (FListenSocket.IcsHosts[I].CertInfo <> '') then LogErrEvent (0, FListenSocket.IcsHosts[I].CertInfo) ; end; end; end else begin FLastErrorStr := FCurTitle + ' Unknown Protocol' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; // SSL stuff if FForceSsl then begin try FCliSslContext.SslSessionCacheModes := []; FCliSslContext.SslVerifyPeer := false; FCliSslContext.SslVerifyPeerModes := [] ; if not Assigned (FExternalSslSessCache) then begin FExternalSslSessCache := TSslAvlSessionCache.Create (self); end; if FLogProtocol = logprotTcpClient then begin FCliSslContext.SslCipherList := sslCiphersNormal; FCliSslContext.SslOptions2 := FCliSslContext.SslOptions2 + [sslOpt2_NO_SESSION_RESUMPTION_ON_RENEGOTIATION, sslOpt2_NO_RENEGOTIATION]; FCliSslContext.SslECDHMethod := sslECDHAuto; FCliSslContext.SslCliSecurity := FLogSslCliSecurity; // see if verifying server SSL certificate if FLogSslVerMethod > logSslVerNone then begin FCliSslContext.SslVerifyPeer := true ; // FCliSslContext.SslOcspStatus := true; { V8.69 use OCSP stapling to get revoked status } FCliSslContext.SslVerifyPeerModes := [SslVerifyMode_PEER] ; if fSslSessCache then begin FCliSslContext.SslSessionCacheModes := [sslSESS_CACHE_CLIENT, sslSESS_CACHE_NO_INTERNAL_LOOKUP, sslSESS_CACHE_NO_INTERNAL_STORE] ; end; if (FLogSslVerMethod >= logSslVerBundle) then begin FCliSslContext.UseSharedCAStore := True; { V9.1 ignore FLogSslRootFile for now } end; end; if NOT FCliSslContext.IsCtxInitialized then begin FCliSslContext.InitContext; end; end ; except FLastErrorStr := FCurTitle + ' Error Starting SSL - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; exit ; end; end ; // clean up old stuff for I := 0 to Pred (FTotSockets) do begin with FChanInfo [I] do begin LogState := logstateNone ; AttemptNr := 0 ; UnexpectedCount := 0 ; PeerIpAddr := '' ; PeerIpPort := '' ; BindIpAddr := '' ; BindIpPort := '' ; BindFamily := sfAny ; RxLineLen := 0 ; SetLength (RxLineData, FMaxLineLen + 8) ; // Dec 2014 dynamic size if FMaxLineLen > FMaxSendBuffer then FMaxSendBuffer := (FMaxLineLen * 2) + 10 ; // Dec 2014 sanity check SetLength (LastLine, 0) ; TotRecvData := 0 ; // 13 Sept 2016 how much data has been received and sent to LogRecvEvent event FillChar (SocRemAddr, Sizeof (SocRemAddr), 0); FillChar (SocRemAddr6, Sizeof (SocRemAddr6), 0); if Assigned (WaitTimer) then // 8 July 2016 begin with WaitTimer do begin Enabled := false ; Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; // warning, may be changed Tag := I ; // keep socnr end ; end; end ; end ; // create send data sockets, may be more than one for TCP Client to send to multiple servers if FLogProtocol in [logprotUdpClient, logprotTcpClient, logprotUdpServer] then begin for I := 0 to Pred (tothosts) do begin with FChanInfo [I] do begin LogState := logstateNone ; try FreeAndNil (SendSocket) ; except end ; SendSocket := TSslWSocket.Create (Self) ; with SendSocket do begin Tag := I; LingerOnOff := wsLingerOff; LingerTimeout := 0; LineMode := false; CreateCounter ; // 4 July 2016 duration, last activity ComponentOptions := [wsoNoReceiveLoop {wsoIcsDnsLookup} ]; // Mar 2017 V9.7 gone // pending - skips DnsLookup,but too many changes // ComponentOptions := ComponentOptions + [wsoAsyncDnsLookup]; // !!! TEMP OnDataAvailable := SocketDataAvailable ; OnBgException := SocketBgException ; SocketErrs := wsErrFriendly ; // Oct 2016 SetAcceptableHostsList (FLogTrustedList); OnDebugDisplay := ClientDebugDisplay; { V9.6 } end ; SendSocket.SslCertVerMethod := TCertVerMethod(FLogSslVerMethod); { V9.6 } SendSocket.SslAllowSelfSign := True ; { V9.6 } SendSocket.OnSslCertVerifyEvent := FOnSslCertVerifyEvent; { V9.6 } SendSocket.WSDebugOptions := FWSDebugOptions; { V9.6 } if FLogSslReportChain then { V9.6 } SendSocket.WSDebugOptions := SendSocket.WSDebugOptions + [wsdlogCerts]; // note, multiple remhost already set by SetRemoteHost or SetRemoteHosts end ; end ; if tothosts = 1 then // Nov 2016 begin FChanInfo [0].RemHost := FRemoteHost ; FChanInfo [0].RemPort := FRemoteIpPort ; FChanInfo [0].BindFamily := FSocFamily ; end; end ; // set sockets parameters, then connect or listen try // except if FLogProtocol = logprotUdpClient then begin for I := 0 to Pred (tothosts) do begin with FChanInfo [I] do begin if RemHost = '' then continue ; // skip unused socket with SendSocket do begin OnDnsLookupDone := SocketDataDnsLookupDone ; // 2 July 2014 OnDataSent := SocketDataSent ; // 3 July 2014 SocketErrs := wsErrFriendly ; // Oct 2016 StreamFlag := false ; StreamNr := 0 ; Tag := I ; // keep socnr RemLookup := WSocketIsIPEx (RemHost, MyFamily) ; // 2 July 2014 true if real IP address RemIP := RemHost ; if FCheckPing then // note UDP continue to ping while connected begin // as an attempt to catch a lost connection if PingStart (I) then begin LogChangeState (I, logstateStart) ; LogProgEvent (I, FCurTitle + ' Start Ping to ' + IcsFmtIpv6Addr (RemHost)) ; result := true ; FLogActive := true ; end else begin FLastErrorStr := FCurTitle + ' Ping Remote Failed' ; LogErrEvent (0, FLastErrorStr) ; end ; end else begin LogChangeState (I, logstateStart) ; if NOT RemLookup then begin LogProgEvent (I, FCurTitle + ' Looking up Host Name ' + RemHost) ; DnsLookup (RemHost) ; end else begin SocketDataConnect (I) ; end; end ; end ; end ; FLogActive := true ; result := true ; end ; end else if FLogProtocol = logprotUdpServer then begin with FChanInfo [0] do begin with SendSocket do begin OnDataSent := SocketDataSent ; // 3 July 2014 StreamFlag := false ; StreamNr := 0 ; Proto := 'udp' ; Tag := 0 ; // only single listen socket Addr := FLocalIpAddr ; Port := FLocalIpPort ; SocketFamily := FSocFamily ; // ReuseAddr := True; { V9.3 allow multiple applications to listen on same IP/port for broadcasts // ExclusiveAddr := true ; // Oct 2016 V9.3 why? Listen ; if (FRcvBufSize > SocketRcvBufSize) then SocketRcvBufSize := FRcvBufSize ; { V8.65 only increase size } // if (FSndBufSize > SocketSndBufSize) then // SocketSndBufSize := FSndBufSize ; { V8.65 only increase size, V9.3 error once ReuseAddr set } end ; LogProgEvent (0, FCurTitle + ' Started on Address ' + IcsFmtIpv6AddrPort (FLocalIpAddr, FLocalIpPort)) ; LogChangeState (0, logstateOK) ; end ; result := true ; FLogActive := true ; end else if FLogProtocol = logprotTcpClient then begin for I := 0 to Pred (tothosts) do begin with FChanInfo [I] do begin if RemHost = '' then continue ; // skip unused socket with SendSocket do begin if Assigned (WaitTimer) then // June 2018 WaitTimer.Enabled := false ; OnSessionConnected := SocketSessionConnected ; OnSessionClosed := SocketSessionClosed; OnDnsLookupDone := SocketDataDnsLookupDone ; // 2 July 2014 OnDataSent := SocketDataSent ; // 3 July 2014 SocketErrs := wsErrFriendly ; // Oct 2016 StreamFlag := false ; StreamNr := 0 ; if FKeepAliveSecs = 0 then KeepAliveOnOff := wsKeepAliveOnSystem else begin KeepAliveOnOff := wsKeepAliveOnCustom ; KeepAliveTime := FKeepAliveSecs * Integer (TicksPerSecond) ; // how often if FKeepAliveSecs < 10 then KeepAliveInterval := TicksPerSecond else KeepAliveInterval := (FKeepAliveSecs div 5) * Integer (TicksPerSecond); // repeat if failed end ; Tag := I ; // keep socnr RemLookup := WSocketIsIPEx (RemHost, MyFamily) ; // 2 July 2014 true if real IP address Addr := RemHost; { V9.6 } RemIP := RemHost ; SslServerName := RemHost ; // Nov 2016 if FCheckPing then begin if PingStart (I) then begin LogChangeState (I, logstateStart) ; LogProgEvent (I, FCurTitle + ' Start Ping to ' + IcsFmtIpv6Addr (RemHost)) ; end else begin FLastErrorStr := FCurTitle + ' Ping Remote Failed' ; LogErrEvent (0, FLastErrorStr) ; end ; end else begin LogChangeState (I, logstateStart) ; if NOT RemLookup then begin LogProgEvent (I, FCurTitle + ' Looking up Host Name ' + RemHost) ; DnsLookup (RemHost) ; end else begin SocketDataConnect (I) ; end; end ; end ; end ; result := true ; FLogActive := true ; end ; end else if FLogProtocol = logprotTcpServer then begin FServerTimer.Enabled := (FSrvTimeoutSecs > 10) ; with FListenSocket do begin MaxClients := FMaxSockets ; Banner := '' ; BannerTooBusy := 'Too Many Remote Connections' ; // 4 Jan 2012 onClientCreate := ServerClientCreate; OnClientConnect := ServerClientConnect; OnClientDisconnect := ServerClientDisconnect; OnBgException := SocketBgException ; SocketErrs := wsErrFriendly ; // Oct 2016 OnDebugDisplay := ServerDebugDisplay; { V9.6 } Proto := 'tcp' ; Tag := 0 ; // only single listen socket ExclusiveAddr := true ; // Oct 2016 FLastErrorStr := MultiListenEx ; // start listening for incoming connections if FLastErrorStr = '' then begin // V8.62 ensure all listeners started result := true ; FLogActive := true ; // for I := 0 to Pred (IcsHosts.Count) do V9.6 logging done in WSockets // LogProgEvent (0, FCurTitle + ' Started on ' + IcsHosts[I].BindInfo); // May 2019 // LogProgEvent (0, FCurTitle + ' ' + Trim(ListenStates)); { V8.64 show dynamic port } end else LogErrEvent (0, FLastErrorStr) ; end; end ; except FLastErrorStr := FCurTitle + ' Error Starting - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end ; // stop everything, but note sockets may not have cleanly closed when // this function exits, keep calling CheckStopped until it returns true function TIcsIpStrmLog.StopLogging: boolean ; var I: integer ; begin result := false ; FLastErrorStr := '' ; if NOT FLogActive then begin result := true ; exit ; end ; FLogActive := false ; if FTotSockets <= 0 then exit ; if FLogProtocol = logprotTcpServer then begin if Assigned (FServerTimer) then FServerTimer.Enabled := false ; // FreeAndNil (FServerTimer) ; if Assigned(FListenSocket) then begin try if FListenSocket.State <> wsClosed then FListenSocket.MultiClose; if FListenSocket.ClientCount > 0 then begin for I := 0 to Pred (FListenSocket.ClientCount) do begin if FListenSocket.Client [I].State = wsConnected then begin LogChangeState (I, logstateStopping) ; FListenSocket.Client [I].Close ; end ; end ; end ; except end ; end ; LogProgEvent (0, FCurTitle + ' Stopped') ; end ; for I := 0 to Pred (FTotSockets) do begin with FChanInfo [I] do begin try if (LogState <> logstateNone) then begin if Assigned (SendSocket) then begin if Assigned (WaitTimer) then // 8 July 2016 WaitTimer.Enabled := false ; if (LogState = logstateStart) and (NOT RemLookup) then // 4 July 2014 begin try SendSocket.CancelDnsLookup; except end; end; if SendSocket.State <> wsClosed then begin LogChangeState (I, logstateStopping) ; SendSocket.Close ; if FLogProtocol <> logprotTcpClient then // 20 Aug 2009 event only if open LogProgEvent (I, FCurTitle + ' Stopped') ; end ; end ; // LogChangeState (I, logstateNone) ; end ; except end ; // LogState := logstateNone ; // final clean-up end ; end ; end ; // see if sockets have all cleanly closed, then destroy them // called after StopLogging before destroying component function TIcsIpStrmLog.CheckStopped: boolean ; var I: integer ; begin result := false ; FLastErrorStr := '' ; if FLogActive then exit ; result := true ; if FTotSockets <= 0 then exit ; if FLogProtocol = logprotTcpServer then begin if Assigned(FListenSocket) then begin try if (FListenSocket.State <> wsClosed) or (FListenSocket.ClientCount > 0) then result := false; except end ; end ; end ; for I := 0 to Pred (FTotSockets) do begin with FChanInfo [I] do begin try if Assigned (SendSocket) then begin if SendSocket.State <> wsClosed then result := false else begin FreeAndNil (SendSocket) ; end; end ; except end ; end ; end ; end ; procedure TIcsIpStrmLog.SocketBgException(Sender: TObject; E: Exception; var CanClose: Boolean); begin FLastErrorStr := FCurTitle + ' Fatal Error - ' + IcsGetExceptMess (E) ; // June 2018 LogErrEvent (0, FLastErrorStr) ; CanClose := true ; end ; // TCP/Client another connection attempt timer // UDP/Client pings continually during connection to see if remote is lost procedure TIcsIpStrmLog.WaitTimerTimer(Sender: TObject); var socnr: integer; begin socnr := (Sender as TIcsTimer).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; with FChanInfo [socnr] do begin WaitTimer.Enabled := false ; if FLogProtocol = logprotUdpClient then begin if NOT FCheckPing then exit ; // should not happen // LogProgEvent (socnr, FCurTitle + ' Starting Ping to ' + IcsIcsFmtIpv6Addr (RemHost)) ; // TEMP !!! if NOT PingStart (socnr) then begin FLastErrorStr := FCurTitle + ' Ping Failed' ; LogErrEvent (socnr, FLastErrorStr) ; end ; end else if FLogProtocol = logprotTcpClient then begin with SendSocket do begin try Proto := 'tcp' ; Tag := socnr ; // keep socnr Addr := RemHost ; Port := RemPort ; LocalAddr := FLocalIpAddr ; LocalPort := FLocalIpPort ; if FCheckPing then begin if PingStart (socnr) then begin LogChangeState (socnr, logstateStart) ; end else begin FLastErrorStr := FCurTitle + ' Ping Failed' ; LogErrEvent (socnr, FLastErrorStr) ; end ; end else begin if NOT RemLookup then begin LogProgEvent (socnr, FCurTitle + ' Looking up Host Name ' + RemHost) ; DnsLookup (RemHost) ; end else begin SocketDataConnect (socnr) ; end; LogChangeState (socnr, logstateStart) ; end ; except FLastErrorStr := FCurTitle + ' Error Starting - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (socnr, FLastErrorStr) ; end; end ; end ; end ; end ; // TCP and UDP client, start a ping function TIcsIpStrmLog.PingStart (Socnr: integer): boolean ; begin result := false ; if Socnr < 0 then exit ; try with FChanInfo [Socnr] do begin WaitTimer.Enabled := false ; with TPingThread.Create (True) do // create suspended begin FreeOnTerminate := True; PingId := Socnr ; OnTerminate := PingThreadDone ; PingHostName := RemHost ; PingSocketFamily := BindFamily ; // Nov 2013 PingSrcAddress := ICS_ANY_HOST_V4 ; PingSrcAddress6 := ICS_ANY_HOST_V6 ; if FPingWaitSecs <= 0 then FPingWaitSecs := 10 ; PingTimeout := FPingWaitSecs * Integer (TicksPerSecond) ; PingTTL := 40 ; // hops PingLookupReply := false ; // reverse DNS {$IFDEF COMPILER14_UP} Start; {$ELSE} Resume; {$ENDIF} result := true ; end ; end ; except end ; end ; // TCP and UDP client - ping completed to remote client - success or fail procedure TIcsIpStrmLog.PingThreadDone (Sender: TObject); var socnr: integer; begin socnr := 0 ; try with Sender as TPingThread do // this event is thread safe begin socnr := PingId ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; with FChanInfo [socnr] do begin WaitTimer.Enabled := false ; inc (AttemptNr) ; if LogState in [LogStateNone, LogStateStopping] then exit ; // stopped already if ErrCode = 0 then begin if NOT RemLookup then // 2 July 2014 keep real remote IP address begin RemIp := DnsHostIP ; BindFamily := PingSocketFamily ; RemLookup := true ; LogProgEvent (socnr, FCurTitle + ' Name Looked up OK, Address ' + RemIp) ; end; if DnsHostIP <> ReplyIPAddr then begin FLastErrorStr := FCurTitle + ' Ping Did Not Reach Host, Request IP ' + IcsFmtIpv6Addr (DnsHostIP) + ', Reply IP ' + IcsFmtIpv6Addr (ReplyIPAddr) ; LogErrEvent (socnr, FLastErrorStr) ; ErrCode := 99 ; end ; end ; if ErrCode = 0 then begin try if FLogProtocol = logprotUdpClient then begin AttemptNr := 0 ; if LogState <> logstateOK then begin SocketDataConnect (socnr) ; end ; // UDP keeps pinging to ensure remote host is still there WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; WaitTimer.Enabled := true ; end else if FLogProtocol = logprotTcpClient then begin with SendSocket do begin if State in [wsConnecting, wsConnected] then begin FLastErrorStr := FCurTitle + ' !! Warning, Data Socket Already Connecting or Connecting to Server' ; LogErrEvent (socnr, FLastErrorStr) ; exit ; end ; end ; SocketDataConnect (socnr) ; end ; except FLastErrorStr := FCurTitle + ' Error Connection - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (socnr, FLastErrorStr) ; end ; end else // ping failed, may retry in a few seconds begin if FLogProtocol = logprotUdpClient then begin if LogState = logstateOK then begin SendSocket.Close ; LogChangeState (socnr, logstateStart) ; FLastErrorStr := FCurTitle + ' Unexpected Disconnect - Attempting to Reconnect' ; LogErrEvent (socnr, FLastErrorStr) ; end ; end ; FLastErrorStr := FCurTitle + ' Failed Ping to ' + IcsFmtIpv6Addr (RemHost) ; if (AttemptNr >= FRetryAttempts) and (FRetryAttempts > 0) then begin LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; FLastErrorStr := FLastErrorStr + ' After Total Retries ' + IntToStr (AttemptNr) ; end else begin if (FRetryAttempts >= 0) then { V8.69 -1 means no retry attempts, 0 mean try for ever } begin LogChangeState (socnr, logstateStart) ; FLastErrorStr := FLastErrorStr + ', Retrying in ' + IntToStr (FRetryWaitSecs) + ' secs' ; WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; WaitTimer.Enabled := true ; end else begin LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; end; end ; LogErrEvent (socnr, FLastErrorStr) ; end ; end ; end ; except FLastErrorStr := FCurTitle + ' Error Ping Done - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (socnr, FLastErrorStr) ; end ; end ; // 2 July 2014, centralised all UDP and TCP Client open connections here procedure TIcsIpStrmLog.SocketDataConnect (Socnr: integer); var Success: Boolean ; begin if (socnr < 0) or (socnr >= FTotSockets) then exit ; with FChanInfo [socnr] do begin if (LogState <> logstateStart) then begin FLastErrorStr := FCurTitle + ' Connection Cancelled, Stopping' ; LogErrEvent (0, FLastErrorStr) ; exit ; end; with SendSocket do begin try Tag := socnr ; if FLogProtocol = logprotUdpClient then begin Proto := 'udp' ; if SocketFamily = sfIPv6 then begin SocRemAddr6.sin6_family := AF_INET6 ; SocRemAddr6.sin6_addr := TInAddr6 (WSocketStrToIPv6 (RemIP, Success)) ; SocRemAddr6.sin6_port := WSocket_htons (atoi (RemPort)) ; end else begin SocRemAddr.sin_family := AF_INET ; SocRemAddr.sin_addr.S_addr := WSocket_inet_addr (RemIP) ; { V8.70 } SocRemAddr.sin_port := WSocket_htons (atoi (RemPort)) ; end ; end else begin Proto := 'tcp' ; end; // Addr := RemIp ; { V9.6 don't corrupt host name } LineMode := false; Port := RemPort ; SocketFamily := BindFamily ; LocalAddr := FLocalIpAddr ; LocalPort := FLocalIpPort ; SetSinConn(RemIp, RemPort, Proto); { V9.6 set FSIN IP address ready for connect, sets resolved } Connect; if FLogProtocol = logprotUdpClient then begin if (FRcvBufSize > SocketRcvBufSize) then SocketRcvBufSize := FRcvBufSize ; { V8.65 only increase size } if (FSndBufSize > SocketSndBufSize) then SocketSndBufSize := FSndBufSize ; { V8.65 only increase size } LogProgEvent (socnr, FCurTitle + ' Connected OK to ' + IcsFmtIpv6AddrPort (RemHost, RemPort)) ; LogChangeState (socnr, logstateOK) ; FLogActive := true ; end else begin LogChangeState (socnr, logstateStart) ; // LogProgEvent (socnr, FCurTitle + ' Opening Connection to ' + IcsFmtIpv6AddrPort (RemHost, RemPort)) ; end; except FLastErrorStr := FCurTitle + ' Error Starting - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (socnr, FLastErrorStr) ; end ; end end; end; // 2 July 2014, TCP/IP Client, DNS lookup down procedure TIcsIpStrmLog.SocketDataDnsLookupDone (Sender: TObject; Error: Word); var MyFamily: TSocketFamily; socnr: integer; begin socnr := (Sender as TWSocket).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; with FChanInfo [socnr] do begin if Error = 0 then begin try if (LogState <> logstateStart) then begin FLastErrorStr := FCurTitle + ' Connection Cancelled, Stopping' ; LogErrEvent (0, FLastErrorStr) ; exit ; end; with SendSocket do begin if NOT RemLookup then begin RemIp := DnsResult ; // keep DNS lookup // LogProgEvent (socnr, FCurTitle + ' Name Looked up OK, Address ' + RemIp) ; V9.6 done in WSocket // pending, may be multiple results, could choose randomly if WSocketIsIPEx (RemIp, MyFamily) then BindFamily := MyFamily; end; RemLookup := true ; SocketDataConnect (socnr) ; end ; except RemLookup := false ; FLastErrorStr := FCurTitle + ' Exception DNS Result - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (socnr, FLastErrorStr) ; end ; end else begin RemLookup := false ; inc (AttemptNr) ; { V9.2 } FLastErrorStr := FCurTitle + ' DNS Lookup Failed - ' + GetWinsockErr (Error) ; if (AttemptNr >= FRetryAttempts) and (FRetryAttempts > 0) then begin LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; FLastErrorStr := FLastErrorStr + ' After Total Retries ' + IntToStr (AttemptNr) ; end else begin if (FRetryAttempts >= 0) then { V8.69 -1 means no retry attempts, 0 mean try for ever } begin LogChangeState (socnr, logstateStart) ; FLastErrorStr := FLastErrorStr + ', Retrying in ' + IntToStr (FRetryWaitSecs) + ' secs' ; WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; WaitTimer.Enabled := true ; end else begin LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; end; end ; LogErrEvent (socnr, FLastErrorStr) ; end; end; end; // TCP/Client - diag logging procedure TIcsIpStrmLog.ClientDebugDisplay(Sender: TObject; const Msg: String); { V9.6 } var socnr: integer; begin socnr := (Sender as TWSocket).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; LogProgEvent (socnr, FCurTitle + ' ' + Msg) ; end; // TCP/Server - diag logging procedure TIcsIpStrmLog.ServerDebugDisplay(Sender: TObject; const Msg: String); { V9.6 } var socnr: integer; begin socnr := (Sender as TWSocket).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; LogProgEvent (socnr, FCurTitle + ' ' + Msg) ; end; // TCP/Client - session connected to remote client - success or fail procedure TIcsIpStrmLog.SocketSessionConnected(Sender: TObject; Error: Word); var socnr: integer; begin socnr := (Sender as TWSocket).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; with FChanInfo [socnr] do begin WaitTimer.Enabled := false ; if Error = 0 then begin with (Sender as TSslWSocket) do begin Counter.SetConnected; // 4 July 2016 AttemptNr := 0 ; BindIpAddr := GetXAddr ; // keep local address and port BindIpPort := GetXPort ; // LogProgEvent (socnr, FCurTitle + ' Client Default SocketRcvBufSize: ' + IntToStr(SocketRcvBufSize) + // ', SocketSndBufSize: ' + IntToStr(SocketSndBufSize)) ; // TEMP !!! if (FRcvBufSize > SocketRcvBufSize) then SocketRcvBufSize := FRcvBufSize ; { V8.65 only increase size } if (FSndBufSize > SocketSndBufSize) then SocketSndBufSize := FSndBufSize ; { V8.65 only increase size } end ; if LogState = logstateOK then // 23 July 2014 begin LogProgEvent (socnr, FCurTitle + ' Already Connected') ; exit ; end; if FForceSsl and Assigned (FCliSslContext) then begin if LogState = logstateHandshake then // 23 July 2014 begin LogProgEvent (socnr, FCurTitle + ' Already Starting SSL Handshake') ; exit ; end; with Sender as TSslWSocket do begin try SslContext := FCliSslContext; SslEnable := true ; SslMode := sslModeClient ; OnSslCliGetSession := TlsSslGetSession; OnSslCliNewSession := TlsSslNewSession; OnSslHandshakeDone := TlsSslHandshakeDone ; OnSslVerifyPeer := TlsSslVerifyPeer ; LogChangeState (socnr, logstateHandshake) ; // LogProgEvent (socnr, FCurTitle + ' Starting SSL Handshake to Address ' + // 23 July 2014, more info // IcsFmtIpv6AddrPort (RemIP, RemPort)) ; { V9.6 } except FLastErrorStr := FCurTitle + ' Error Starting SSL - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (socnr, FLastErrorStr) ; end ; end ; end else begin // LogProgEvent (socnr, FCurTitle + ' Connected OK') ; { V9.6 } LogChangeState (socnr, logstateOK) ; end; end else begin inc (AttemptNr) ; { V9.2 } if (AttemptNr >= FRetryAttempts) and (FRetryAttempts > 0) then begin FLastErrorStr := FCurTitle + ' Failed Connection After Total Retries ' + IntToStr (AttemptNr) ; LogErrEvent (socnr, FLastErrorStr) ; LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; end else begin FLastErrorStr := FCurTitle + ' Failed Connection - ' + GetWinsockErr (Error); if (FRetryAttempts >= 0) then { V8.69 -1 means no retry attempts, 0 mean try for ever } begin // if (LogState <> logstateStart) then begin { V9.3 avoid repeated errors } WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; WaitTimer.Enabled := true ; FLastErrorStr := FLastErrorStr + ' - Retrying in ' + IntToStr (FRetryWaitSecs) + ' secs' ; LogChangeState (socnr, logstateStart) ; // end; end else begin if (LogState <> logstateNone) then begin { V9.3 avoid repeated errors } LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; end; end; LogErrEvent (socnr, FLastErrorStr) ; end ; end ; end ; end ; // TCP/Client - session disconnected from remote client - deliberately or unexpected procedure TIcsIpStrmLog.SocketSessionClosed(Sender: TObject; Error: Word); var socnr: integer; begin socnr := (Sender as TWSocket).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; GetPartialLine (Socnr) ; // 3 July 2014 receive any partial line if (Error <> 0) then begin FLastErrorStr := FCurTitle + ' Disconnection Failed - ' + GetWinsockErr (Error) ; // LogErrEvent (socnr, FLastErrorStr) ; { V9.6 } end ; with FChanInfo [socnr] do begin // disconnection during capture is bad news, try and reconnect if (LogState in [logstateOK, logstateOKStream]) and FAutoReconnect then begin LogChangeState (socnr, logstateStart) ; WaitTimer.Enabled := false ; // June 2018, reset timer inc (UnexpectedCount) ; if (UnexpectedCount <= 2) and (NOT FRetryNoImm) then // 7 July 2015 don't always do immediate retries begin WaitTimer.Interval := TicksPerSecond ; // almost immediate retry first two fails WaitTimer.Enabled := true ; FLastErrorStr := FCurTitle + ' Unexpected Disconnect - Attempting to Reconnect' ; LogErrEvent (socnr, FLastErrorStr) ; end else begin WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; WaitTimer.Enabled := true ; FLastErrorStr := FCurTitle + ' Unexpected Disconnect - Retrying in ' + IntToStr (RetryWaitSecs) + ' secs' ; LogErrEvent (socnr, FLastErrorStr) ; end ; end // disconnect during start-up should be retrying already, June 2018 don't need to do anything else if (LogState in [logstateStart]) then begin { WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; WaitTimer.Enabled := true ; FLastErrorStr := FCurTitle + ' Failed Connection - Retrying in ' + IntToStr (RetryWaitSecs) + ' secs' ; LogErrEvent (socnr, FLastErrorStr) ; } end else // planned disconnection begin if (Error = 0) then // June 2018 don't repeat error begin // FLastErrorStr := FCurTitle + ' Disconnected ??' ; // get logged even if next line gone // LogErrEvent (socnr, FLastErrorStr) ; { V9.6 } end; LogChangeState (socnr, logstateNone) ; UnexpectedCount := 0 ; end ; end ; end ; // TCP Server Protocol - build socket table with clients available // warning - socnrs change dynamically as clients come and go (* gone V9.3 procedure TIcsIpStrmLog.CheckServerSockets ; var I: integer; begin FCurSockets := 0 ; if FListenSocket.ClientCount > 0 then begin for I := 0 to Pred (FListenSocket.ClientCount) do begin if FListenSocket.Client [I].Tag >= 0 then // skip client about to be removed begin FListenSocket.Client [I].Tag := FCurSockets ; inc (FCurSockets) ; end ; end ; end ; { if FTotSockets > FMaxSockets then V9.3 not doing anything useful begin for I := FCurSockets to Pred (FMaxSockets) do begin if FLogActive then LogChangeState (I, logstateStart) else LogChangeState (I, logstateNone) ; end ; end ; } end ; *) // current TCP Server total clients function TIcsIpStrmLog.GetCurSockets: Integer; { V9.4 } begin Result := FListenSocket.ClientCount; end; // TCP Server protocol - remote client created by SocketServer procedure TIcsIpStrmLog.ServerClientCreate(Sender : TObject; Client : TWSocketClient); begin Client.CreateCounter; // 4 July 2016 Client.Counter.SetConnected; // 4 July 2016 end; // TCP Server protocol - remote client connected to SocketServer procedure TIcsIpStrmLog.ServerClientConnect(Sender: TObject; Client: TWSocketClient; Error: Word); //var // socnr: integer; begin { socnr := Pred (FListenSocket.ClientCount) ; // too many clients, no logging, just ignore session it will be closed if (socnr < 0) or (socnr >= FTotSockets) then begin exit ; end ; } { V9.3 ChanInfo now stored with socket so stable as clients come and go } { events and functions called with ClientId (sequential number) insead of SocNr } with Client as TIpServerClient do begin CliChanInfo.ClientId := CliId; // for validation SetLength (CliChanInfo.RxLineData, FMaxLineLen + 8) ; if FMaxLineLen > FMaxSendBuffer then FMaxSendBuffer := (FMaxLineLen * 2) + 10 ; CliChanInfo.BindIpAddr := GetXAddr ; // keep local address and port CliChanInfo.BindIpPort := GetXPort ; // LogProgEvent (socnr, FCurTitle + ' Server Default SocketRcvBufSize: ' + IntToStr(SocketRcvBufSize) + // ', SocketSndBufSize: ' + IntToStr(SocketSndBufSize)) ; // TEMP !!! if (FRcvBufSize > SocketRcvBufSize) then SocketRcvBufSize := FRcvBufSize ; { V8.65 only increase size } if (FSndBufSize > SocketSndBufSize) then SocketSndBufSize := FSndBufSize ; { V8.65 only increase size } if FForceSsl then begin if FListenSocket.ClientCount = 1 then { V9.3 only for first new remote client } LogChangeState (CliId, logstateHandshake) ; LogProgEvent (CliId, FCurTitle + ' Starting SSL Handshake from Address ' + IcsFmtIpv6AddrPort (CPeerAddr, CPeerPort) + ', Client Id: ' + IntToStr(CliId)) ; { V9.3 } end else begin LogProgEvent (CliId, FCurTitle + ' Client Connected from Address ' + IcsFmtIpv6AddrPort (Client.CPeerAddr, Client.CPeerPort) + ', Client Id: ' + IntToStr(CliId)) ; { V9.3 } LogChangeState (CliId, logstateOK) ; end; Tag := 0 ; // set in a moment LineMode := false; OnDataAvailable := SocketDataAvailable ; OnBgException := SocketBgException; OnDataSent := SocketDataSent ; // 3 July 2014 Banner := '' ; end ; // CheckServerSockets ; // updates all tags with socnr V9.3 not needed end; // TCP Server protocol - remote client disconnected from SocketServer procedure TIcsIpStrmLog.ServerClientDisconnect(Sender: TObject; Client: TWSocketClient; Error: Word); //var // socnr: integer; begin // socnr := Client.Tag ; // if (socnr < 0) or (socnr >= FTotSockets) then exit ; { V9.3 ChanInfo now stored with socket so stable as clients come and go } GetPartialLine (Client.CliId) ; // 3 July 2014 receive any partial line // with FChanInfo [socnr] do // begin Client.Tag := -1 ; // mark as about to be removed LogChangeState (Client.CliId, logstateStopping) ; if (FListenSocket.ClientCount > FListenSocket.MaxClients) then // 4 Jan 2012 better error for too many clients LogProgEvent (Client.CliId, FCurTitle + ' Client Connection Refused, Too Many') else LogProgEvent (Client.CliId, FCurTitle + ' Client Disconnected, Client Id: ' + IntToStr(Client.CliId)) ; { V9.3 } // end ; // CheckServerSockets ; // updates tags with socnr end; // V9.3 close single TCP Server remote client function TIcsIpStrmLog.CloseSrvCli (ClientId: Integer): boolean ; { V9.3 } var I: Integer; begin Result := False; if FLogProtocol = logprotTcpServer then begin I := GetSrvSocNr(ClientId); if I >= 0 then begin FListenSocket.Disconnect(FListenSocket.Client [I]); Result := True; end; end end; // TCP/Server check for idle client sessions procedure TIcsIpStrmLog.ServerTimerTimer(Sender: TObject); var CurTicks: Int64; { V8.71 } I: Integer; Cli: TWSocketClient; begin if FSrvTimeoutSecs < 10 then Exit ; // sanity check if NOT Assigned (FListenSocket) then Exit ; // sanity check Oct 2016 if FListenSocket.ClientCount = 0 then Exit ; // sanity check Oct 2016 if not FHeartBeatBusy then { Avoid reentrance } try FHeartBeatBusy := TRUE; CurTicks := IcsGetTickCount64; { V8.71 } for I := FListenSocket.ClientCount - 1 downto 0 do begin Cli := FListenSocket.Client[I]; // socnr := Cli.Tag ; { V9.3 gone } if (IcsDiffSecs64(Cli.Counter.LastAliveTick, CurTicks) > FSrvTimeoutSecs) then { V8.71 } begin LogProgEvent (Cli.CliId, FCurTitle + ' Client Idle Timeout After ' + IntToStr(FSrvTimeoutSecs) + ' secs') ; FListenSocket.Disconnect(Cli); end; end; finally FHeartBeatBusy := FALSE; end; end ; // all clients and servers, see how many bytes of send data is not yet sent function TIcsIpStrmLog.GetSendWaiting (Socnr: integer): integer ; // 6 Sept 2016 var I: Integer; begin result := -1 ; FLastErrorStr := '' ; if NOT FLogActive then exit ; if FTotSockets <= 0 then exit ; if FLogProtocol = logprotTcpServer then begin I := GetSrvSocNr(Socnr); { V9.3 using ClientId } if I >= 0 then result := FListenSocket.Client [I].BufferedByteCount ; end else if FLogProtocol in [logprotUdpClient, logprotTcpClient, logprotUdpServer] then begin if (Socnr >= FMaxSockets) then exit ; with FChanInfo [socnr] do begin if (LogState = logstateOK) and (SendSocket.State = wsConnected) then result := SendSocket.BufferedByteCount ; end ; end end; // All clients and servers, send a line // send raw TBytes function TIcsIpStrmLog.SendLogLine (const Line: TBytes; ClientId: Integer = 0): boolean ; { V8.70 } var I, len, tot: integer ; xmitline: TBytes; { V8.69 was AnsiString } Success: boolean ; begin result := false ; FLastErrorStr := '' ; if NOT FLogActive then begin FLastErrorStr := FCurTitle + ' Not Started' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if FTotSockets <= 0 then exit ; xmitline := Line; len := Length (xmitline) ; if FAddCRLF and (NOT (FUdpNoCRLF and (FLogProtocol in [logprotUdpClient, logprotUdpServer]))) then begin SetLength (xmitline, len + 2); xmitline[len] := IcsbCR; len := len + 1; xmitline[len] := IcsbLF; len := len + 1; end; if FLogProtocol = logprotTcpServer then begin if FListenSocket.ClientCount > 0 then begin for I := 0 to Pred (FListenSocket.ClientCount) do begin try // except with FListenSocket.Client [I] do begin // V9.3 only sending to one specific client, check it if (ClientId > 0) and (ClientId <> CliId) then Continue; if State = wsConnected then begin if (len + BufferedByteCount) < FMaxSendBuffer then begin tot := SendTB (xmitline) ; { V8.69 } if tot >= 0 then result := true else begin FLastErrorStr := FCurTitle + ' Failed to Send Data' ; LogErrEvent(CliId, FLastErrorStr) ; { V9.3 } end ; end else begin FLastErrorStr := FCurTitle + ' Buffer Full Sending Data' ; LogErrEvent(CliId, FLastErrorStr) ; { V9.3 } end ; end ; end ; except FLastErrorStr := FCurTitle + ' Error Send Data - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end ; end ; end else if FLogProtocol in [logprotUdpClient, logprotTcpClient, logprotUdpServer] then begin for I := 0 to Pred (FMaxSockets) do begin with FChanInfo [I] do begin try with SendSocket do begin if (LogState = logstateOK) and (State = wsConnected) then begin if (len + BufferedByteCount) < FMaxSendBuffer then begin // for UDP, check we already have an address, for clients this // will have been set before connection, but for server we only // know it once a packet has been received but try and use RemHost // instead (of course this is a guess and assumes we know where the // connection is coming from) if FLogProtocol in [logprotUdpServer, logprotUdpClient] then begin if SocketFamily = sfIPv6 then begin {$IFDEF MSWINDOWS} if (SocRemAddr6.sin6_addr.u6_addr32 [0] = 0) and (SocRemAddr6.sin6_addr.u6_addr32 [1] = 0) and (SocRemAddr6.sin6_addr.u6_addr32 [2] = 0) and (SocRemAddr6.sin6_addr.u6_addr32 [3] = 0) then {$ELSE} if (SocRemAddr6.sin6_addr.s6_addr32 [0] = 0) and { V8.65 } (SocRemAddr6.sin6_addr.s6_addr32 [1] = 0) and (SocRemAddr6.sin6_addr.s6_addr32 [2] = 0) and (SocRemAddr6.sin6_addr.s6_addr32 [3] = 0) then {$ENDIF MSWINDOWS} begin SocRemAddr6.sin6_family := AF_INET6 ; SocRemAddr6.sin6_addr := TInAddr6 (WSocketStrToIPv6 (RemHost, Success)) ; SocRemAddr6.sin6_port := WSocket_htons (atoi (RemPort)) ; end ; tot := SendToTB6 (SocRemAddr6, SizeOf (TSockAddrIn6), xmitline) ; { V8.69 } end else begin if SocRemAddr.sin_addr.S_addr = 0 then begin SocRemAddr.sin_family := AF_INET ; SocRemAddr.sin_addr.S_addr := WSocket_inet_addr (AnsiString (RemHost)) ; SocRemAddr.sin_port := WSocket_htons (atoi (RemPort)) ; end ; tot := SendToTB (SocRemAddr, SizeOf (TSockAddrIn), xmitline) ; { V8.69 } end; end else tot := SendTB (xmitline) ; { V8.69 } if tot >= 0 then result := true else begin FLastErrorStr := FCurTitle + ' Failed to Send Data - ' + GetWinsockErr (LastError) ; { V8.67 was GetLastError } LogErrEvent (0, FLastErrorStr) ; end end else begin FLastErrorStr := FCurTitle + ' Buffer Full Sending Data' ; LogErrEvent (0, FLastErrorStr) ; end ; end ; end ; except FLastErrorStr := FCurTitle + ' Error Send Data - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end ; end ; end ; end ; // send ansi line as ANSI function TIcsIpStrmLog.SendLogLine (const Line: Ansistring; ClientId: Integer = 0): boolean ; var xmitline: TBytes; begin if FUseUtf8 then { V8.70 } IcsMoveStringToTBytes(UnicodeString(Line), xmitline, Length(Line), CP_UTF8) else IcsMoveStringToTBytes(Line, xmitline, Length(Line)); Result := SendLogLine (xmitline, ClientId) ; { V9.3 added CliId } end ; // send unicode line, converting to UTF8 function TIcsIpStrmLog.SendLogLine (const Line: UnicodeString; ClientId: Integer = 0): boolean ; { V8.70 } var xmitline: TBytes; begin if FUseUtf8 then { V8.70 } IcsMoveStringToTBytes(Line, xmitline, Length(Line), CP_UTF8) else IcsMoveStringToTBytes(Line, xmitline, Length(Line)); Result := SendLogLine (xmitline, ClientId) ; { V9.3 added CliId } end; // send a stream - 3 Jul 2014 function TIcsIpStrmLog.SendStream (MyStream: TStream; ClientId: Integer = 0): boolean ; var I: Integer ; Success: boolean ; begin Result := false ; if NOT FLogActive then begin FLastErrorStr := FCurTitle + ' Not Started' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if FTotSockets <= 0 then exit ; if NOT Assigned (MyStream) then begin FLastErrorStr := FCurTitle + ' No Send Stream Specified' ; LogErrEvent (0, FLastErrorStr) ; exit ; end ; if FLogProtocol = logprotTcpServer then begin if FListenSocket.ClientCount > 0 then begin for I := 0 to Pred (FListenSocket.ClientCount) do begin try // except with TIpServerClient(FListenSocket.Client [I]) do begin if State = wsConnected then begin if CliChanInfo.StreamFlag then begin FLastErrorStr := FCurTitle + ' Still Sending Old Stream' ; LogErrEvent (CliId, FLastErrorStr) ; continue ; end ; FSendStream := MyStream ; SetLength (FSendBuffer, FMaxSendBuffer) ; // create send buffer to read stream CliChanInfo.StreamFlag := true ; { V9.3 chaninfo now in client } CliChanInfo.StreamNr := 0 ; LogProgEvent (CliId, FCurTitle + ' Sending Data Stream, Size ' + IntToKbyte (FSendStream.Size, True)); LogChangeState (CliId, logstateOKStream) ; SocketDataSent (FListenSocket.Client [I], 0); // send first block Result := true ; end ; end ; except FLastErrorStr := FCurTitle + ' Error Start Send Stream - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (I, FLastErrorStr) ; end ; end ; end ; end else if FLogProtocol in [logprotUdpClient, logprotTcpClient, logprotUdpServer] then begin // UDP only allows small packets to be sent if FLogProtocol in [logprotUdpClient, logprotUdpServer] then FMaxSendBuffer := 2048 ; // 7 Sept 2016 was 512 ; for I := 0 to Pred (FMaxSockets) do begin with FChanInfo [I] do begin try with SendSocket do begin if (LogState = logstateOK) and (State = wsConnected) then begin if StreamFlag then begin FLastErrorStr := FCurTitle + ' Still Sending Old Stream' ; LogErrEvent (I, FLastErrorStr) ; continue ; end ; // for UDP, check we already have an address, for clients this // will have been set before connection, but for server we only // know it once a packet has been received but try and use RemHost // instead (of course this is a guess and assumes we know where the // connection is coming from) if FLogProtocol in [logprotUdpServer, logprotUdpClient] then begin if SocketFamily = sfIPv6 then begin {$IFDEF MSWINDOWS} if (SocRemAddr6.sin6_addr.u6_addr32 [0] = 0) and (SocRemAddr6.sin6_addr.u6_addr32 [1] = 0) and (SocRemAddr6.sin6_addr.u6_addr32 [2] = 0) and (SocRemAddr6.sin6_addr.u6_addr32 [3] = 0) then {$ELSE} if (SocRemAddr6.sin6_addr.s6_addr32 [0] = 0) and { V8.65 } (SocRemAddr6.sin6_addr.s6_addr32 [1] = 0) and (SocRemAddr6.sin6_addr.s6_addr32 [2] = 0) and (SocRemAddr6.sin6_addr.s6_addr32 [3] = 0) then {$ENDIF MSWINDOWS} begin SocRemAddr6.sin6_family := AF_INET6 ; SocRemAddr6.sin6_addr := TInAddr6 (WSocketStrToIPv6 (RemHost, Success)) ; SocRemAddr6.sin6_port := WSocket_htons (atoi (RemPort)) ; end ; end else begin if SocRemAddr.sin_addr.S_addr = 0 then begin SocRemAddr.sin_family := AF_INET ; SocRemAddr.sin_addr.S_addr := WSocket_inet_addr (AnsiString (RemHost)) ; SocRemAddr.sin_port := WSocket_htons (atoi (RemPort)) ; end ; end ; end; FSendStream := MyStream ; SetLength (FSendBuffer, FMaxSendBuffer) ; // create send buffer to read stream StreamNr := 0 ; StreamFlag := true ; LogProgEvent (I, FCurTitle + ' Sending Data Stream, Size ' + IntToKByte (FSendStream.Size, True)); LogChangeState (I, logstateOKStream) ; SocketDataSent (FChanInfo [I].SendSocket, 0); // send first block Result := true ; end ; end ; except FLastErrorStr := FCurTitle + ' Error Start Send Stream - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (I, FLastErrorStr) ; end ; end ; end ; end ; end; // client and server, send some data OK - 3 July 2014 procedure TIcsIpStrmLog.SocketDataSent(Sender: TObject; ErrCode : word); var socnr, len, tot: integer; TxSocket: TWSocket; // MyChanInfo: PStrmChanInfo; { V9.3 } begin if FLogProtocol = logprotTcpServer then begin try with (Sender as TIpServerClient) do begin { V9.3 client now has channel info } if (CliChanInfo.LogState <> logstateOKStream) or (State <> wsConnected) then exit ; // non-stream data being sent if (NOT CliChanInfo.StreamFlag) or (NOT Assigned (FSendStream)) then begin FLastErrorStr := FCurTitle + ' Failed to Send Stream' ; LogErrEvent (CliId, FLastErrorStr) ; CliChanInfo.StreamFlag := false ; SetLength (FSendBuffer, 0); LogChangeState (CliId, logstateOK) ; exit ; end; FSendStream.Position := CliChanInfo.StreamNr; { V8.67 Seek (StreamNr, soBeginning) ; } len := FSendStream.Read (FSendBuffer [0], FMaxSendBuffer) ; CliChanInfo.StreamNr := CliChanInfo.StreamNr + len ; if len = 0 then begin CliChanInfo.StreamFlag := false ; SetLength (FSendBuffer, 0); LogProgEvent (CliId, FCurTitle + ' Sent Data Stream OK, Size ' + IntToKbyte (CliId, True)); LogChangeState (CliId, logstateOK) ; exit ; end ; tot := SendTB (FSendBuffer, len) ; { V8.69 } if tot = 0 then begin FLastErrorStr := FCurTitle + ' Failed to Send Stream Data' ; LogErrEvent (CliId, FLastErrorStr) ; end ; end; except FLastErrorStr := FCurTitle + ' Error Send Stream Data - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end else if FLogProtocol in [logprotUdpClient, logprotTcpClient, logprotUdpServer] then begin // socnr := 0; try TxSocket := Sender as TWSocket ; except FLastErrorStr := FCurTitle + ' Error Socket Data Sent - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; Exit; end ; socnr := TxSocket.Tag; if (socnr < 0) or (socnr >= FTotSockets) then begin FLastErrorStr := FCurTitle + ' Error Send Data - Invalid Client' ; LogErrEvent (socnr, FLastErrorStr) ; exit ; end; with FChanInfo [socnr] do begin try if (LogState <> logstateOKStream) or (TxSocket.State <> wsConnected) then exit ; // non-stream data being sent if (NOT StreamFlag) or (NOT Assigned (FSendStream)) then begin FLastErrorStr := FCurTitle + ' Failed to Send Stream' ; LogErrEvent (0, FLastErrorStr) ; StreamFlag := false ; SetLength (FSendBuffer, 0); LogChangeState (socnr, logstateOK) ; exit ; end; FSendStream.Position := StreamNr; { V8.67 Seek (StreamNr, soBeginning) ; } len := FSendStream.Read (FSendBuffer [0], FMaxSendBuffer) ; StreamNr := StreamNr + len ; if len = 0 then begin StreamFlag := false ; SetLength (FSendBuffer, 0); LogProgEvent (socnr, FCurTitle + ' Sent Data Stream OK, Size ' + IntToKByte (StreamNr, True)); LogChangeState (socnr, logstateOK) ; exit ; end ; if FLogProtocol in [logprotUdpServer, logprotUdpClient] then begin if TxSocket.SocketFamily = sfIPv6 then tot := TxSocket.SendToTB6 (SocRemAddr6, SizeOf (TSockAddrIn6), FSendBuffer, len) else tot := TxSocket.SendToTB (SocRemAddr, SizeOf (TSockAddrIn), FSendBuffer, len) ; end else tot := TxSocket.SendTB (FSendBuffer, len) ; if tot = 0 then begin FLastErrorStr := FCurTitle + ' Failed to Send Data - ' + GetWinsockErr (TxSocket.LastError) ; { V8.67 was GetLastError } LogErrEvent (0, FLastErrorStr) ; end ; except FLastErrorStr := FCurTitle + ' Error Send Data - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end ; end; end; // All Clients and Servers - remote is sending stuff to us procedure TIcsIpStrmLog.SocketDataAvailable(Sender: TObject; Error: Word); var Socnr, I, len, AddrInLen, BadCount: integer; RxSocket: TWSocket; Ch: AnsiChar ; process: boolean ; MyChanInfo: PStrmChanInfo; { V9.3 } begin // Socnr := 0 ; try // except RxSocket := Sender as TWSocket ; { V9.3 TCP server has channel info in client, not table, so set pointer to correct location } Socnr := ChanInfofromSocket(RxSocket, MyChanInfo); (* MyChanInfo := Nil; if (FLogProtocol = logprotTcpServer) then begin MyChanInfo := @(Sender as TIpServerClient).CliChanInfo; { V9.3 client now has channel info } Socnr := (Sender as TIpServerClient).CliId; end else begin Socnr := RxSocket.Tag; if (Socnr >= 0) and (Socnr < FTotSockets) then MyChanInfo := @FChanInfo [Socnr]; end; *) if NOT Assigned(FRxBuffer) then SetLength(FRxBuffer, 33000); { sanity check } if MyChanInfo = Nil then begin RxSocket.ReceiveTB (FRxBuffer); // flush but ignore data V8.70 now using TBytes FLastErrorStr := FCurTitle + ' Error Receive Data - Invalid Client' ; LogErrEvent (socnr, FLastErrorStr) ; exit ; end; with MyChanInfo^ do begin // warning - ReceiveFrom does not support SSL if FLogProtocol in [logprotUdpServer, logprotUdpClient] then begin if RxSocket.SocketFamily <> sfIPv6 then begin AddrInLen := SizeOf (TSockAddrIn) ; len := RxSocket.ReceiveFromTB (FRxBuffer, SocRemAddr, AddrInLen) ; { V8.70 now using TBytes } if len <= 0 then exit; // 1 Feb 2007, always keep UDP remote stuff, may be different for each packet PeerIpAddr := string (WSocket_inet_ntoa (SocRemAddr.sin_addr)) ; // 8 Aug 2010 PeerIpPort := IntToStr (WSocket_ntohs (SocRemAddr.sin_port)) ; end else begin AddrInLen := SizeOf (TSockAddrIn6) ; len := RxSocket.ReceiveFrom6TB (FRxBuffer, SocRemAddr6, AddrInLen) ; { V8.70 now using TBytes } if len <= 0 then exit; PeerIpAddr := WSocketIPv6ToStr (@SocRemAddr6) ; PeerIpPort := IntToStr (WSocket_ntohs (SocRemAddr6.sin6_port)) ; end; end else begin len := RxSocket.ReceiveTB (FRxBuffer) ; { V8.70 now using TBytes } if len <= 0 then exit; end; BadCount := 0; for I := 0 to Pred (len) do begin Ch := AnsiChar(FRxBuffer [I]) ; { V8.69 } process := false ; if Ch >= IcsSpace then begin inc (RxLineLen) ; RxLineData [RxLineLen] := Ch ; end else begin if LineEndType = lineendLF then begin if (Ch = IcsLF) then process := true ; end else if LineEndType = lineendCR then begin if (Ch = IcsCR) then process := true ; if (Ch = IcsFF) then process := true ; // form feed, Apr 2015 only CRFF end else if LineEndType = lineendCRLF then begin if (Ch = IcsLF) then begin if (RxLineLen > 0) and (RxLineData [RxLineLen] = IcsCR) then begin process := true ; if NOT FRawData then RxLineLen := RxLineLen - 1 ; // remove CR end; end; end ; if FRawData then begin inc (RxLineLen) ; RxLineData [RxLineLen] := Ch ; end else begin if Ch in [icsCR, IcsCR, IcsFF] then begin if (LineEndType <> lineendCRLF) or (Ch <> IcsCR) then // April 2015 CR removed later Ch := IcsNULL end else if NOT FStripControls then Ch := IcsSPACE else Ch := IcsNULL ; if Ch > IcsNULL then begin inc (RxLineLen) ; RxLineData [RxLineLen] := Ch ; end else begin { V8.70 break loop if continually receiving non-acceptabe characters } BadCount := BadCount + 1 ; if BadCount >= FMaxLineLen then process := true end; end ; end ; if RxLineLen >= FMaxLineLen then process := true else if LineEndType = lineendCustom then begin if (Ch = FLineEndChar) then process := true ; end else if LineEndType = lineendPacket then begin if (I >= Pred (len)) then process := true ; end ; if FMaxRecvData > 0 then begin // 12 Sept 2016 see if waiting for specific length of data, like HTTP content if ((TotRecvData + RxLineLen) >= FMaxRecvData) then process := true ; end; if process then begin // might be blank line SetLength (LastLine, RxLineLen) ; if RxLineLen > 0 then Move (RxLineData [1], LastLine [1], RxLineLen) ; TotRecvData := TotRecvData + RxLineLen ; // 12 Sept 2016 how much data has been received if Assigned (FonLogRecvEvent) then begin if FUseUtf8 and (NOT FRawData) then { V8.70 convert line from UTF8 to Unicode } {$IFDEF UNICODE} FonLogRecvEvent (Self, Socnr, UTF8ToStringW(LastLine)) {$ELSE} FonLogRecvEvent (Self, Socnr, UTF8ToStringA(LastLine)) {$ENDIF} else FonLogRecvEvent (Self, Socnr, String (LastLine)) ; // 8 Aug 2010 end ; RxLineLen := 0 ; end ; end ; end ; except FLastErrorStr := FCurTitle + ' Error Receive Data - ' + IcsGetExceptMess (ExceptObject) ; LogErrEvent (0, FLastErrorStr) ; end ; end ; // clears any partial received data procedure TIcsIpStrmLog.ClearLine (Socnr: integer) ; var MyChanInfo: PStrmChanInfo; begin MyChanInfo := GetChanInfo(Socnr); { V9.3 using ClientId for server } if MyChanInfo = Nil then Exit; with MyChanInfo^ do begin RxLineLen := 0 ; SetLength (LastLine, 0) ; end; end ; // retrieve any partial received data function TIcsIpStrmLog.GetPartialLine (Socnr: integer): string ; var MyChanInfo: PStrmChanInfo; begin result := '' ; MyChanInfo := GetChanInfo(Socnr); { V9.3 using ClientId for server } if MyChanInfo = Nil then Exit; with MyChanInfo^ do begin SetLength (LastLine, RxLineLen) ; if RxLineLen > 0 then begin Move (RxLineData [1], LastLine [1], RxLineLen) ; if Assigned (FonLogRecvEvent) then FonLogRecvEvent (Self, Socnr, String (LastLine)) ; // 8 Aug 2010 end ; RxLineLen := 0 ; result := String (LastLine) ; end ; end ; function TIcsIpStrmLog.GetTotRecvData (Socnr: integer): int64 ; // 13 Sept 2016 var MyChanInfo: PStrmChanInfo; begin Result := 0 ; MyChanInfo := GetChanInfo(Socnr); { V9.3 using ClientId for server } if MyChanInfo = Nil then Exit; Result := MyChanInfo^.TotRecvData ; end ; procedure TIcsIpStrmLog.ResetRecvData (Socnr: integer) ; // 13 Sept 2016 var MyChanInfo: PStrmChanInfo; begin MyChanInfo := GetChanInfo(Socnr); { V9.3 using ClientId for server } if MyChanInfo = Nil then Exit; MyChanInfo^.TotRecvData := 0 ; end ; // SSL client, new session, see if re-using external cached session procedure TIcsIpStrmLog.TlsSslNewSession(Sender: TObject; SslSession: Pointer; WasReused: Boolean; var IncRefCount : Boolean); var socnr: integer; begin if NOT (FSslSessCache) then exit; socnr := (Sender as TWSocket).Tag ; if (socnr < 0) or (socnr >= FTotSockets) then exit ; if (NOT WasReused) then begin with Sender as TSslWSocket do FExternalSslSessCache.CacheCliSession (SslSession, PeerAddr + PeerPort, IncRefCount); // if (wsdlogSsl in FWSDebugOptions) then { V9.6 } // LogProgEvent (socnr, FCurTitle + ' SSL New Session'); end; // else begin // if (wsdlogSsl in FWSDebugOptions) then { V9.6 } // LogProgEvent (socnr, FCurTitle + ' SSL Session Reused'); // end; end; // SSL client, look-up session from external cache procedure TIcsIpStrmLog.TlsSslGetSession(Sender: TObject; var SslSession: Pointer; var FreeSession : Boolean); begin if NOT (FSslSessCache) then exit; with Sender as TSslWSocket do SslSession := FExternalSslSessCache.GetCliSession (PeerAddr + PeerPort, FreeSession); end; // SSL Handshaking done, if OK may check certificate chain // called for both client and server, warning different senders procedure TIcsIpStrmLog.TlsSslHandshakeDone(Sender: TObject; ErrCode: Word; PeerCert: TX509Base; var Disconnect: Boolean); var Socnr: integer; // CertChain: TX509List; // Hash, info, VerifyInfo: String; // Safe: Boolean; MyChanInfo: PStrmChanInfo; { V9.3 } // VerifyCode: Integer; { V9.3 } begin { V9.3 TCP server has channel info in client, not table, so set pointer to correct location } Socnr := ChanInfofromSocket(Sender as TWSocket, MyChanInfo); if (Socnr < 0) then Exit; if Assigned(FOnHandshakeDone) then FOnHandshakeDone(Sender, ErrCode, PeerCert, Disconnect); // client response, may need to check server certificate if FLogProtocol = logprotTcpClient then begin with Sender as TSslWSocket do begin if (ErrCode <> 0) or Disconnect then begin if (FChanInfo [socnr].AttemptNr >= FRetryAttempts) and (FRetryAttempts > 0) then // May 2015 retry on handshake errors begin FLastErrorStr := FCurTitle + ' SSL Handshake Failed - ' + SslHandshakeRespMsg + ', After Total Retries ' + IntToStr (MyChanInfo^.AttemptNr) ; LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; end else begin if MyChanInfo^.LogState in [logstateNone, logstateStopping] then begin FLastErrorStr := FCurTitle + ' SSL Handshake Failed - ' + SslHandshakeRespMsg ; end else begin FLastErrorStr := FCurTitle + ' SSL Handshake Failed - ' + SslHandshakeRespMsg; if (FRetryAttempts >= 0) then { V8.69 -1 means no retry attempts, 0 mean try for ever } begin MyChanInfo^.WaitTimer.Interval := Longword (FRetryWaitSecs) * TicksPerSecond ; MyChanInfo^.WaitTimer.Enabled := true ; FLastErrorStr := FLastErrorStr + ' - Retrying in ' + IntToStr (FRetryWaitSecs) + ' secs' ; LogChangeState (socnr, logstateStart) ; end else begin LogChangeState (socnr, logstateStopping) ; { V8.69 } LogChangeState (socnr, logstateNone) ; end; end; end ; LogErrEvent (socnr, FLastErrorStr) ; // Disconnect := TRUE; if fSslSessCache then begin if FExternalSslSessCache.RemoveSession(PeerAddr + PeerPort) then LogProgEvent (socnr, 'SSL Session Uncached After Failure') else LogProgEvent (socnr, 'SSL Session Not Found in Cache'); end; CloseDelayed; // Dec 2016 exit; end ; LogChangeState (socnr, logstateOK) ; exit; // nothing to do, go ahead (* // OK V9.6 handshake already checked and loggged inm WSocket LogProgEvent (socnr, FCurTitle + IcsSpace + SslHandshakeRespMsg) ; // Dec 2014 if SslSessionReused OR (FLogSslVerMethod = logSslVerNone) then begin LogChangeState (socnr, logstateOK) ; exit; // nothing to do, go ahead end ; // Is current host already in the list of temporarily accepted hosts ? Hash := PeerCert.Sha1Hex ; if SslAcceptableHosts.IndexOf (SslServerName + Hash ) > -1 then begin LogChangeState (socnr, logstateOK) ; exit; // nothing to do, go ahead end ; // Property SslCertChain contains all certificates in current verify chain CertChain := SslCertChain; VerifyCode := PeerCert.VerifyResult; // V9.3 OpenSSL verification result VerifyInfo := PeerCert.FirstVerifyErrMsg; // V9.3 earlier // see if validating against Windows certificate store if FLogSslVerMethod = logSslVerWinStore then begin {$IFDEF MSCRYPT_Clients} // start engine if not Assigned (FMsCertChainEngine) then FMsCertChainEngine := TMsCertChainEngine.Create; // see if checking revoocation, CRL checks and OCSP checks in Vista+, very slow!!!! if FLogSslRevocation then FMsCertChainEngine.VerifyOptions := [mvoRevocationCheckChainExcludeRoot] else FMsCertChainEngine.VerifyOptions := []; // This option doesn't seem to work, at least when a DNS lookup fails FMsCertChainEngine.UrlRetrievalTimeoutMsec := 10 * TicksPerSecond; { Pass the certificate and the chain certificates to the engine } FMsCertChainEngine.VerifyCert (PeerCert, CertChain, ChainVerifyResult, True); Safe := (ChainVerifyResult = 0) or { We ignore the case if a revocation status is unknown. } (ChainVerifyResult = Ics_CERT_TRUST_REVOCATION_STATUS_UNKNOWN) or { V9.3 constants in Types } (ChainVerifyResult = Ics_CERT_TRUST_IS_OFFLINE_REVOCATION) or (ChainVerifyResult = Ics_CERT_TRUST_REVOCATION_STATUS_UNKNOWN or Ics_CERT_TRUST_IS_OFFLINE_REVOCATION); { The MsChainVerifyErrorToStr function works on chain error codes } VerifyInfo := MsChainVerifyErrorToStr (ChainVerifyResult); // Nov 2016 // MSChain ignores host name, so see if it failed using OpenSSL if VerifyCode = X509_V_ERR_HOSTNAME_MISMATCH then begin // Nov 2016 Safe := False; VerifyInfo := PeerCert.FirstVerifyErrMsg; end; {$ELSE} LogProgEvent (socnr, FCurTitle + ' Windows certificate store not available'); { V8.65 } exit ; {$ENDIF MSCRYPT_Clients} end else if FLogSslVerMethod = logSslVerBundle then begin // VerifyInfo := PeerCert.FirstVerifyErrMsg; // Nov 2016 Safe := (VerifyCode = X509_V_OK); { check whether SSL chain verify result was OK } {.$IFDEF OpenSSL_OcspChains} { V9.6 } { V8.69 check OCSP to see if revoked, if we got a chain of certificates } { note this is a soft check, if we don't have a stapled OCSP response from the TLS handshake, we get it from an OCSP HTTP server and cache it but don't wait for the response. So next attempt comes from cache. } { V9.6 skip OSCP if no cert OSCP URL, since now common since summer 2025 } if (Safe and FLogSslRevocation and PeerCert.IsCertLoaded and (CertChain.Count > 0)) and (PeerCert.UrlOcsp <> '' ) then begin FOcspHttp.ClearOcsp; FOcspHttp.OcspCert := PeerCert; FOcspHttp.OcspInters := CertChain; if (Length(OcspStapleRaw) > 50) and (OcspStapleStatus = OCSP_RESPONSE_STATUS_SUCCESSFUL) then FOcspHttp.OcspRespRaw := OcspStapleRaw; if FOcspHttp.CheckOcspRevoked(FCliSslContext.GetX509Store, 0) then Safe := False; VerifyInfo := FOcspHttp.OcspLastResp; FOcspHttp.OcspInters := Nil; LogProgEvent (socnr, FCurTitle + ' ' + VerifyInfo) end; {.$ENDIF} // OpenSSL_OcspChains end { V9.3 allow application to verify chain, perhaps checking public key only } { the event should change VerifyCode, VerifyInfo, Disconnect so the result get logged sensibly } else if FLogSslVerMethod = logSslVerOwnEvent then begin if Assigned(FOnSslCertVerifyEvent) then begin FOnSslCertVerifyEvent(Self, CertChain, VerifyCode, VerifyInfo, Disconnect); if Disconnect and (VerifyCode = X509_V_OK) then VerifyCode := X509_V_ERR_CERT_SIGNATURE_FAILURE; end; Safe := (VerifyCode = X509_V_OK); end else begin exit ; // unknown method end ; // allow self signed certs if (CertChain.Count > 0) and (CertChain[0].FirstVerifyResult = X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN) then begin Safe := true ; LogProgEvent (socnr, FCurTitle + ' SSL Self Signed Certificate Succeeded: ' + IcsUnwrapNames (PeerCert.IssuerCName)); end; // V9.6 OpenSSL does not check IPv6 adresses correctly ??? if (VerifyCode = X509_V_ERR_HOSTNAME_MISMATCH) or (VerifyCode = X509_V_ERR_IP_ADDRESS_MISMATCH) then begin if PeerCert.PostConnectionCheck(SslServerName) then begin Safe := True; VerifyCode := X509_V_OK; VerifyInfo := 'OK'; LogProgEvent (socnr, FCurTitle + ' ' + SslServerName + ' Matched OK in PostConnectionCheck') ; end else LogProgEvent (socnr, FCurTitle + ' ' + SslServerName + ' Match Failed in PostConnectionCheck') ; end; // tell user verification failed if NOT Safe then begin if (CertChain.Count > 0) then begin { V9.6 check something to report } info := ' SSL Chain Verification Failed: ' + VerifyInfo + ', Domain: ' + PeerCert.SubAltAllDisp; { V9.6 new simpler function gets all SANs }; if Pos(SslServerName, PeerCert.SubAltAllDisp) = 0 then { V9.6 only expected if different } info := info + ', Expected: ' + SslServerName ; // Nov 2016 end else info := info + ', No Certificates'; LogProgEvent (socnr, FCurTitle + info); end // certificate OK else begin LogProgEvent (socnr, FCurTitle + ' SSL Chain Verification Succeeded, Domain: ' + SslServerName); { V9.6 was SslCertPeerName } end; // if certificate checking failed, see if the host is specifically listed as being allowed anyway if (NOT Safe) and (SslAcceptableHosts.IndexOf (SslServerName) > -1) then begin Safe := true ; SslAcceptableHosts.Add (SslServerName + Hash); // keep it to avoid checking again LogProgEvent (socnr, FCurTitle + ' SSL Succeeded with Acceptable Host Name'); end ; // tell user about all the certificates we found if FLogSslReportChain and (CertChain.Count > 0) then begin info := 'Verify Result: ' + VerifyInfo + IcsCRLF ; { V8.69 simplify } info := info + IntToStr (CertChain.Count) + ' SSL Certificates in the verify chain:'+ IcsCRLF + IcsCRLF + CertChain.CertsHandshake; { V9.6 better reporting } // CertChain.AllCertInfo (true, true) ; // Feb 2017 report all certs, backwards LogProgEvent (socnr, FCurTitle + ' ' + info); end; // all failed, V8.65 need to remove cached SSL session so it's not reused!!! if NOT Safe then begin Disconnect := TRUE; if fSslSessCache then begin if FExternalSslSessCache.RemoveSession(PeerAddr + PeerPort) then LogProgEvent (socnr, 'SSL Session Uncached After Failure') else LogProgEvent (socnr, 'SSL Session Not Found in Cache'); end; end; *) end; end // server currently ignores a client certificate, not often used else if FLogProtocol = logprotTcpServer then begin with Sender as TWSocket do begin // nothing much to do if SSL failed or event said disconnect if (ErrCode <> 0) or Disconnect then begin FLastErrorStr := FCurTitle + ' SSL Handshake Failed - ' + SslHandshakeRespMsg ; LogErrEvent (socnr, FLastErrorStr) ; Disconnect := TRUE; exit; end ; LogProgEvent (socnr, FCurTitle + IcsSpace + SslHandshakeRespMsg) ; end; end else LogProgEvent (socnr, FCurTitle + ' SSL Connected OK') ; LogChangeState (socnr, logstateOK) ; end; // SSL Verify Peer, gets called for each certificate in chain, if being checked procedure TIcsIpStrmLog.TlsSslVerifyPeer(Sender: TObject; var Ok: Integer; Cert: TX509Base); var socnr: integer ; info: string ; begin socnr := SocnrfromSocket(Sender as TWSocket) ; { V9.3 } if (socnr < 0) then exit ; OK := 1; // don't check certificate until handshaking over if LogRcvdCerts then begin info := 'Received Certificate, Depth ' + IntToStr (Cert.VerifyDepth) + IcsCRLF + 'Verify Result: ' + Cert.VerifyErrMsg + IcsCRLF + Cert.CertInfo + IcsCRLF ; // Apr 2016 LogProgEvent (socnr, FCurTitle + ' ' + info); end; end; // Dec 2016 log SSL protocol messages for debugging procedure TIcsIpStrmLog.TlsSslProtoMsgEvent(Sender: TObject; Info: String; Sending: integer; Version: integer; ContentType: integer; Buffer: PAnsiChar; BuffSize: integer) ; var socnr: integer; begin socnr := SocnrfromSocket(Sender as TWSocket) ; { V9.3 } if (socnr < 0) then exit ; LogProgEvent (socnr, FCurTitle + ' SSL ProtoMsg: ' + info + ', DataLen=' + IntToStr (BuffSize) + ', Data=' + IcsBufferToHex (Buffer[0], BuffSize)) ; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetSslCliSecurity(Value: TSslCliSecurity); begin if Value = FLogSslCliSecurity then Exit; FLogSslCliSecurity := Value; FCliSslContext.SslCliSecurity := FLogSslCliSecurity; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TIcsIpStrmLog.GetIcsHosts: TIcsHostCollection; begin Result := FListenSocket.GetIcsHosts end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetIcsHosts(const Value: TIcsHostCollection); begin FListenSocket.SetIcsHosts(Value); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} (* function TIcsIpStrmLog.GetDHParams: String; begin Result := FListenSocket.DHParams; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetDHParams(const Value: String); begin FListenSocket.DHParams := Value; end; *) {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TIcsIpStrmLog.GetSslCliCertMethod: TSslCliCertMethod; begin Result := FListenSocket.SslCliCertMethod; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetSslCliCertMethod(const Value : TSslCliCertMethod); begin FListenSocket.SslCliCertMethod := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TIcsIpStrmLog.GetSslCertAutoOrder: Boolean; begin Result := FListenSocket.SslCertAutoOrder; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetSslCertAutoOrder(const Value : Boolean); begin FListenSocket.SslCertAutoOrder := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TIcsIpStrmLog.GetCertExpireDays: Integer; begin Result := FListenSocket.CertExpireDays; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetCertExpireDays(const Value : Integer); begin FListenSocket.CertExpireDays := Value; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {$IFDEF AUTO_X509_CERTS} function TIcsIpStrmLog.GetSslX509Certs: TSslX509Certs; begin Result := FListenSocket.GetSslX509Certs as TSslX509Certs; end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} procedure TIcsIpStrmLog.SetSslX509Certs(const Value : TSslX509Certs); begin FListenSocket.SetSslX509Certs(Value); end; {$ENDIF} // AUTO_X509_CERTS {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TIcsIpStrmLog.SrvValidateHosts(Stop1stErr: Boolean=True; NoExceptions: Boolean=False; AllowSelfSign: Boolean=False): String; { V8.63 } begin Result := FListenSocket.ValidateHosts(Stop1stErr, NoExceptions, AllowSelfSign); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} function TIcsIpStrmLog.SrvRecheckSslCerts(var CertsInfo: String; Stop1stErr: Boolean=True; NoExceptions: Boolean=False; AllowSelfSign: Boolean=False): Boolean; { V8.63 } begin Result := FListenSocket.RecheckSslCerts(CertsInfo, Stop1stErr, NoExceptions, AllowSelfSign); end; {* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *} {$ENDIF USE_SSL} end.