{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

Author:       François PIETTE
Creation:     Jan 24, 2003
Description:  A basic SSL server using TSslWSocket.
              Make use of OpenSSL (http://www.openssl.org)
Version:      1.00.1
EMail:        francois.piette@overbyte.be  http://www.overbyte.be
Support:      Use the mailing list ics-ssl@elists.org
              Follow "SSL" link at http://www.overbyte.be for subscription.
Legal issues: Copyright (C) 2003-2006 by François PIETTE
              Rue de Grady 24, 4053 Embourg, Belgium. Fax: +32-4-365.74.56
              <francois.piette@overbyte.be>
              SSL implementation includes code written by Arno Garrels,
              Berlin, Germany, contact: <arno.garrels@gmx.de>
              
              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.

              This code is _NOT_ freeware nor Open Source.
              To use it, you must financially contribute to the development.
              See SSL page on the author website for details.

              Once you got the right to use this software, you can use in your
              own applications only. Distributing the source code or compiled
              units or packages is prohibed.

              As this code make use of OpenSSL, your rights are restricted by
              OpenSSL license. See http://www.openssl.org for details.

              Further, the following restrictions applies:

              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.

History:
Mar 03, 2006 A.Garrels fixed some bugs and added session caching options to
             the GUI.

 * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
unit SimpleThrdSslServer1;

{ You must define USE_SSL in the project options so that SSL code is        }
{ included in the socket component.                                         }
{ To be able to compile the component, you must have the SSL related files  }
{ which are _NOT_ freeware. See http://www.overbyte.be for details.         }
{$IFNDEF USE_SSL}
    Bomb('Add USE_SSL in the define section in project options');
{$ENDIF}

{$B-}                                 { Enable partial boolean evaluation   }
{$T-}                                 { Untyped pointers                    }
{$X+}                                 { Enable extended syntax              }
{$H+}                                 { Use long strings                    }
{$J+}                                 { Allow typed constant to be modified }
{ If you use Delphi 7, you may wants to disable warnings for unsage type,   }
{ unsafe code and unsafe typecast in the project options. Those warning are }
{ intended for .NET programs. You may also want to turn off deprecated      }
{ symbol and platform symbol warnings.                                      }

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  IniFiles, StdCtrls, ExtCtrls, WSocket, WSocketS, IcsSSLEAY, IcsLIBEAY,
  WSocketTS, IcsLogger, IcsSslSessionCache;

const
  SimpleSslServer1Version            = 100;
  SimpleSslServer1Date               = 'Feb 02, 2003';
  SimpleSslServer1CopyRight : String = ' SimpleSslServer1 (c) 2003 Francois Piette V1.00.1 ';
  
  WM_SSL_NOT_TRUSTED = WM_USER + 1;
  WM_LOG_MESSAGE     = WM_USER + 2;
  
var
  LockDisplay : TRtlCriticalSection;

type
  { TTcpSrvClient is the class which will be instanciated by server component }
  { for each new client. N simultaneous clients means N TTcpSrvClient will be }
  { instanciated. Each being used to handle only a single client.             }
  { We can add any data that has to be private for each client, such as       }
  { receive buffer or any other data needed for processing.                   }
  TMyClient = class(TSslWSocketThrdClient)
  public
    RcvdLine    : String;
    ConnectTime : TDateTime;
  end;

  TSimpleThreadedSslServerForm = class(TForm)
    ToolsPanel: TPanel;
    DisplayMemo: TMemo;
    StartButton: TButton;
    Label1: TLabel;
    PortEdit: TEdit;
    Label3: TLabel;
    CertFileEdit: TEdit;
    Label7: TLabel;
    CAFileEdit: TEdit;
    Label6: TLabel;
    PrivKeyFileEdit: TEdit;
    Label4: TLabel;
    PassPhraseEdit: TEdit;
    Label2: TLabel;
    CAPathEdit: TEdit;
    VerifyPeerCheckBox: TCheckBox;
    StopButton: TButton;
    SslContext1: TSslContext;
    SslWSocketThrdServer1: TSslWSocketThrdServer;
    SslEnableCheckBox: TCheckBox;
    ClientsPerThreadEdit: TEdit;
    Label5: TLabel;
    IcsLogger1: TIcsLogger;
    ListenBacklogEdit: TEdit;
    Label10: TLabel;
    LoggingButton: TButton;
    RadioGroupSessionCache: TRadioGroup;
    SslAvlSessionCache1: TSslAvlSessionCache;
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure StartButtonClick(Sender: TObject);
    procedure SslWSocketThrdServer1ClientConnect(Sender: TObject;
      Client: TWSocketClient; Error: Word);
    procedure StopButtonClick(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
    procedure ClientVerifyPeer(Sender        : TObject;
                               var Ok        : Integer;
                               Cert          : TX509Base);
    procedure SslWSocketThrdServer1ClientDisconnect(Sender: TObject;
      Client: TWSocketClient; Error: Word);
    procedure ClientsPerThreadEditChange(Sender: TObject);
    procedure SslWSocketThrdServer1ThreadException(Sender: TObject;
      AThread: TWsClientThread; const AErrMsg: String);
    procedure SslWSocketThrdServer1BgException(Sender: TObject;
      E: Exception; var CanClose: Boolean);
    procedure LoggingButtonClick(Sender: TObject);
    procedure SslWSocketThrdServer1SslSvrGetSession(Sender: TObject;
      var SslSession: Pointer; SessId: Pointer; Idlen: Integer;
      var IncRefCount: Boolean);
    procedure SslWSocketThrdServer1SslSvrNewSession(Sender: TObject;
      SslSession, SessId: Pointer; Idlen: Integer;
      var AddToInternalCache: Boolean);
    procedure SslContext1RemoveSession(Sender: TObject;
      SslSession: Pointer);
  private
    FIniFileName : String;
    FInitialized : Boolean;
    FTrustedList : TStringList;
    FNotTrusted  : String;
    FLogList     : TStringList;
    procedure ClientDataAvailable(Sender: TObject; Error: Word);
    procedure ProcessData(Client : TMyClient);
    procedure ClientBgException(Sender       : TObject;
                                E            : Exception;
                                var CanClose : Boolean);
    procedure ClientLineLimitExceeded(Sender        : TObject;
                                      Cnt           : LongInt;
                                      var ClearData : Boolean);
    procedure WMSslNotTrusted(var Msg: TMessage); message WM_SSL_NOT_TRUSTED;
    procedure WmLogMessage(var Msg: TMessage); message WM_LOG_MESSAGE;
  public
    procedure Display(Msg : String);
    property IniFileName : String read FIniFileName write FIniFileName;
  end;

var
  SimpleThreadedSslServerForm: TSimpleThreadedSslServerForm;

implementation

{$R *.DFM}

const
    SectionWindow      = 'Window';   // Must be unique for each window
    KeyTop             = 'Top';
    KeyLeft            = 'Left';
    KeyWidth           = 'Width';
    KeyHeight          = 'Height';
    SectionData        = 'Data';
    KeyPort            = 'Port';
    KeyCertFile        = 'CertFile';
    KeyPassPhrase      = 'PassPhrase';
    KeyPrivKeyFile     = 'PrivKeyFile';
    KeyCAFile          = 'CAFile';
    KeyCAPath          = 'CAPath';
    KeyVerifyPeer      = 'VerifyPeer';
    KeyAcceptableHosts = 'AcceptableHosts';
    KeyCliPerThrd      = 'ClientsPerThread';
    KeySslEnable       = 'EnableSSL';
    KeySslCaching      = 'SslCaching';
    KeyListenBacklog   = 'ListenBacklog';

{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure BigConsole(nCols, nLines : Integer);
var
    sc : TCoord;
    N  : DWord;
begin
    if not IsConsole then
        Exit;
    sc.x := nCols;
    sc.y := nLines;
    SetConsoleScreenBufferSize(GetStdHandle(STD_OUTPUT_HANDLE), sc);
    SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
                            BACKGROUND_BLUE or BACKGROUND_GREEN or
                            BACKGROUND_RED or BACKGROUND_INTENSITY);
    sc.x := 0;
    sc.y := 0;
    FillConsoleOutputAttribute(GetStdHandle(STD_OUTPUT_HANDLE),
                               BACKGROUND_BLUE or BACKGROUND_GREEN or
                               BACKGROUND_RED or BACKGROUND_INTENSITY,
                               nCols * nLines, sc, N);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.FormCreate(Sender: TObject);
begin
    BigConsole(80, 100);
    FIniFileName   := LowerCase(ChangeFileExt(Application.ExeName, '.ini'));
    FTrustedList   := TStringList.Create;
    FLogList       := TStringList.Create;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.FormDestroy(Sender: TObject);
begin
    if Assigned(FTrustedList) then
        FreeAndNil(FTrustedList);
    EnterCriticalSection(LockDisplay);
    try
        if Assigned(FLogList) then
            FLogList.Free;
    finally
        LeaveCriticalSection(LockDisplay);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.WmLogMessage(var Msg: TMessage);
var
    I : Integer;
begin
    DisplayMemo.Lines.BeginUpdate;
    try
        if DisplayMemo.Lines.Count > 1200 then begin
            for I := 1 to 50 do
                DisplayMemo.Lines.Delete(0);
        end;
        EnterCriticalSection(LockDisplay);
        try
            DisplayMemo.Lines.AddStrings(FLogList);
            FLogList.Clear;
        finally
            LeaveCriticalSection(LockDisplay);
        end;
    finally
        DisplayMemo.Lines.EndUpdate;
        DisplayMemo.Perform(EM_SCROLLCARET, 0, 0);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.FormShow(Sender: TObject);
var
    IniFile : TIniFile;
begin
    if not FInitialized then begin
        FInitialized := TRUE;

        IniFile      := TIniFile.Create(FIniFileName);
        Width        := IniFile.ReadInteger(SectionWindow, KeyWidth,  Width);
        Height       := IniFile.ReadInteger(SectionWindow, KeyHeight, Height);
        Top          := IniFile.ReadInteger(SectionWindow, KeyTop,
                                            (Screen.Height - Height) div 2);
        Left         := IniFile.ReadInteger(SectionWindow, KeyLeft,
                                            (Screen.Width  - Width)  div 2);
        PortEdit.Text        := IniFile.ReadString(SectionData, KeyPort,
                                                   '443');
        CertFileEdit.Text    := IniFile.ReadString(SectionData, KeyCertFile,
                                                   '01cert.pem');
        PrivKeyFileEdit.Text := IniFile.ReadString(SectionData, KeyPrivKeyFile,
                                                   '01key.pem');
        PassPhraseEdit.Text  := IniFile.ReadString(SectionData, KeyPassPhrase,
                                                   'password');
        CAFileEdit.Text      := IniFile.ReadString(SectionData, KeyCAFile,
                                                   'cacert.pem');
        CAPathEdit.Text      := IniFile.ReadString(SectionData, KeyCAPath,
                                                   '');
        VerifyPeerCheckBox.Checked := Boolean(IniFile.ReadInteger(SectionData,
                                                                  KeyVerifyPeer,
                                                                  0));
        SslEnableCheckBox.Checked := Boolean(IniFile.ReadBool(SectionData,
                                                                 KeySslEnable,
                                                                 TRUE));
        ClientsPerThreadEdit.Text :=  IniFile.ReadString(SectionData,
                                                         KeyCliPerThrd, '5');
        ListenBacklogEdit.Text    :=  IniFile.ReadString(SectionData,
                                                         KeyListenBacklog, '5');

        RadioGroupSessionCache.ItemIndex := IniFile.ReadInteger(SectionData,
                                                         KeySslCaching, 1);

        IniFile.Destroy;
        DisplayMemo.Clear;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.FormClose(
    Sender     : TObject;
    var Action : TCloseAction);
var
    IniFile : TIniFile;
begin
    IniFile := TIniFile.Create(FIniFileName);
    IniFile.WriteInteger(SectionWindow, KeyTop,         Top);
    IniFile.WriteInteger(SectionWindow, KeyLeft,        Left);
    IniFile.WriteInteger(SectionWindow, KeyWidth,       Width);
    IniFile.WriteInteger(SectionWindow, KeyHeight,      Height);
    IniFile.WriteString(SectionData,    KeyPort,        PortEdit.Text);
    IniFile.WriteString(SectionData,    KeyCertFile,    CertFileEdit.Text);
    IniFile.WriteString(SectionData,    KeyPrivKeyFile, PrivKeyFileEdit.Text);
    IniFile.WriteString(SectionData,    KeyPassPhrase,  PassPhraseEdit.Text);
    IniFile.WriteString(SectionData,    KeyCAFile,      CAFileEdit.Text);
    IniFile.WriteString(SectionData,    KeyCAPath,      CAPathEdit.Text);
    IniFile.WriteInteger(SectionData,   KeyVerifyPeer,  Ord(VerifyPeerCheckBox.Checked));
    IniFile.WriteBool(SectionData,      KeySslEnable,   SslEnableCheckBox.Checked);
    IniFile.WriteString(SectionData,    KeyCliPerThrd,  ClientsPerThreadEdit.Text);
    IniFile.WriteString(SectionData,    KeyListenBacklog, ListenBacklogEdit.Text);
    IniFile.WriteInteger(SectionData,   KeySslCaching, RadioGroupSessionCache.ItemIndex);
    IniFile.Destroy;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.Display(Msg : String);
begin
    if Application.Terminated then Exit; // avoid AV's on application exit
    EnterCriticalSection(LockDisplay);
    try
        FLogList.Add(Msg);
        PostMessage(Handle, WM_LOG_MESSAGE, 0, 0);
    finally
        LeaveCriticalSection(LockDisplay);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.StartButtonClick(Sender: TObject);
begin
    SslWSocketThrdServer1.Proto         := 'tcp';
    SslWSocketThrdServer1.Addr          := '0.0.0.0'; // Use any interface
    SslWSocketThrdServer1.ListenBacklog := StrToIntDef(ListenBacklogEdit.Text, 5);
    SslWSocketThrdServer1.Port          := PortEdit.Text;
    SslWSocketThrdServer1.SslEnable     := SslEnableCheckBox.Checked;
    SslContext1.SslVersionMethod        := sslV23_SERVER; // includes TLS as well 
    SslContext1.SslCertFile             := CertFileEdit.Text;
    SslContext1.SslPassPhrase           := PassPhraseEdit.Text;
    SslContext1.SslPrivKeyFile          := PrivKeyFileEdit.Text;
    SslContext1.SslCAFile               := CAFileEdit.Text;
    SslContext1.SslCAPath               := CAPathEdit.Text;
    SslContext1.SslVerifyPeer           := VerifyPeerCheckBox.Checked;
    case RadioGroupSessionCache.ItemIndex of
     0 : begin
            { No session caching }
            SslContext1.SslSessionCacheModes := [];
            SslContext1.SslSessionTimeout    := 0;
            SslContext1.SslDefaultSessionIDContext   := '';
            SslWSocketThrdServer1.OnSslSvrNewSession := nil;
            SslWSocketThrdServer1.OnSslSvrGetSession := nil;
        end;
    1 : begin
            { If we use internal Openssl session cache }
            SslContext1.SslSessionCacheModes := [sslSESS_CACHE_SERVER];
            SslContext1.SslSessionTimeout    := 300; //Livetime of newly created sessions
            SslContext1.SslDefaultSessionIDContext   := 'AnythingUpTo32Bytes';
            SslWSocketThrdServer1.OnSslSvrNewSession := nil;
            SslWSocketThrdServer1.OnSslSvrGetSession := nil;
        end;
    2 : begin
            { External session caching }
            SslContext1.SslSessionCacheModes := [sslSESS_CACHE_SERVER,
                                                 sslSESS_CACHE_NO_INTERNAL_LOOKUP,
                                                 sslSESS_CACHE_NO_INTERNAL_STORE];
            SslContext1.SslSessionTimeout    := 300; //Livetime of newly created sessions
            SslContext1.SslDefaultSessionIDContext   := 'AnythingUpTo32Bytes';
            SslWSocketThrdServer1.OnSslSvrNewSession := SslWSocketThrdServer1SslSvrNewSession;
            SslWSocketThrdServer1.OnSslSvrGetSession := SslWSocketThrdServer1SslSvrGetSession;
        end;
    end;
    SslWSocketThrdServer1.Listen;
    SslWSocketThrdServer1.ClientClass := TMyClient; // Use our component
    Display('Listenning...');
    StartButton.Enabled := False;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslWSocketThrdServer1ClientConnect(
    Sender : TObject;
    Client : TWSocketClient;
    Error  : Word);
begin
    with Client as TMyClient do begin
        Display('Client connected.' +
                ' Remote: ' + PeerAddr + '/' + PeerPort +
                ' Local: '  + GetXAddr + '/' + GetXPort +
                ' ThrdID : $' + IntToStr(ClientThread.ThreadID) +
                ' ThrdCnt: #' + IntToStr(SslWSocketThrdServer1.ThreadCount) + #13#10 +
                'There is now ' +
                IntToStr(TSslWSocketThrdServer(Sender).ClientCount) +
                ' clients connected.');
        LineMode            := TRUE;
        LineEdit            := TRUE;
        LineLimit           := 1024; { Do not accept long lines }
        OnDataAvailable     := ClientDataAvailable;
        OnLineLimitExceeded := ClientLineLimitExceeded;
        OnBgException       := ClientBgException;
        OnSslVerifyPeer     := ClientVerifyPeer;
        ConnectTime         := Now;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslWSocketThrdServer1ClientDisconnect(
    Sender : TObject;
    Client : TWSocketClient;
    Error  : Word);
var
    MyClient       : TMyClient;
    ClientThreadID : Integer;
begin
    MyClient := Client as TMyClient;
    if Assigned(MyClient.ClientThread) then
        ClientThreadID := MyClient.ClientThread.ThreadID
    else
        ClientThreadID := -1;
    Display('Client disconnecting: ' + MyClient.PeerAddr + '   ' +
            'Duration: ' + FormatDateTime('hh:nn:ss',
            Now - MyClient.ConnectTime) + ' Error: ' + IntTostr(Error) +
            ' ThrdID: $' + IntToStr(ClientThreadID) +
            ' ThrdCnt: #' + IntToStr(TWSocketThrdServer(Sender).ThreadCount) +
            #13#10 + 'There is now ' +
            IntToStr(TWSocketThrdServer(Sender).ClientCount - 1) +
            ' clients connected.');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.ClientBgException(
    Sender       : TObject;
    E            : Exception;
    var CanClose : Boolean);
begin
    Display('Client exception occured: ' + E.ClassName + ': ' + E.Message);
    CanClose := TRUE;   // Goodbye client !
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.ClientDataAvailable(
    Sender : TObject;
    Error  : Word);
begin
    with Sender as TMyClient do begin
        { We use line mode. We will receive complete lines }
        RcvdLine := ReceiveStr;
        { Remove trailing CR/LF }
        while (Length(RcvdLine) > 0) and
              (RcvdLine[Length(RcvdLine)] in [#13, #10]) do
            RcvdLine := Copy(RcvdLine, 1, Length(RcvdLine) - 1);
        Display('Received from ' + GetPeerAddr + ': ''' + RcvdLine + '''');
        ProcessData(Sender as TMyClient);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.ClientLineLimitExceeded(
    Sender        : TObject;
    Cnt           : Integer;
    var ClearData : Boolean);
begin
    with Sender as TMyClient do begin
        Display('Line limit exceeded from ' + GetPeerAddr + '. Closing.');
        ClearData := TRUE;
        Close;
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.ProcessData(Client: TMyClient);
begin
    { This should be changed! Needed just for my MT-test }
    if Client.State = wsConnected then
    begin
        if (Pos('D:', Client.RcvdLine) = 1) or (Pos('L', Client.RcvdLine) = 1) then
            Client.SendStr(Client.RcvdLine + #13#10)
        else
            Client.SendStr('Unknown command: ''' + Client.RcvdLine + '''' + #13#10);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.StopButtonClick(Sender: TObject);
begin
    StartButton.Enabled := True;
    SslWSocketThrdServer1.Close;
    SslWSocketThrdServer1.DisconnectAll;
    SslContext1.DeInitContext;
    Display('Server stopped');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.WMSslNotTrusted(var Msg: TMessage);
begin
    if Application.MessageBox(
           PChar('Do you want to trust this certificate ?' + #10 +
                 FNotTrusted),
           PChar(Caption), MB_YESNO + MB_DEFBUTTON2) = ID_YES then begin
        FTrustedList.Add(FNotTrusted);
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.ClientVerifyPeer(Sender: TObject;
  var Ok: Integer; Cert: TX509Base);
var
    Issuer : String;
begin
    Issuer := Cert.IssuerOneLine;
    if Ok <> 0 then
        Display('Received certificate. Issuer = "' + Issuer + '"')
    else begin
        if Cert.VerifyResult = X509_V_ERR_SELF_SIGNED_CERT_IN_CHAIN then begin
            if FTrustedList.IndexOf(Issuer) >= 0 then begin
                Display('Received certificate. Issuer = "' + Issuer + '"');
                Display('We trust this one');
                Ok := 1;
                Exit;
            end;
            FNotTrusted := Issuer;
            (Sender as TSslWSocket).CloseDelayed;
            PostMessage(Handle, WM_SSL_NOT_TRUSTED, 0, 0);
            Exit;
        end;
        Display('Can''t verify certificate:');
        Display('  Issuer = "' + Issuer + '"');
        Display('  Error  = ' + IntToStr(Cert.VerifyResult) + ' (' + Cert.VerifyErrMsg + ')');
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.ClientsPerThreadEditChange(
  Sender: TObject);
var
    Num : Integer;
begin
    try
        Num := StrToInt((Sender as TEdit).Text);
    except
        Num := 1;
    end;
    SslWSocketThrdServer1.ClientsPerThread := Num;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslWSocketThrdServer1ThreadException(
  Sender: TObject; AThread: TWsClientThread; const AErrMsg: String);
begin
    Display(IntToStr(AThread.ThreadID) + ' ' + AErrMsg);
    MessageBeep(MB_ICONEXCLAMATION);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslWSocketThrdServer1BgException(
  Sender: TObject; E: Exception; var CanClose: Boolean);
begin
    Display('Background Exeption: ' + E.ClassName + ': ' + E.Message);
    CanClose := False;
    MessageBeep(MB_ICONEXCLAMATION);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.LoggingButtonClick(Sender: TObject);
begin
    if IcsLogger1.LogOptions = [] then begin
        IcsLogger1.OpenLogFile;
        IcsLogger1.LogOptions := [loDestFile,loWsockErr,loWsockInfo,loWsockDump,
                                  loSslErr,loSslInfo,loProtSpecErr,
                                  loProtSpecInfo,loProtSpecDump];
        TButton(Sender).Caption := 'Disable logging';
    end
    else begin
        IcsLogger1.CloseLogFile;
        IcsLogger1.LogOptions := [];
        TButton(Sender).Caption := 'Enable full logging to file';
    end;
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslWSocketThrdServer1SslSvrGetSession(
  Sender: TObject; var SslSession: Pointer; SessId: Pointer;
  Idlen: Integer; var IncRefCount: Boolean);
var
    LookupKey : String;
begin
    SetLength(LookupKey, IDLen);
    StrLCopy(PChar(LookupKey), PChar(SessId), IDLen);
    SslSession  := SslAvlSessionCache1.GetSvrSession(LookupKey, IncRefCount);
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslWSocketThrdServer1SslSvrNewSession(
  Sender: TObject; SslSession, SessId: Pointer; Idlen: Integer;
  var AddToInternalCache: Boolean);
var
    LookupKey : String;
begin
    SetLength(LookupKey, IDLen);
    StrLCopy(PChar(LookupKey), PChar(SessId), IDLen);
    SslAvlSessionCache1.CacheSvrSession(SslSession, LookupKey, AddToInternalCache);
    Display('[' + FormatDateTime('HH:NN:SS', Now) + ' ' +
            TWSocket(Sender).GetPeerAddr + '] New SSL session created and ' +
           'cached in external cache class.');

end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
procedure TSimpleThreadedSslServerForm.SslContext1RemoveSession(
  Sender: TObject; SslSession: Pointer);
begin
    Display('SSL session removed');
end;


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
initialization
    InitializeCriticalSection(LockDisplay);


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
finalization
    DeleteCriticalSection(LockDisplay);


{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}

end.
