{
  Loopback regression test for the fpwebsocketclient message pump.

  Written to evaluate the WebSocket shutdown/recovery patch. The patch makes
  the pump own and join its reader thread, handles irClose, prevents callback
  self-join, and interrupts only the transport currently blocked in a read.

  On Windows, a stuck read is interrupted with raw socket shutdown followed
  by CancelIoEx. The socket descriptor and TLS objects remain alive until the
  reader thread has exited.

  Scenarios
  ---------
    1  HTTP upgrade handshake against FPC's own TWebSocketServer, and echo.
    2  Repeated Execute/Terminate on a healthy pump; each echo is matched by
       content so a stale reply cannot pass for a fresh one.
    3  Peer close: exactly one OnDisconnect, and the client goes inactive.
    4  Terminate while a healthy connection is idle; the connection remains
       usable after restarting the pump.
    5  Upgrade, echo and peer close over TLS.
    6  Partial-frame stall over plain TCP.
    7  Partial-frame stall over TLS, with the reader blocked inside SSL_read.
    8  Terminate called from the OnDisconnect callback on the reader thread.
    9  A healthy client sharing one pump with a partial-frame stalled client.
   10  Terminate while a callback waits in TThread.Synchronize for the main
       thread - the one wait that interrupting a socket cannot end.
   11  A connection that an earlier OnDisconnect callback destroys while the
       pump still holds it in its notification queue.
   12  An exception from a later client while an earlier one is queued for
       notification.

  Scenarios 6, 7 and 9 deliberately put the reader inside a genuinely
  blocking read. The other scenarios exercise bounded polling, connection
  state, callbacks and compatibility.

  How it runs
  -----------
  Without arguments, the program re-executes itself once per scenario using
  --scenario N. The parent supervises each child with a timeout, so a hung
  scenario is killed and reported as HUNG without stopping the remaining
  tests. Each child also has an internal watchdog.

  The separate --pump-first mode demonstrates the unrelated case where a pump
  is destroyed before a client that still references it. It is excluded from
  the numbered run and is expected to fail or crash.

  The separate --interrupt-race mode stages a read that completes exactly
  while the pump is interrupting sockets. It is excluded from the numbered
  run because it asks about a window a few instructions wide, which only a
  deliberately delayed copy of the patch can be expected to show.

  Child exit codes: 0 passed, 1 failed, 2 skipped, 99 watchdog,
  98 self-test failure.

  Runner exit code: number of failed, hung and crashed scenarios.
}

program wsshutdowntest;

{$mode objfpc}{$H+}

uses
  {$IFDEF UNIX}cthreads, BaseUnix,{$ENDIF}
  SysUtils, Classes, process, sockets, ssockets, sslbase, sslsockets,
  opensslsockets, sha1, base64,
  fpwebsocket, fpcustwsserver, fpwebsocketserver, fpwebsocketclient;

Const
  WaitLimitMs    = 5000;   // how long a scenario waits for an expected event
  ScenarioLimitS = 45;     // in-child watchdog budget per scenario
  ChildLimitMs   = 60000;  // runner's hard limit per child process
  PollMs         = 5;

{ ---------------------------------------------------------------------
  Cross-thread flags and counters.

  Callbacks fire on the pump's reader thread and on server threads, so
  nothing they touch may be a plain field read from the main thread.
  Counters are LongInt manipulated only through InterLocked*; strings are
  guarded by a critical section.
  --------------------------------------------------------------------- }

Function ReadCounter(Var aValue : LongInt) : LongInt;
begin
  Result:=InterLockedExchangeAdd(aValue,0);
end;

Procedure BumpCounter(Var aValue : LongInt);
begin
  InterLockedIncrement(aValue);
end;

{ ---------------------------------------------------------------------
  Output and per-scenario bookkeeping
  --------------------------------------------------------------------- }

Var
  OutLock : TRTLCriticalSection;
  StateLock : TRTLCriticalSection;
  ScenariosPassed : Integer = 0;
  ScenariosFailed : Integer = 0;
  ScenariosSkipped : Integer = 0;
  CurrentName : String = '';
  CurrentFailed : Boolean = False;
  CurrentDeadline : QWord = 0;   // 0 = watchdog idle

Procedure Say(Const aLine : String);
begin
  EnterCriticalSection(OutLock);
  try
    Writeln(aLine);
    Flush(Output);
  finally
    LeaveCriticalSection(OutLock);
  end;
end;

Procedure SetDeadline(Const aName : String; aDeadline : QWord);
begin
  EnterCriticalSection(StateLock);
  try
    CurrentName:=aName;
    CurrentDeadline:=aDeadline;
  finally
    LeaveCriticalSection(StateLock);
  end;
end;

Procedure GetDeadline(Out aName : String; Out aDeadline : QWord);
begin
  EnterCriticalSection(StateLock);
  try
    aName:=CurrentName;
    aDeadline:=CurrentDeadline;
  finally
    LeaveCriticalSection(StateLock);
  end;
end;

Procedure BeginScenario(Const aName : String);
begin
  CurrentFailed:=False;
  SetDeadline(aName,GetTickCount64+QWord(ScenarioLimitS)*1000);
  Say('--- '+aName);
end;

{ One assertion inside the current scenario. }
Procedure Check(Const aWhat : String; aOK : Boolean; Const aDetail : String = '');
begin
  if aOK then
    Say('    ok    '+aWhat)
  else
    begin
    begin
    if aDetail='' then
      Say('    FAIL  '+aWhat)
    else
      Say('    FAIL  '+aWhat+'  ('+aDetail+')');
    end;
    CurrentFailed:=True;
    end;
end;

{ In a child process each of these ends the run, so the exit code carries
  the single scenario's verdict back to the runner. }
Procedure EndScenario;
begin
  SetDeadline('',0);
  if CurrentFailed then
    begin
    Inc(ScenariosFailed);
    Say('    => FAILED');
    end
  else
    begin
    Inc(ScenariosPassed);
    Say('    => passed');
    end;
end;

Procedure SkipScenario(Const aName, aReason : String);
begin
  SetDeadline('',0);
  Inc(ScenariosSkipped);
  Say('--- '+aName);
  Say('    => SKIPPED: '+aReason);
end;

{ ---------------------------------------------------------------------
  Watchdog. A scenario that hangs would otherwise make the whole run
  stall silently, and the hanging call can never report its own failure.
  --------------------------------------------------------------------- }

Type
  TWatchdog = Class(TThread)
  Public
    Procedure Execute; override;
  end;

Procedure TWatchdog.Execute;
Var
  D : QWord;
  N : String;
begin
  While not Terminated do
    begin
    GetDeadline(N,D);
    if (D<>0) and (GetTickCount64>D) then
      begin
      Say('');
      Say('WATCHDOG: scenario "'+N+'" exceeded '
         +IntToStr(ScenarioLimitS)+' s - it is hung.');
      Say('This is itself the finding: the call under test never returned.');
      Flush(Output);
      Halt(99);
      end;
    Sleep(100);
    end;
end;

{ ---------------------------------------------------------------------
  Ports. Fixed ports make two concurrent runs interfere, so each run
  picks its own base and walks upwards from there.
  --------------------------------------------------------------------- }

Var
  PortSeq : Integer = 0;
  PortBase : Integer;

Function NextPort : Word;
begin
  Inc(PortSeq);
  Result:=PortBase+PortSeq;
end;

{ Wait until a counter reaches at least aWanted, or the limit expires. }
Function WaitForCount(Var aCounter : LongInt; aWanted : LongInt;
                      aLimitMs : Integer = WaitLimitMs) : Boolean;
Var
  Waited : Integer;
begin
  Waited:=0;
  While (ReadCounter(aCounter)<aWanted) and (Waited<aLimitMs) do
    begin
    Sleep(PollMs);
    Inc(Waited,PollMs);
    end;
  Result:=ReadCounter(aCounter)>=aWanted;
end;

{ ---------------------------------------------------------------------
  Sec-WebSocket-Accept, needed by the hand-rolled stall peer.
  --------------------------------------------------------------------- }

Function CalcAccept(Const aKey : String) : String;
Var
  Hash : TSHA1Digest;
  B : TBytes;
begin
  Hash:=SHA1String(Trim(aKey)+SSecWebSocketGUID);
  SetLength(B,SizeOf(Hash));
  Move(Hash,B[0],Length(B));
  Result:=EncodeBytesBase64(B);
end;

{ RFC 6455 section 1.3 known-answer vector. If this is wrong every stall
  scenario would fail for the wrong reason, so it is checked first. }
Function SelfTestAccept : Boolean;
Const
  RFCKey    = 'dGhlIHNhbXBsZSBub25jZQ==';
  RFCExpect = 's3pPLMBiTxaQ9kYGzzhZRbK+xOo=';
Var
  Got : String;
begin
  Got:=CalcAccept(RFCKey);
  Result:=Got=RFCExpect;
  if not Result then
    Say('    FAIL  RFC 6455 accept vector: got '+Got+', expected '+RFCExpect);
end;

{ ---------------------------------------------------------------------
  Echo server. Three behaviours: echo, close after the first message, or
  send half a frame and then stay silent.
  --------------------------------------------------------------------- }

Type
  TServerMode = (smEcho, smCloseAfterMessage, smStallAfterMessage);

  TEchoServer = Class
  Private
    FServer : TWebSocketServer;
    FPort : Word;
    FMode : TServerMode;
    FCert : TCertificateData;
    FReceived : LongInt;
    FHalfSent : LongInt;
    FErrors : LongInt;
    FRelease : LongInt;   // set by the test to let a parked callback return
    FStopping : LongInt;  // set during teardown so a parked callback exits
    FLastError : String;
    FErrLock : TRTLCriticalSection;
    Procedure DoMessage(Sender : TObject; Const aMessage : TWSMessage);
    Procedure DoGetHandler(Sender : TObject; Const aUseSSL : Boolean; Out aHandler : TSocketHandler);
    Procedure NoteError(Const aMsg : String);
  Public
    Constructor Create(aPort : Word; aMode : TServerMode; aUseSSL : Boolean);
    Destructor Destroy; override;
    Procedure Start;
    Procedure Stop;
    Function LastError : String;
    Procedure Release;
    Property Port : Word Read FPort;
    Property Received : LongInt Read FReceived;
    Property HalfSent : LongInt Read FHalfSent;
    Property Errors : LongInt Read FErrors;
  end;

Constructor TEchoServer.Create(aPort : Word; aMode : TServerMode; aUseSSL : Boolean);
begin
  InitCriticalSection(FErrLock);
  FPort:=aPort;
  FMode:=aMode;
  FServer:=TWebSocketServer.Create(Nil);
  FServer.Port:=aPort;
  FServer.Host:='127.0.0.1';
  FServer.ThreadedAccept:=True;
  FServer.ThreadMode:=wtmThread;
  FServer.OnMessageReceived:=@DoMessage;
  if aUseSSL then
    begin
    { TWebSocketServer.CertificateData is declared but never instantiated,
      so the built-in CreateSSLSocketHandler dereferences nil. We supply
      the handler ourselves and own the certificate. The client runs with
      VerifyPeerCert:=False, so a generated self-signed cert suffices. }
    FCert:=TCertificateData.Create;
    FCert.HostName:='127.0.0.1';
    FServer.OnGetSocketHandler:=@DoGetHandler;
    FServer.UseSSL:=True;
    end;
end;

Destructor TEchoServer.Destroy;
begin
  Stop;
  FreeAndNil(FServer);
  FreeAndNil(FCert);
  DoneCriticalSection(FErrLock);
  inherited Destroy;
end;

Procedure TEchoServer.NoteError(Const aMsg : String);
begin
  EnterCriticalSection(FErrLock);
  try
    FLastError:=aMsg;
  finally
    LeaveCriticalSection(FErrLock);
  end;
  BumpCounter(FErrors);
end;

Function TEchoServer.LastError : String;
begin
  EnterCriticalSection(FErrLock);
  try
    Result:=FLastError;
  finally
    LeaveCriticalSection(FErrLock);
  end;
end;

Procedure TEchoServer.DoGetHandler(Sender : TObject; Const aUseSSL : Boolean;
  Out aHandler : TSocketHandler);
Var
  S : TSSLSocketHandler;
  CK : TCertAndKey;
begin
  aHandler:=Nil;
  if not aUseSSL then
    Exit;
  S:=TSSLSocketHandler.GetDefaultHandler;
  try
    if FCert.NeedCertificateData then
      begin
      S.CertGenerator.HostName:=FCert.HostName;
      CK:=S.CertGenerator.CreateCertificateAndKey;
      FCert.Certificate.Value:=CK.Certificate;
      FCert.PrivateKey.Value:=CK.PrivateKey;
      end;
    S.CertificateData:=FCert;
    aHandler:=S;
  except
    On E : Exception do
      begin
      S.Free;
      NoteError('handler: '+E.Message);
      Raise;
      end;
  end;
end;

Procedure TEchoServer.DoMessage(Sender : TObject; Const aMessage : TWSMessage);
Var
  Con : TWSServerConnection;
  Half : TBytes;
begin
  BumpCounter(FReceived);
  try
    Con:=Sender as TWSServerConnection;
    Case FMode of
      smEcho:
        Con.Send(aMessage.AsString);
      smCloseAfterMessage:
        Con.Disconnect;
      smStallAfterMessage:
        begin
        { A final text frame announcing five payload bytes that never
          arrive. Written through the transport, so over TLS this lands
          inside a TLS record and parks the client in SSL_read. }
        Half:=[$81,$05];
        Con.Transport.WriteBuffer(Half);
        BumpCounter(FHalfSent);
        { Park here instead of returning. If this callback returned, the
          server would resume reading, notice the FIN that the client's
          own SHUT_RDWR produces, and close the connection - and that peer
          activity, not the local shutdown, would release the client's
          read. The plain-TCP peer holds its connection open in exactly
          the same way, so both scenarios differ only in transport. }
        While (ReadCounter(FRelease)=0) and (ReadCounter(FStopping)=0) do
          Sleep(25);
        end;
    end;
  except
    On E : Exception do
      NoteError('message: '+E.Message);
  end;
end;

Procedure TEchoServer.Release;
begin
  InterLockedExchange(FRelease,1);
end;

Procedure TEchoServer.Start;
begin
  FServer.Active:=True;
end;

Procedure TEchoServer.Stop;
begin
  InterLockedExchange(FStopping,1);
  if Assigned(FServer) and FServer.Active then
    Try
      FServer.Active:=False;
    except
      On E : Exception do
        NoteError('stop: '+E.Message);
    end;
end;


{ ---------------------------------------------------------------------
  Read instrumentation.

  The stall scenarios need to prove that the reader is actually parked in
  a payload read, not merely that time has passed. TWSConnection's
  CheckIncoming is not virtual, but GetTransport is, so a delegating
  IWSTransport can count entries and exits of the blocking reads.

  While ReadEntries > ReadExits the frame reader is inside a read. Each
  scenario runs in its own process, so plain globals are safe here.
  --------------------------------------------------------------------- }

Var
  ReadEntries : LongInt = 0;
  ReadExits : LongInt = 0;

Function ReaderIsInsideRead : Boolean;
begin
  Result:=ReadCounter(ReadEntries)>ReadCounter(ReadExits);
end;

Type
  { IWSTransport is declared under {$INTERFACES CORBA}, so references
    through it are NOT reference counted. The wrapper therefore has to be
    owned and freed explicitly by the connection that installs it. }
  TInstrumentedTransport = Class(TObject, IWSTransport)
  Private
    FInner : IWSTransport;
  Public
    Constructor Create(aInner : IWSTransport);
    Function CanRead(aTimeOut: Integer) : Boolean;
    Procedure ReadBuffer(aBytes : TBytes);
    Function ReadBytes(var aBytes : TBytes; aCount : Integer) : Integer;
    Function WriteBytes(aBytes : TBytes; aCount : Integer) : Integer;
    Procedure WriteBuffer(aBytes : TBytes);
    Function ReadLn : String;
    Function PeerIP : string;
    Function PeerPort : word;
  end;

Constructor TInstrumentedTransport.Create(aInner : IWSTransport);
begin
  FInner:=aInner;
end;

{ CanRead is a bounded select, not a blocking read - not counted. }
Function TInstrumentedTransport.CanRead(aTimeOut: Integer) : Boolean;
begin
  Result:=FInner.CanRead(aTimeOut);
end;

Procedure TInstrumentedTransport.ReadBuffer(aBytes : TBytes);
begin
  BumpCounter(ReadEntries);
  try
    FInner.ReadBuffer(aBytes);
  finally
    BumpCounter(ReadExits);
  end;
end;

Function TInstrumentedTransport.ReadBytes(var aBytes : TBytes; aCount : Integer) : Integer;
begin
  BumpCounter(ReadEntries);
  try
    Result:=FInner.ReadBytes(aBytes,aCount);
  finally
    BumpCounter(ReadExits);
  end;
end;

Function TInstrumentedTransport.WriteBytes(aBytes : TBytes; aCount : Integer) : Integer;
begin
  Result:=FInner.WriteBytes(aBytes,aCount);
end;

Procedure TInstrumentedTransport.WriteBuffer(aBytes : TBytes);
begin
  FInner.WriteBuffer(aBytes);
end;

Function TInstrumentedTransport.ReadLn : String;
begin
  BumpCounter(ReadEntries);
  try
    Result:=FInner.ReadLn;
  finally
    BumpCounter(ReadExits);
  end;
end;

Function TInstrumentedTransport.PeerIP : string;
begin
  Result:=FInner.PeerIP;
end;

Function TInstrumentedTransport.PeerPort : word;
begin
  Result:=FInner.PeerPort;
end;

Type
  TInstrumentedConnection = Class(TWebSocketClientConnection)
  Private
    FWrapper : TInstrumentedTransport;   // owned, see the note above
  Protected
    Function GetTransport : IWSTransport; override;
  Public
    Destructor Destroy; override;
  end;

Function TInstrumentedConnection.GetTransport : IWSTransport;
begin
  if FWrapper=Nil then
    FWrapper:=TInstrumentedTransport.Create(inherited GetTransport);
  Result:=FWrapper;
end;

Destructor TInstrumentedConnection.Destroy;
begin
  inherited Destroy;
  FreeAndNil(FWrapper);
end;

Type
  TInstrumentedClient = Class(TWebsocketClient)
  Protected
    Function CreateClientConnection(aTransport : TWSClientTransport) : TWebsocketClientConnection; override;
  end;

Function TInstrumentedClient.CreateClientConnection(aTransport : TWSClientTransport) : TWebsocketClientConnection;
begin
  Result:=TInstrumentedConnection.Create(Self,aTransport,Options);
end;


{ ---------------------------------------------------------------------
  Lifetime probe.

  Scenario 11 destroys a connection that the pump has already collected for
  notification. The question is whether the collected pointer is used
  afterwards, so a probe connection notes its own address as its instance
  is released, and DoDisconnect consults that note before anything else.

  FreeInstance deliberately keeps the block instead of returning it to the
  heap. The destructor has run and CleanupInstance has finalised the
  fields, so the object is destroyed in every sense that matters - but the
  memory and the VMT pointer stay valid, so a later call lands in this
  class and can be counted rather than jumping into whatever the heap
  manager has since written there. The instances leak on purpose; the
  scenario ends the process shortly afterwards.
  --------------------------------------------------------------------- }

Const
  MaxDestroyed = 32;

Var
  DestroyedAddrs : Array[0..MaxDestroyed-1] of Pointer;
  DestroyedCount : LongInt = 0;
  UseAfterFree : LongInt = 0;

Procedure NoteDestroyed(aAddr : Pointer);
Var
  N : LongInt;
begin
  N:=InterLockedIncrement(DestroyedCount)-1;
  if (N>=0) and (N<MaxDestroyed) then
    DestroyedAddrs[N]:=aAddr;
end;

Function WasDestroyed(aAddr : Pointer) : Boolean;
Var
  I, N : LongInt;
begin
  Result:=False;
  N:=ReadCounter(DestroyedCount);
  if N>MaxDestroyed then
    N:=MaxDestroyed;
  For I:=0 to N-1 do
    if DestroyedAddrs[I]=aAddr then
      Exit(True);
end;

Type
  TProbeConnection = Class(TWebSocketClientConnection)
  Public
    Procedure FreeInstance; override;
    Procedure DoDisconnect; override;
  end;

Procedure TProbeConnection.FreeInstance;
begin
  { TObject.FreeInstance is CleanupInstance followed by FreeMem. The second
    half is skipped on purpose - see the note above. }
  CleanupInstance;
  NoteDestroyed(Self);
end;

Procedure TProbeConnection.DoDisconnect;
begin
  if WasDestroyed(Self) then
    begin
    BumpCounter(UseAfterFree);
    Say('      DoDisconnect entered on a connection that was already destroyed');
    Exit;
    end;
  inherited DoDisconnect;
end;

Type
  TProbeClient = Class(TWebsocketClient)
  Protected
    Function CreateClientConnection(aTransport : TWSClientTransport) : TWebsocketClientConnection; override;
  end;

Function TProbeClient.CreateClientConnection(aTransport : TWSClientTransport) : TWebsocketClientConnection;
begin
  Result:=TProbeConnection.Create(Self,aTransport,Options);
end;

Type
  { TWSMessagePump.List is protected, so asking the pump which connections
    it still tracks needs a descendant rather than a cast. }
  TProbePump = Class(TWSThreadMessagePump)
  Public
    Function ClientCount : Integer;
    Function Tracks(aConnection : TWSClientConnection) : Boolean;
  end;

Function TProbePump.ClientCount : Integer;
Var
  L : TList;
begin
  L:=List.LockList;
  try
    Result:=L.Count;
  finally
    List.UnlockList;
  end;
end;

Function TProbePump.Tracks(aConnection : TWSClientConnection) : Boolean;
Var
  L : TList;
begin
  L:=List.LockList;
  try
    Result:=L.IndexOf(aConnection)>=0;
  finally
    List.UnlockList;
  end;
end;

Type
  { TWSErrorEvent is a method pointer, so the pump's OnError needs an
    object to report into. }
  TErrorSink = Class
  Private
    FErrors : LongInt;
    FLast : String;
    FLock : TRTLCriticalSection;
  Public
    Constructor Create;
    Destructor Destroy; override;
    Procedure DoError(Sender : TObject; E : Exception);
    Function LastError : String;
    Property Errors : LongInt Read FErrors;
  end;

Constructor TErrorSink.Create;
begin
  InitCriticalSection(FLock);
end;

Destructor TErrorSink.Destroy;
begin
  DoneCriticalSection(FLock);
  inherited Destroy;
end;

Procedure TErrorSink.DoError(Sender : TObject; E : Exception);
begin
  EnterCriticalSection(FLock);
  try
    FLast:=E.ClassName+': '+E.Message;
  finally
    LeaveCriticalSection(FLock);
  end;
  BumpCounter(FErrors);
end;

Function TErrorSink.LastError : String;
begin
  EnterCriticalSection(FLock);
  try
    Result:=FLast;
  finally
    LeaveCriticalSection(FLock);
  end;
end;


{ ---------------------------------------------------------------------
  Client wrapper. Counters rather than flags, so "exactly once" can be
  asserted.
  --------------------------------------------------------------------- }

Type
  TTestClient = Class
  Private
    FClient : TWebsocketClient;
    FMessages : LongInt;
    FDisconnects : LongInt;
    FLast : String;
    FLastLock : TRTLCriticalSection;
    FTerminateOnDisconnect : TWSMessagePump;
    FTerminateEntered : LongInt;    // the callback reached the Terminate call
    FTerminateReturned : LongInt;   // Terminate returned normally
    FTerminateRaised : LongInt;     // Terminate raised an exception
    FTerminateError : String;
    FTermLock : TRTLCriticalSection;
    FSyncOnMessage : Boolean;
    FSyncEntered : LongInt;    // the callback is about to call Synchronize
    FSyncReturned : LongInt;   // Synchronize returned
    FRaiseOnMessage : Boolean;
    FTearDownOnDisconnect : TCustomWebsocketClient;
    Procedure DoNothing;
    Procedure DoMessage(Sender : TObject; Const aMessage : TWSMessage);
    Procedure DoDisconnect(Sender : TObject);
  Public
    Constructor Create(aPort : Word; aPump : TWSMessagePump; aUseSSL : Boolean = False;
                       aInstrument : Boolean = False; aProbe : Boolean = False);
    Destructor Destroy; override;
    Function LastMessage : String;
    Property Client : TWebsocketClient Read FClient;
    Property Messages : LongInt Read FMessages;
    Property Disconnects : LongInt Read FDisconnects;
    { When set, OnDisconnect calls Terminate on this pump - from the reader
      thread, which is what makes the patched Terminate join itself. }
    Property TerminateOnDisconnect : TWSMessagePump
      Read FTerminateOnDisconnect Write FTerminateOnDisconnect;
    { When set, OnMessage parks in TThread.Synchronize. That call only
      returns once someone runs CheckSynchronize on the main thread. }
    Property SyncOnMessage : Boolean Read FSyncOnMessage Write FSyncOnMessage;
    { When set, OnMessage raises an ordinary exception after counting the
      message - an application callback that fails, nothing more. }
    Property RaiseOnMessage : Boolean Read FRaiseOnMessage Write FRaiseOnMessage;
    { When set, the first OnDisconnect disconnects this other client, which
      frees its connection object. Ordinary application behaviour: one
      connection drops, so the rest are torn down as well. }
    Property TearDownOnDisconnect : TCustomWebsocketClient
      Read FTearDownOnDisconnect Write FTearDownOnDisconnect;
    Property SyncEntered : LongInt Read FSyncEntered;
    Property SyncReturned : LongInt Read FSyncReturned;
    Property TerminateEntered : LongInt Read FTerminateEntered;
    Property TerminateReturned : LongInt Read FTerminateReturned;
    Property TerminateRaised : LongInt Read FTerminateRaised;
    Function TerminateError : String;
  end;

Constructor TTestClient.Create(aPort : Word; aPump : TWSMessagePump; aUseSSL : Boolean = False;
                               aInstrument : Boolean = False; aProbe : Boolean = False);
begin
  InitCriticalSection(FLastLock);
  InitCriticalSection(FTermLock);
  if aProbe then
    FClient:=TProbeClient.Create(Nil)
  else if aInstrument then
    FClient:=TInstrumentedClient.Create(Nil)
  else
    FClient:=TWebsocketClient.Create(Nil);
  FClient.HostName:='127.0.0.1';
  FClient.Port:=aPort;
  FClient.Resource:='/';
  FClient.UseSSL:=aUseSSL;
  FClient.MessagePump:=aPump;
  FClient.OnMessageReceived:=@DoMessage;
  FClient.OnDisconnect:=@DoDisconnect;
end;

Destructor TTestClient.Destroy;
begin
  FreeAndNil(FClient);
  DoneCriticalSection(FTermLock);
  DoneCriticalSection(FLastLock);
  inherited Destroy;
end;

Procedure TTestClient.DoNothing;
begin
  { The body is irrelevant; what matters is that it runs on the main
    thread, so the reader thread waits until the main thread services it. }
end;

Procedure TTestClient.DoMessage(Sender : TObject; Const aMessage : TWSMessage);
begin
  EnterCriticalSection(FLastLock);
  try
    FLast:=aMessage.AsString;
  finally
    LeaveCriticalSection(FLastLock);
  end;
  BumpCounter(FMessages);
  if FSyncOnMessage then
    begin
    BumpCounter(FSyncEntered);
    TThread.Synchronize(TThread.CurrentThread,@DoNothing);
    BumpCounter(FSyncReturned);
    end;
  if FRaiseOnMessage then
    Raise Exception.Create('deliberate failure in an OnMessage callback');
end;

Procedure TTestClient.DoDisconnect(Sender : TObject);
Var
  Other : TCustomWebsocketClient;
begin
  BumpCounter(FDisconnects);
  if Assigned(FTearDownOnDisconnect) then
    begin
    { Once only: the teardown itself produces an OnDisconnect. }
    Other:=FTearDownOnDisconnect;
    FTearDownOnDisconnect:=Nil;
    Other.Disconnect(False);
    end;
  if Assigned(FTerminateOnDisconnect) then
    begin
    { Three outcomes have to be told apart: a normal return, an exception,
      and neither - the last one being a genuine self-join deadlock. On
      glibc pthread_join detects self-join and returns EDEADLK, which FPC
      ignores, so the failure surfaces later as an exception instead. }
    BumpCounter(FTerminateEntered);
    try
      FTerminateOnDisconnect.Terminate;
      BumpCounter(FTerminateReturned);
    except
      On E : Exception do
        begin
        EnterCriticalSection(FTermLock);
        try
          FTerminateError:=E.ClassName+': '+E.Message;
        finally
          LeaveCriticalSection(FTermLock);
        end;
        BumpCounter(FTerminateRaised);
        end;
    end;
    end;
end;

Function TTestClient.TerminateError : String;
begin
  EnterCriticalSection(FTermLock);
  try
    Result:=FTerminateError;
  finally
    LeaveCriticalSection(FTermLock);
  end;
end;

Function TTestClient.LastMessage : String;
begin
  EnterCriticalSection(FLastLock);
  try
    Result:=FLast;
  finally
    LeaveCriticalSection(FLastLock);
  end;
end;

{ ---------------------------------------------------------------------
  Plain-TCP stall peer: completes the upgrade by hand, then sends two
  bytes of a frame header and holds the connection open.
  --------------------------------------------------------------------- }

Type
  TStallServer = Class(TThread)
  Private
    FPort : Word;
    FListener : TInetServer;
    FHandshakes : LongInt;
    FHalfSent : LongInt;
    FRestSent : LongInt;
    FSendRest : LongInt;
    FErrors : LongInt;
    FLastError : String;
    FErrLock : TRTLCriticalSection;
    Procedure DoConnect(Sender : TObject; Data : TSocketStream);
    Procedure NoteError(Const aMsg : String);
  Public
    Constructor Create(aPort : Word);
    Destructor Destroy; override;
    Procedure Execute; override;
    Procedure Shutdown;
    { Release the five payload bytes the half frame announced. Used to make
      a parked read complete at a chosen moment. }
    Procedure SendRest;
    Function LastError : String;
    Property Handshakes : LongInt Read FHandshakes;
    Property HalfSent : LongInt Read FHalfSent;
    Property RestSent : LongInt Read FRestSent;
    Property Errors : LongInt Read FErrors;
  end;

Constructor TStallServer.Create(aPort : Word);
begin
  InitCriticalSection(FErrLock);
  FPort:=aPort;
  FListener:=TInetServer.Create('127.0.0.1',aPort);
  FListener.OnConnect:=@DoConnect;
  FListener.QueueSize:=5;
  FreeOnTerminate:=False;
  Inherited Create(False);
end;

{ Terminate, stop accepting, join - in that order - then release the
  listener. The destructor must not be the thing that stops the thread. }
Procedure TStallServer.Shutdown;
begin
  Terminate;
  if Assigned(FListener) then
    Try
      FListener.StopAccepting(True);
    except
      // the accept loop may already be gone
    end;
  WaitFor;
end;

Destructor TStallServer.Destroy;
begin
  { Safe even if the caller already did it: Terminate and StopAccepting
    are idempotent, and WaitFor on a finished thread returns at once. }
  Shutdown;
  FreeAndNil(FListener);
  inherited Destroy;
  DoneCriticalSection(FErrLock);
end;

Procedure TStallServer.NoteError(Const aMsg : String);
begin
  EnterCriticalSection(FErrLock);
  try
    FLastError:=aMsg;
  finally
    LeaveCriticalSection(FErrLock);
  end;
  BumpCounter(FErrors);
end;

Function TStallServer.LastError : String;
begin
  EnterCriticalSection(FErrLock);
  try
    Result:=FLastError;
  finally
    LeaveCriticalSection(FErrLock);
  end;
end;

Procedure TStallServer.DoConnect(Sender : TObject; Data : TSocketStream);

  { Read the request headers. Bounded, and gives up if the peer stops
    talking, so shutting the test down cannot hang in here forever. }
  Function ReadHeaders(Out aHeaders : String) : Boolean;
  Var
    C : Char;
    Res : String;
    N : Integer;
    Idle : Integer;
  begin
    Res:='';
    Idle:=0;
    While (Pos(#13#10#13#10,Res)=0) and (Length(Res)<8192) and (not Terminated) do
      begin
      { Data.Read goes straight into a blocking recv, so ask first. Without
        this the loop could never observe Terminated or its own deadline,
        and a stuck setup would look like the shutdown hang under test. }
      if not Data.CanRead(PollMs*10) then
        begin
        Inc(Idle,PollMs*10);
        if Idle>WaitLimitMs then
          Break;
        Continue;
        end;
      N:=Data.Read(C,1);
      if N=1 then
        begin
        Res:=Res+C;
        Idle:=0;
        end
      else
        Break;   // peer closed or errored
      end;
    aHeaders:=Res;
    Result:=Pos(#13#10#13#10,Res)>0;
  end;

  Function ExtractKey(Const aHeaders : String; Out aKey : String) : Boolean;
  Var
    L : TStringList;
    I : Integer;
    N : String;
  begin
    aKey:='';
    L:=TStringList.Create;
    try
      L.Text:=aHeaders;
      For I:=0 to L.Count-1 do
        begin
        N:=L[I];
        if SameText(Copy(N,1,Length(SSecWebsocketKey)+1),SSecWebsocketKey+':') then
          begin
          aKey:=Trim(Copy(N,Length(SSecWebsocketKey)+2,Length(N)));
          Break;
          end;
        end;
    finally
      L.Free;
    end;
    Result:=aKey<>'';
  end;

  { Write everything or report failure - a short write would leave the
    client waiting for bytes we never sent, which would look like the
    stall we are trying to stage on purpose. }
  Function WriteAll(Const aBuf; aCount : Integer) : Boolean;
  Var
    Written, N : Integer;
    P : PByte;
  begin
    P:=@aBuf;
    Written:=0;
    While Written<aCount do
      begin
      N:=Data.Write(P[Written],aCount-Written);
      if N<=0 then
        Exit(False);
      Inc(Written,N);
      end;
    Result:=True;
  end;

Var
  Headers, Key, Resp : String;
  Half : Array[0..1] of Byte;
  Rest : Array[0..4] of Byte;
begin
  try
    try
      if not ReadHeaders(Headers) then
        begin
        NoteError('incomplete request headers');
        Exit;
        end;
      if not ExtractKey(Headers,Key) then
        begin
        NoteError('no '+SSecWebsocketKey+' header');
        Exit;
        end;

      Resp:='HTTP/1.1 101 Switching Protocols'#13#10
           +'Upgrade: websocket'#13#10
           +'Connection: Upgrade'#13#10
           +SSecWebsocketAccept+': '+CalcAccept(Key)+#13#10
           +#13#10;
      if not WriteAll(Resp[1],Length(Resp)) then
        begin
        NoteError('short write on handshake response');
        Exit;
        end;
      BumpCounter(FHandshakes);

      { Final text frame announcing five payload bytes - which never come. }
      Half[0]:=$81;
      Half[1]:=$05;
      if not WriteAll(Half[0],2) then
        begin
        NoteError('short write on partial frame');
        Exit;
        end;
      BumpCounter(FHalfSent);

      { Hold the connection open. The client is now stuck waiting for a
        payload; a shutdown, a close, or SendRest can free it. }
      While not Terminated do
        begin
        if InterLockedExchange(FSendRest,0)=1 then
          begin
          Rest[0]:=$68; Rest[1]:=$65; Rest[2]:=$6C;   { 'hel' }
          Rest[3]:=$6C; Rest[4]:=$6F;                 { 'lo'  }
          if not WriteAll(Rest[0],5) then
            NoteError('short write on the frame payload')
          else
            BumpCounter(FRestSent);
          end;
        Sleep(1);
        end;
    except
      On E : Exception do
        NoteError('connection: '+E.Message);
    end;
  finally
    Data.Free;
  end;
end;

Procedure TStallServer.SendRest;
begin
  InterLockedExchange(FSendRest,1);
end;

Procedure TStallServer.Execute;
begin
  try
    FListener.StartAccepting;
  except
    On E : Exception do
      if not Terminated then
        NoteError('accept: '+E.Message);
  end;
end;

{ ---------------------------------------------------------------------
  Is there a usable OpenSSL on this machine?
  --------------------------------------------------------------------- }

Var
  TLSChecked : Boolean = False;
  TLSAvailable : Boolean = False;
  TLSReason : String = '';

Function HaveTLS : Boolean;
Var
  H : TSSLSocketHandler;
begin
  if not TLSChecked then
    begin
    TLSChecked:=True;
    try
      H:=TSSLSocketHandler.GetDefaultHandler;
      try
        TLSAvailable:=Assigned(H);
        if not TLSAvailable then
          TLSReason:='no default SSL handler registered';
      finally
        H.Free;
      end;
    except
      On E : Exception do
        begin
        TLSAvailable:=False;
        TLSReason:=E.Message;
        end;
    end;
    end;
  Result:=TLSAvailable;
end;

{ ---------------------------------------------------------------------
  Scenario 1: upgrade handshake and echo
  --------------------------------------------------------------------- }

Procedure TestUpgradeAndEcho;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
begin
  BeginScenario('upgrade handshake and echo');
  Srv:=TEchoServer.Create(NextPort,smEcho,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.Client.Connect;
    Check('client is active after connect',Cli.Client.Active);
    Cli.Client.SendMessage('ping');
    Check('echo received',WaitForCount(Cli.FMessages,1));
    Check('echo content matches',Cli.LastMessage='ping','got "'+Cli.LastMessage+'"');
    Check('server saw the message',ReadCounter(Srv.FReceived)=1,
          'received='+IntToStr(ReadCounter(Srv.FReceived)));
    Check('no server errors',ReadCounter(Srv.FErrors)=0,Srv.LastError);
    Pump.Terminate;
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 2: repeated Execute/Terminate on a healthy connection
  --------------------------------------------------------------------- }

Procedure TestRepeatedExecuteTerminate;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
  I : Integer;
  Expect : String;
  Got : Boolean;
begin
  BeginScenario('repeated Execute/Terminate keeps the connection usable');
  Srv:=TEchoServer.Create(NextPort,smEcho,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.Client.Connect;

    For I:=1 to 5 do
      begin
      Pump.Terminate;
      Pump.Execute;
      Expect:='round'+IntToStr(I);
      Cli.Client.SendMessage(Expect);
      { Match on content: waiting for a count alone could be satisfied by
        a reply from an earlier round. }
      Got:=WaitForCount(Cli.FMessages,I,2000) and (Cli.LastMessage=Expect);
      Check('round '+IntToStr(I)+' echoed correctly',Got,
            'last="'+Cli.LastMessage+'" expected="'+Expect+'"');
      if not Got then
        Break;
      end;
    Check('client still active',Cli.Client.Active);
    Pump.Terminate;
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 3: peer close reaches the owner exactly once
  --------------------------------------------------------------------- }

Procedure TestPeerClose;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
begin
  BeginScenario('peer close notifies the owner and clears Active');
  Srv:=TEchoServer.Create(NextPort,smCloseAfterMessage,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.Client.Connect;
    Cli.Client.SendMessage('bye');

    Check('OnDisconnect fired',WaitForCount(Cli.FDisconnects,1));
    Check('client is no longer active',not Cli.Client.Active,
          'Active='+BoolToStr(Cli.Client.Active,True));
    { Give any duplicate notification time to show up before counting. }
    Sleep(300);
    Check('OnDisconnect fired exactly once',ReadCounter(Cli.FDisconnects)=1,
          'count='+IntToStr(ReadCounter(Cli.FDisconnects)));
    Pump.Terminate;
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 4: Terminate on an idle but healthy connection.

  The reader is in its bounded select here, not in a blocking payload
  read - that case is scenarios 7 and 8. What is asserted is the
  compatibility promise: stopping a healthy pump must be quick and must
  leave the connection usable.
  --------------------------------------------------------------------- }

Procedure TestTerminateWhileIdle;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
  Started, Elapsed : QWord;
begin
  BeginScenario('Terminate on an idle healthy connection');
  Srv:=TEchoServer.Create(NextPort,smEcho,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.Client.Connect;
    Sleep(300);   // let the reader settle into its polling loop

    { The client stays alive and registered across the Terminate. }
    Started:=GetTickCount64;
    Pump.Terminate;
    Elapsed:=GetTickCount64-Started;
    Check('Terminate returned promptly',Elapsed<WaitLimitMs,
          IntToStr(Int64(Elapsed))+' ms');
    Check('connection survived Terminate',Cli.Client.Active);

    Pump.Execute;
    Cli.Client.SendMessage('after');
    Check('echo works again after restart',
          WaitForCount(Cli.FMessages,1) and (Cli.LastMessage='after'),
          'last="'+Cli.LastMessage+'"');
    Pump.Terminate;
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 6: upgrade, echo and peer close over TLS
  --------------------------------------------------------------------- }

Procedure TestTLSEchoAndClose;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
begin
  if not HaveTLS then
    begin
    SkipScenario('TLS upgrade, echo and peer close','no usable OpenSSL: '+TLSReason);
    Exit;
    end;

  BeginScenario('TLS upgrade, echo and peer close');

  { First half: handshake and echo over TLS. }
  Srv:=TEchoServer.Create(NextPort,smEcho,True);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(250);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump,True);
    Cli.Client.Connect;
    Cli.Client.SendMessage('tls');
    Check('TLS echo received',WaitForCount(Cli.FMessages,1));
    Check('TLS echo content matches',Cli.LastMessage='tls','got "'+Cli.LastMessage+'"');
    Pump.Terminate;
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;

  { Second half: peer close over TLS must reach the owner just the same. }
  Srv:=TEchoServer.Create(NextPort,smCloseAfterMessage,True);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(250);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump,True);
    Cli.Client.Connect;
    Cli.Client.SendMessage('bye');
    Check('TLS peer close fires OnDisconnect',WaitForCount(Cli.FDisconnects,1));
    Check('TLS peer close clears Active',not Cli.Client.Active,
          'Active='+BoolToStr(Cli.Client.Active,True));
    Pump.Terminate;
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 7: partial frame over plain TCP.

  select() reports the socket readable, the reader consumes the two
  header bytes and then blocks in recv waiting for a payload that never
  arrives. This is the case InterruptRead exists for.
  --------------------------------------------------------------------- }

Procedure TestPartialFrameStall;
Var
  Srv : TStallServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
  Started, Elapsed : QWord;
  Port : Word;
  Waited : Integer;
begin
  BeginScenario('partial frame stall over plain TCP');
  Port:=NextPort;
  Srv:=TStallServer.Create(Port);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Sleep(200);
    Pump.Execute;
    Cli:=TTestClient.Create(Port,Pump,False,True);   // instrumented reads
    Cli.Client.Connect;

    Check('stall peer completed the handshake',
          WaitForCount(Srv.FHandshakes,1),Srv.LastError);
    Check('stall peer sent the partial frame',
          WaitForCount(Srv.FHalfSent,1),Srv.LastError);

    { Precondition: the reader must actually be inside a read that cannot
      complete. Without this the scenario could pass because the reader
      noticed Terminated first and stopped gracefully. }
    Waited:=0;
    While (not ReaderIsInsideRead) and (Waited<WaitLimitMs) do
      begin
      Sleep(PollMs);
      Inc(Waited,PollMs);
      end;
    Check('reader is parked inside a read',ReaderIsInsideRead,
          Format('entries=%d exits=%d',
                 [ReadCounter(ReadEntries),ReadCounter(ReadExits)]));

    Started:=GetTickCount64;
    Pump.Terminate;
    Elapsed:=GetTickCount64-Started;
    Say('      Terminate returned after '+IntToStr(Int64(Elapsed))+' ms');
    Check('Terminate returned on a stalled reader',Elapsed<WaitLimitMs,
          IntToStr(Int64(Elapsed))+' ms');

    { The point of the patch: once Terminate is done the reader is gone,
      so the connection can be destroyed without racing it. }
    FreeAndNil(Cli);
    Check('client destroyed after Terminate',True);
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    if Assigned(Srv) then
      begin
      Srv.Shutdown;
      FreeAndNil(Srv);
      end;
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 8: the same stall over TLS.

  Here the reader is blocked inside SSL_read, which is the situation the
  original report describes. The half frame is written through the
  server's transport, so it travels inside a complete TLS record: the TLS
  layer hands over two plaintext bytes and then has nothing more.
  --------------------------------------------------------------------- }

Procedure TestPartialFrameStallTLS;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
  Started, Elapsed : QWord;
  Waited : Integer;
begin
  if not HaveTLS then
    begin
    SkipScenario('partial frame stall over TLS','no usable OpenSSL: '+TLSReason);
    Exit;
    end;

  BeginScenario('partial frame stall over TLS');
  Srv:=TEchoServer.Create(NextPort,smStallAfterMessage,True);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(250);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump,True,True);   // instrumented reads
    Cli.Client.Connect;
    Cli.Client.SendMessage('stall');

    { FReceived is bumped before the write, so it proves nothing about the
      frame. FHalfSent is bumped after WriteBuffer returns. }
    Check('server wrote the partial frame',WaitForCount(Srv.FHalfSent,1),Srv.LastError);
    Check('no server errors so far',ReadCounter(Srv.FErrors)=0,Srv.LastError);

    { Same precondition as the plain scenario. The counters prove the frame
      reader is inside a transport read that cannot complete; for the TLS
      transport that read descends into SSL_read, but the instrumentation
      itself only establishes the outstanding transport read. }
    Waited:=0;
    While (not ReaderIsInsideRead) and (Waited<WaitLimitMs) do
      begin
      Sleep(PollMs);
      Inc(Waited,PollMs);
      end;
    Check('reader is inside a read on the TLS transport',ReaderIsInsideRead,
          Format('entries=%d exits=%d',
                 [ReadCounter(ReadEntries),ReadCounter(ReadExits)]));

    Started:=GetTickCount64;
    Pump.Terminate;
    Elapsed:=GetTickCount64-Started;
    Say('      Terminate returned after '+IntToStr(Int64(Elapsed))+' ms');
    Check('Terminate returned with the reader inside a TLS read',
          Elapsed<WaitLimitMs,IntToStr(Int64(Elapsed))+' ms');

    FreeAndNil(Cli);
    Check('client and TLS objects destroyed after Terminate',True);
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    { Let the parked server callback return before tearing the server down. }
    if Assigned(Srv) then
      Srv.Release;
    FreeAndNil(Srv);
  end;
  EndScenario;
end;


{ ---------------------------------------------------------------------
  Scenario 9: the disconnect callback stops the pump.

  ReadConnections invokes MessagePumpDisconnected, and thus the user's
  OnDisconnect, on the reader thread. If that handler calls Terminate,
  the patched implementation reaches FThread.WaitFor on the very thread
  it is waiting for. Reacting to a disconnect by stopping the pump is an
  ordinary thing for an application to do.
  --------------------------------------------------------------------- }

Procedure TestTerminateFromDisconnect;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
  Waited : Integer;
begin
  BeginScenario('Terminate called from the OnDisconnect callback');
  Srv:=TEchoServer.Create(NextPort,smCloseAfterMessage,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.TerminateOnDisconnect:=Pump;
    Cli.Client.Connect;
    Cli.Client.SendMessage('bye');

    Check('OnDisconnect fired',WaitForCount(Cli.FDisconnects,1));

    { Wait for either outcome, then report which one happened. }
    Waited:=0;
    While (ReadCounter(Cli.FTerminateReturned)=0)
      and (ReadCounter(Cli.FTerminateRaised)=0)
      and (Waited<10000) do
      begin
      Sleep(PollMs);
      Inc(Waited,PollMs);
      end;

    if ReadCounter(Cli.FTerminateEntered)=0 then
      begin
      { The callback never ran, so Terminate was never called from the
        reader thread. Saying anything about a self-join here would be
        reading a result out of an absent experiment. }
      Say('      the disconnect callback never ran - Terminate was not '
         +'called from the reader thread, so this defect is not exercised');
      Check('disconnect callback ran at all',False,
            'no OnDisconnect on this tree, scenario not exercised');
      end
    else
      begin
      if ReadCounter(Cli.FTerminateRaised)>0 then
        Say('      Terminate raised inside the callback: '+Cli.TerminateError)
      else if ReadCounter(Cli.FTerminateReturned)>0 then
        Say('      Terminate returned normally inside the callback')
      else
        Say('      Terminate was entered but neither returned nor raised - '
           +'the reader thread is waiting for itself');

      Check('Terminate from the disconnect callback returns normally',
            ReadCounter(Cli.FTerminateReturned)>0,
            'entered=1 raised='+IntToStr(ReadCounter(Cli.FTerminateRaised))
            +' error="'+Cli.TerminateError+'"');
      end;
  finally
    Cli.TerminateOnDisconnect:=Nil;
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 10: collateral damage of the forced interrupt.

  InterruptConnections shuts down every registered socket, not just the
  one that is stuck. A healthy client sharing the pump is shut down too.
  The patch's own comment promises that stopping a healthy pump does not
  disconnect its clients, so this checks whether the healthy client
  survives a Terminate that had to force its way out.
  --------------------------------------------------------------------- }

Procedure TestCollateralInterrupt;
Var
  EchoSrv : TEchoServer;
  StallSrv : TStallServer;
  Pump : TWSThreadMessagePump;
  Healthy, Stalled : TTestClient;
  StallPort : Word;
  SendErr : String;
  ActiveAfter, Usable : Boolean;
  DiscAfter : LongInt;
  Waited : Integer;
begin
  BeginScenario('healthy client sharing a pump with a stalled one');
  EchoSrv:=TEchoServer.Create(NextPort,smEcho,False);
  StallPort:=NextPort;
  StallSrv:=TStallServer.Create(StallPort);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Healthy:=Nil;
  Stalled:=Nil;
  try
    EchoSrv.Start;
    Sleep(200);
    Pump.Execute;

    Healthy:=TTestClient.Create(EchoSrv.Port,Pump);
    Healthy.Client.Connect;
    Healthy.Client.SendMessage('warmup');
    Check('healthy client works before the stall',
          WaitForCount(Healthy.FMessages,1) and (Healthy.LastMessage='warmup'));

    Stalled:=TTestClient.Create(StallPort,Pump,False,True);
    Stalled.Client.Connect;
    Check('stall peer sent its partial frame',WaitForCount(StallSrv.FHalfSent,1),
          StallSrv.LastError);
    Waited:=0;
    While (not ReaderIsInsideRead) and (Waited<WaitLimitMs) do
      begin
      Sleep(PollMs);
      Inc(Waited,PollMs);
      end;
    Check('reader is parked inside a read',ReaderIsInsideRead,
          Format('entries=%d exits=%d',
                 [ReadCounter(ReadEntries),ReadCounter(ReadExits)]));

    { This Terminate cannot finish gracefully, so it forces an interrupt
      across every registered socket - including the healthy one. }
    Pump.Terminate;

    { Snapshot before restarting the pump: once the reader runs again it can
      itself change Active and deliver notifications, which would blur what
      the forced interrupt did. }
    ActiveAfter:=Healthy.Client.Active;
    DiscAfter:=ReadCounter(Healthy.FDisconnects);
    Say(Format('      after Terminate: Active=%s, OnDisconnect count=%d',
               [BoolToStr(ActiveAfter,True),DiscAfter]));

    { The real question: is it still usable? A client that reports Active
      but whose socket was shut down underneath it will raise here rather
      than send, so the send has to be guarded to keep this a finding
      instead of a crash. }
    Pump.Execute;
    SendErr:='';
    try
      Healthy.Client.SendMessage('after');
    except
      On E : Exception do
        SendErr:=E.ClassName+': '+E.Message;
    end;
    Usable:=(SendErr='') and WaitForCount(Healthy.FMessages,2,3000)
            and (Healthy.LastMessage='after');
    if SendErr<>'' then
      Check('healthy client still usable after the forced interrupt',False,
            'send raised: '+SendErr)
    else
      Check('healthy client still usable after the forced interrupt',Usable,
            'last="'+Healthy.LastMessage+'"');

    { The state question, judged on the snapshot taken before the restart:
      if the connection was broken, the owner should have been told. }
    Check('client state and notification agree after the interrupt',
          Usable or (not ActiveAfter) or (DiscAfter>0),
          Format('unusable but Active=%s with %d disconnect(s) - the owner '
                +'was not told',[BoolToStr(ActiveAfter,True),DiscAfter]));
    Pump.Terminate;
  finally
    FreeAndNil(Healthy);
    FreeAndNil(Stalled);
    FreeAndNil(Pump);
    if Assigned(StallSrv) then
      begin
      StallSrv.Shutdown;
      FreeAndNil(StallSrv);
      end;
    FreeAndNil(EchoSrv);
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 5: pump destroyed before the client that points at it.

  TCustomWebsocketClient.Destroy calls Disconnect, which calls
  MessagePump.RemoveClient. SetMessagePump does register a
  FreeNotification, but the class has no Notification override that
  clears FMessagePump, so the pointer is never cleared.

  This crashes, so it is opt-in: --pump-first runs it alone.
  --------------------------------------------------------------------- }

Procedure TestPumpFreedBeforeClient;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
begin
  BeginScenario('pump freed before an active client');
  Srv:=TEchoServer.Create(NextPort,smEcho,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.Client.Connect;
    Check('client is active',Cli.Client.Active);
    Sleep(300);

    Say('      freeing the pump first (an access violation here is the finding)');
    FreeAndNil(Pump);
    FreeAndNil(Cli);
    Check('survived pump-before-client teardown',True);
  finally
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;


{ ---------------------------------------------------------------------
  Probe mode --interrupt-race: an interrupt landing on a read that is just
  completing.

  Not part of the numbered run, because it asks a question about a window
  rather than about the patch's normal behaviour.

  InterruptRead claims a transport that is inside a read and publishes the
  request afterwards; EndRead clears the state and reads the request
  afterwards. Between the claim and the publication there is a window in
  which EndRead sees no request and returns normally - while the socket is
  shut down a moment later. The window is a few instructions wide, so the
  submitted patch is not expected to show it. Running this mode against a
  copy of the patch with a deliberate delay inside InterruptRead answers
  what happens when it is hit.

  Terminate waits gracefully for 100 ms and only then starts interrupting,
  so the peer is armed to deliver the missing payload 120 ms after
  Terminate is entered - about 20 ms into the interrupt loop.
  --------------------------------------------------------------------- }

Type
  { The main thread is inside Terminate when the payload has to arrive, so
    the peer is released from a thread of its own. }
  TArmThread = Class(TThread)
  Private
    FServer : TStallServer;
    FDelayMs : Integer;
  Public
    Constructor Create(aServer : TStallServer; aDelayMs : Integer);
    Procedure Execute; override;
  end;

Constructor TArmThread.Create(aServer : TStallServer; aDelayMs : Integer);
begin
  FServer:=aServer;
  FDelayMs:=aDelayMs;
  FreeOnTerminate:=False;
  Inherited Create(False);
end;

Procedure TArmThread.Execute;
begin
  Sleep(FDelayMs);
  FServer.SendRest;
end;

Procedure TestInterruptOnCompletingRead;
Var
  Srv : TStallServer;
  Pump : TProbePump;
  Cli : TTestClient;
  Arm : TArmThread;
  Con : TWSClientConnection;
  Port : Word;
  Waited : Integer;
  Active, Tracked : Boolean;
  Disc : LongInt;
  SendErr : String;
  Started, Elapsed : QWord;
begin
  BeginScenario('interrupt landing on a read that is just completing');
  Port:=NextPort;
  Srv:=TStallServer.Create(Port);
  Pump:=TProbePump.Create(Nil);
  Cli:=Nil;
  Arm:=Nil;
  try
    Sleep(250);   { let the peer's listener come up before connecting }
    Pump.Execute;
    Cli:=TTestClient.Create(Port,Pump,False,True);
    Cli.Client.Connect;
    Check('the peer sent its partial frame',WaitForCount(Srv.FHalfSent,1),
          Srv.LastError);
    Waited:=0;
    While (not ReaderIsInsideRead) and (Waited<WaitLimitMs) do
      begin
      Sleep(PollMs);
      Inc(Waited,PollMs);
      end;
    Check('the reader is parked inside a read',ReaderIsInsideRead,
          Format('entries=%d exits=%d',
                 [ReadCounter(ReadEntries),ReadCounter(ReadExits)]));
    Con:=Cli.Client.Connection;

    Arm:=TArmThread.Create(Srv,120);
    Started:=TThread.GetTickCount64;
    Pump.Terminate;
    Elapsed:=TThread.GetTickCount64-Started;
    Arm.WaitFor;

    Active:=Cli.Client.Active;
    Tracked:=Pump.Tracks(Con);
    Disc:=ReadCounter(Cli.FDisconnects);
    Say(Format('      Terminate returned after %d ms; payload delivered=%d',
               [Elapsed,ReadCounter(Srv.FRestSent)]));
    Say(Format('      Active=%s, still tracked by the pump=%s, OnDisconnect=%d',
               [BoolToStr(Active,True),BoolToStr(Tracked,True),Disc]));

    { A socket that was shut down cannot be written to. This tells a
      connection that merely survived Terminate from one that was broken
      without anybody being told. }
    SendErr:='';
    try
      Cli.Client.SendMessage('after');
    except
      On E : Exception do
        SendErr:=E.ClassName+': '+E.Message;
    end;
    if SendErr='' then
      Say('      a send afterwards succeeded')
    else
      Say('      a send afterwards raised '+SendErr);

    Check('the connection is either intact or its owner was told',
          ((SendErr='') and Active) or (Disc>=1) or (not Active),
          'the socket is gone, the client still reports Active, and no '
          +'disconnect was reported');
    Check('a connection the pump still tracks has a usable socket',
          (not Tracked) or (SendErr=''),
          'it is still registered with a socket that has been shut down');
  finally
    if Assigned(Arm) then
      begin
      Arm.WaitFor;
      FreeAndNil(Arm);
      end;
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    if Assigned(Srv) then
      begin
      Srv.Shutdown;
      FreeAndNil(Srv);
      end;
  end;
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario table, child entry point and runner
  --------------------------------------------------------------------- }

Type
  TScenarioProc = Procedure;

{ ---------------------------------------------------------------------
  Scenario 10: a callback that waits for the main thread, while the main
  thread is inside Terminate.

  TThread.Synchronize parks the reader until someone runs CheckSynchronize
  on the main thread. Terminate polls on the main thread and does not, so
  the two wait for each other. Interrupting the socket cannot help here:
  the reader is not in a read.

  What differs between the versions is how they get out of it. A bounded
  wait gives up and abandons the thread - unsafe, but it returns. An
  unbounded one does not return at all.
  --------------------------------------------------------------------- }
Procedure TestSynchronizeDuringTerminate;
Var
  Srv : TEchoServer;
  Pump : TWSThreadMessagePump;
  Cli : TTestClient;
  Started, Elapsed : QWord;
  Reached : Boolean;
begin
  BeginScenario('Terminate while a callback waits in Synchronize');
  Srv:=TEchoServer.Create(NextPort,smEcho,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  Cli:=Nil;
  try
    Srv.Start;
    Sleep(150);
    Pump.Execute;
    Cli:=TTestClient.Create(Srv.Port,Pump);
    Cli.SyncOnMessage:=True;
    Cli.Client.Connect;
    Cli.Client.SendMessage('sync');

    Reached:=WaitForCount(Cli.FSyncEntered,1);
    Check('the callback reached Synchronize',Reached);
    if not Reached then
      Exit;

    { Nobody has serviced it, so it must still be waiting. Without this the
      scenario could pass with the reader long since finished. }
    Sleep(200);
    Check('the callback is still parked in Synchronize',
          ReadCounter(Cli.FSyncReturned)=0,
          'it returned on its own, so the main thread is not the only one '
          +'that can service it and this scenario proves nothing');

    Started:=TThread.GetTickCount64;
    Pump.Terminate;
    Elapsed:=TThread.GetTickCount64-Started;
    Say(Format('      Terminate returned after %d ms',[Elapsed]));
    Check('Terminate returns while a callback waits for the main thread',True);

    { Release the parked callback so that the teardown below is not itself
      the thing that hangs. }
    CheckSynchronize(0);
    Say('      after CheckSynchronize the callback had '
       +BoolToStr(ReadCounter(Cli.FSyncReturned)>0,'returned','not returned'));
  finally
    CheckSynchronize(0);
    FreeAndNil(Cli);
    FreeAndNil(Pump);
    FreeAndNil(Srv);
  end;
  EndScenario;
end;


{ ---------------------------------------------------------------------
  Scenario 11: a connection destroyed while the pump still has it queued.

  ReadConnections removes closed connections from both registries under the
  list lock, collects them in a local list, and calls Disconnect on each of
  them after unlocking. Between the first and the second of those calls the
  application's OnDisconnect callback runs - and tearing the remaining
  connections down from there is an ordinary thing for an application to do.

  Both peers close before the pump is started, so its very first pass finds
  both sockets ready and collects both in the same pass. The first callback
  then disconnects the second client, which frees its connection object,
  and the pump goes on to call Disconnect on that pointer.

  A control round runs the same arrangement without the teardown, so a
  finding below cannot be blamed on the setup.
  --------------------------------------------------------------------- }

Type
  TQueuedRound = Record
    DiscA, DiscB, Used : LongInt;
    Armed : Boolean;
  end;

Function RunQueuedRound(aTearDown : Boolean) : TQueuedRound;
Var
  SrvA, SrvB : TEchoServer;
  Pump : TWSThreadMessagePump;
  A, B : TTestClient;
  Before : LongInt;
begin
  Result.DiscA:=0;
  Result.DiscB:=0;
  Result.Used:=0;
  Result.Armed:=False;
  SrvA:=TEchoServer.Create(NextPort,smCloseAfterMessage,False);
  SrvB:=TEchoServer.Create(NextPort,smCloseAfterMessage,False);
  Pump:=TWSThreadMessagePump.Create(Nil);
  A:=Nil;
  B:=Nil;
  try
    SrvA.Start;
    SrvB.Start;
    Sleep(200);

    { The pump is deliberately left stopped. Both peers have to have closed
      before its first pass, otherwise the two connections are collected in
      two passes and the queue never holds more than one. }
    A:=TTestClient.Create(SrvA.Port,Pump,False,False,True);
    B:=TTestClient.Create(SrvB.Port,Pump,False,False,True);
    A.Client.Connect;
    B.Client.Connect;
    A.Client.SendMessage('bye');
    B.Client.SendMessage('bye');
    Sleep(500);

    { Both peers must have closed before the pump's first pass. Otherwise the
      two connections are collected one per pass, B is never queued while A's
      callback runs, and a clean result below would mean nothing was tried.
      CheckIncoming with DoRead=False answers "is there something waiting"
      without consuming it. }
    Result.Armed:=A.Client.Active and B.Client.Active
              and (A.Client.Connection.CheckIncoming(50,False)=irWaiting)
              and (B.Client.Connection.CheckIncoming(50,False)=irWaiting);

    if aTearDown then
      A.TearDownOnDisconnect:=B.Client;

    Before:=ReadCounter(UseAfterFree);
    Pump.Execute;
    WaitForCount(A.FDisconnects,1);
    Sleep(400);
    Pump.Terminate;

    Result.DiscA:=ReadCounter(A.FDisconnects);
    Result.DiscB:=ReadCounter(B.FDisconnects);
    Result.Used:=ReadCounter(UseAfterFree)-Before;
  finally
    FreeAndNil(A);
    FreeAndNil(B);
    FreeAndNil(Pump);
    FreeAndNil(SrvA);
    FreeAndNil(SrvB);
  end;
end;

Procedure TestFreeQueuedDisconnect;
Var
  Ctl, Prov : TQueuedRound;
begin
  BeginScenario('a queued connection destroyed by an earlier callback');

  Say('      control round: the callback does not tear anything down');
  Ctl:=RunQueuedRound(False);
  Say(Format('      control: OnDisconnect A=%d B=%d, calls after destruction=%d',
             [Ctl.DiscA,Ctl.DiscB,Ctl.Used]));
  Check('control: both peers had closed before the pump started',Ctl.Armed,
        'they were not both waiting, so they were not collected in one pass');
  Check('control: both peer closes are reported exactly once',
        (Ctl.DiscA=1) and (Ctl.DiscB=1),
        Format('A=%d B=%d',[Ctl.DiscA,Ctl.DiscB]));
  Check('control: nothing is used after destruction',Ctl.Used=0,
        Format('%d call(s)',[Ctl.Used]));

  Say('      provocation round: the first callback disconnects the second client');
  Prov:=RunQueuedRound(True);
  Say(Format('      provocation: OnDisconnect A=%d B=%d, calls after destruction=%d',
             [Prov.DiscA,Prov.DiscB,Prov.Used]));

  { Two ways this round can decide nothing: the two peers were not collected
    in the same pass, or the first callback never fired. Either has to be
    reported as such rather than as a clean result. }
  if not Prov.Armed then
    Check('the provocation actually ran',False,
          'the two peers had not both closed before the pump started, so '
          +'they were not collected in one pass and B was never queued')
  else if Prov.DiscA=0 then
    Check('the provocation actually ran',False,
          'the first callback never fired, so the second client was never '
          +'torn down and this round decides nothing')
  else
    Check('the pump does not touch a connection destroyed by a callback',
          Prov.Used=0,
          Format('%d call(s) reached a connection whose destructor had '
                +'completed; the probe keeps that memory alive on purpose, '
                +'an ordinary build hands it back to the heap manager',
                [Prov.Used]));
  EndScenario;
end;

{ ---------------------------------------------------------------------
  Scenario 12: an exception in a later client, and the notifications that
  were already pending.

  ReadConnections removes closed connections from both registries first and
  notifies their owners afterwards, in a second loop. Both loops sit inside
  one try..except. An ordinary exception from a *later* client - an
  application callback that fails - therefore jumps past the notification
  loop. The connections removed before it are then in neither registry and
  have not been told, so nothing will ever look at them again.

  Two clients: the first one's peer closes, the second one's callback
  raises. A control round with the same arrangement, minus the failing
  callback, shows what the pass does when nothing interferes.
  --------------------------------------------------------------------- }

Type
  TSkipRound = Record
    Errors, DiscA : LongInt;
    TrackedA, TrackedB, Armed : Boolean;
    Error : String;
  end;

Function RunSkipRound(aRaise : Boolean) : TSkipRound;
Var
  SrvA, SrvB : TEchoServer;
  Pump : TProbePump;
  Sink : TErrorSink;
  A, B : TTestClient;
  ConA, ConB : TWSClientConnection;
begin
  Result.Errors:=0;
  Result.DiscA:=0;
  Result.TrackedA:=False;
  Result.TrackedB:=False;
  Result.Armed:=False;
  Result.Error:='';
  SrvA:=TEchoServer.Create(NextPort,smCloseAfterMessage,False);
  SrvB:=TEchoServer.Create(NextPort,smEcho,False);
  Pump:=TProbePump.Create(Nil);
  Sink:=TErrorSink.Create;
  A:=Nil;
  B:=Nil;
  try
    Pump.OnError:=@Sink.DoError;
    SrvA.Start;
    SrvB.Start;
    Sleep(200);

    { Connect order is list order, so A is visited before B. }
    A:=TTestClient.Create(SrvA.Port,Pump);
    B:=TTestClient.Create(SrvB.Port,Pump);
    A.Client.Connect;
    B.Client.Connect;
    B.RaiseOnMessage:=aRaise;
    ConA:=A.Client.Connection;
    ConB:=B.Client.Connection;

    A.Client.SendMessage('bye');    { the peer closes }
    B.Client.SendMessage('echo');   { the peer answers, so a message waits }
    Sleep(500);

    { Both have to be waiting before the pump's first pass, otherwise A can be
      notified in one pass and B raise in another, and every assertion below
      would hold without the arrangement ever existing. }
    Result.Armed:=(Pump.ClientCount=2) and A.Client.Active and B.Client.Active
              and (ConA.CheckIncoming(50,False)=irWaiting)
              and (ConB.CheckIncoming(50,False)=irWaiting);

    Pump.Execute;
    { Several passes. A notification that were merely late would arrive here. }
    Sleep(1500);

    Result.Errors:=ReadCounter(Sink.FErrors);
    Result.Error:=Sink.LastError;
    Result.DiscA:=ReadCounter(A.FDisconnects);
    Result.TrackedA:=Pump.Tracks(ConA);
    Result.TrackedB:=Pump.Tracks(ConB);
    Pump.Terminate;
  finally
    FreeAndNil(A);
    FreeAndNil(B);
    FreeAndNil(Pump);
    FreeAndNil(Sink);
    FreeAndNil(SrvA);
    FreeAndNil(SrvB);
  end;
end;

Procedure TestExceptionSkipsNotification;
Var
  Ctl, Prov : TSkipRound;
begin
  BeginScenario('an exception in a later client and a pending notification');

  Say('      control round: no failing callback');
  Ctl:=RunSkipRound(False);
  Say(Format('      control: errors=%d, OnDisconnect A=%d, A tracked=%s',
             [Ctl.Errors,Ctl.DiscA,BoolToStr(Ctl.TrackedA,True)]));
  Check('control: the arrangement is what it claims to be',Ctl.Armed,
        'the pump did not have two live clients before the pass');
  Check('control: the closed connection is reported',Ctl.DiscA>=1,
        Format('OnDisconnect ran %d time(s)',[Ctl.DiscA]));
  Check('control: no error is reported',Ctl.Errors=0,Ctl.Error);

  Say('      provocation round: the second client''s callback raises');
  Prov:=RunSkipRound(True);
  Say(Format('      provocation: errors=%d, OnDisconnect A=%d, '
            +'A tracked=%s, B tracked=%s',
             [Prov.Errors,Prov.DiscA,BoolToStr(Prov.TrackedA,True),
              BoolToStr(Prov.TrackedB,True)]));

  Check('provocation: the arrangement is what it claims to be',Prov.Armed,
        'the two clients were not both waiting before the pass, so A and B '
        +'may well have been handled in different passes');
  Check('the failing callback is reported through OnError',
        (Prov.Errors>=1) and (Pos('deliberate failure',Prov.Error)>0),
        'the reported error was "'+Prov.Error+'", not the callback''s own');
  Check('the closed connection is still reported to its owner',Prov.DiscA>=1,
        Format('OnDisconnect ran %d time(s)',[Prov.DiscA]));
  Check('a connection the pump dropped was either reported or is still tracked',
        (Prov.DiscA>=1) or Prov.TrackedA,
        'it is in neither state: the owner was not told and no later pass '
        +'can find it again');
  EndScenario;
end;

Const
  ScenarioCount = 12;

Var
  ScenarioProcs : Array[1..ScenarioCount] of TScenarioProc;
  ScenarioNames : Array[1..ScenarioCount] of String;

Procedure BuildScenarioTable;
begin
  ScenarioProcs[1]:=@TestUpgradeAndEcho;
  ScenarioNames[1]:='upgrade handshake and echo';
  ScenarioProcs[2]:=@TestRepeatedExecuteTerminate;
  ScenarioNames[2]:='repeated Execute/Terminate';
  ScenarioProcs[3]:=@TestPeerClose;
  ScenarioNames[3]:='peer close';
  ScenarioProcs[4]:=@TestTerminateWhileIdle;
  ScenarioNames[4]:='Terminate while idle';
  ScenarioProcs[5]:=@TestTLSEchoAndClose;
  ScenarioNames[5]:='TLS echo and peer close';
  ScenarioProcs[6]:=@TestPartialFrameStall;
  ScenarioNames[6]:='partial frame stall, plain TCP';
  ScenarioProcs[7]:=@TestPartialFrameStallTLS;
  ScenarioNames[7]:='partial frame stall, TLS';
  ScenarioProcs[8]:=@TestTerminateFromDisconnect;
  ScenarioNames[8]:='Terminate from OnDisconnect';
  ScenarioProcs[9]:=@TestCollateralInterrupt;
  ScenarioNames[9]:='collateral interrupt of a healthy client';
  ScenarioProcs[10]:=@TestSynchronizeDuringTerminate;
  ScenarioNames[10]:='Terminate while a callback is in Synchronize';
  ScenarioProcs[11]:=@TestFreeQueuedDisconnect;
  ScenarioNames[11]:='queued connection destroyed by an earlier callback';
  ScenarioProcs[12]:=@TestExceptionSkipsNotification;
  ScenarioNames[12]:='exception in a later client skips a notification';
end;

{ Run one scenario in this process and exit with its verdict. }
Procedure RunAsChild(aIndex : Integer);
Var
  Dog : TWatchdog;
begin
  if (aIndex<1) or (aIndex>ScenarioCount) then
    begin
    Say('no such scenario: '+IntToStr(aIndex));
    Halt(97);
    end;
  Dog:=TWatchdog.Create(False);
  try
    ScenarioProcs[aIndex]();
  finally
    SetDeadline('',0);
    Dog.Terminate;
    Dog.WaitFor;
    Dog.Free;
  end;
  if ScenariosSkipped>0 then
    Halt(2)
  else if ScenariosFailed>0 then
    Halt(1)
  else
    Halt(0);
end;

Type
  TChildVerdict = (cvPassed, cvFailed, cvSkipped, cvHung, cvCrashed);

{ Start ourselves for one scenario and supervise it. The child inherits
  our console, so its output appears inline. }
Function RunChild(aIndex : Integer; Out aExit : Integer) : TChildVerdict;
Var
  P : TProcess;
  Waited : Integer;
  Raw : Integer;
begin
  aExit:=-1;
  Raw:=0;
  P:=TProcess.Create(Nil);
  try
    P.Executable:=ParamStr(0);
    P.Parameters.Add('--scenario');
    P.Parameters.Add(IntToStr(aIndex));
    P.Options:=[];          // no pipes: the child writes straight to our console
    P.ShowWindow:=swoShow;
    P.Execute;

    Waited:=0;
    While P.Running and (Waited<ChildLimitMs) do
      begin
      Sleep(50);
      Inc(Waited,50);
      end;

    if P.Running then
      begin
      P.Terminate(1);
      { Give it a moment to actually go away. }
      Waited:=0;
      While P.Running and (Waited<2000) do
        begin
        Sleep(50);
        Inc(Waited,50);
        end;
      Exit(cvHung);
      end;

    { On Unix ExitStatus is the raw wait() status and ExitCode decodes it -
      but ExitCode returns 0 for a child killed by a signal, which would
      otherwise be scored as a pass. Detect that case from the raw status. }
    Raw:=P.ExitStatus;
    aExit:=P.ExitCode;
    {$IFDEF UNIX}
    if (aExit=0) and (Raw<>0) then
      begin
      aExit:=Raw;
      Exit(cvCrashed);   // killed by a signal
      end;
    {$ENDIF}
    Case aExit of
      0 : Result:=cvPassed;
      1 : Result:=cvFailed;
      2 : Result:=cvSkipped;
      99: Result:=cvHung;
    else
      Result:=cvCrashed;
    end;
  finally
    P.Free;
  end;
end;

Var
  I, Ex, Bad : Integer;
  V : TChildVerdict;
  Passed, Failed, Skipped, Hung, Crashed : Integer;

begin
  {$IFDEF UNIX}
  { Writing to a socket whose peer has gone away raises SIGPIPE, which kills
    the process by default. Every scenario here deliberately shuts sockets
    down under a live peer, so ignore it and let write() report EPIPE. }
  fpSignal(SIGPIPE,SignalHandler(SIG_IGN));
  {$ENDIF}
  InitCriticalSection(OutLock);
  InitCriticalSection(StateLock);
  Randomize;
  PortBase:=24000+Random(1200)*10;
  BuildScenarioTable;

  { ---- child mode: one scenario, then exit ---- }
  if (ParamCount>=2) and (ParamStr(1)='--scenario') then
    begin
    if not SelfTestAccept then
      Halt(98);
    RunAsChild(StrToIntDef(ParamStr(2),0));
    end;

  { ---- the interrupt-window probe, run directly ---- }
  if (ParamCount>0) and (ParamStr(1)='--interrupt-race') then
    begin
    if not SelfTestAccept then
      Halt(98);
    TestInterruptOnCompletingRead;
    Halt(ScenariosFailed);
    end;

  { ---- the crashing opt-in scenario, run directly ---- }
  if (ParamCount>0) and (ParamStr(1)='--pump-first') then
    begin
    if not SelfTestAccept then
      Halt(98);
    TestPumpFreedBeforeClient;
    Halt(ScenariosFailed);
    end;

  { ---- runner ---- }
  Say('fpwebsocketclient shutdown regression test');
  Say(Format('FPC %s %s-%s',
             [{$I %FPCVERSION%},{$I %FPCTARGETCPU%},{$I %FPCTARGETOS%}]));
  Say(Format('each scenario runs in its own process, limit %d s',
             [ChildLimitMs div 1000]));
  Say('');

  if not SelfTestAccept then
    begin
    Say('RFC 6455 accept self-test failed - aborting.');
    Halt(98);
    end;

  Passed:=0; Failed:=0; Skipped:=0; Hung:=0; Crashed:=0;
  For I:=1 to ScenarioCount do
    begin
    Say(Format('===== scenario %d/%d: %s',[I,ScenarioCount,ScenarioNames[I]]));
    V:=RunChild(I,Ex);
    Case V of
      cvPassed  : Inc(Passed);
      cvFailed  : Inc(Failed);
      cvSkipped : Inc(Skipped);
      cvHung    :
        begin
        Inc(Hung);
        Say('    => HUNG: "'+ScenarioNames[I]+'" did not finish within '
           +IntToStr(ChildLimitMs div 1000)+' s and was killed');
        end;
      cvCrashed :
        begin
        Inc(Crashed);
        Say('    => CRASHED: "'+ScenarioNames[I]+'" exit code '+IntToStr(Ex));
        end;
    end;
    Say('');
    end;

  Say('=====================================================');
  Say(Format('passed %d   failed %d   skipped %d   hung %d   crashed %d',
             [Passed,Failed,Skipped,Hung,Crashed]));
  Bad:=Failed+Hung+Crashed;
  if Bad=0 then
    Say('all executed scenarios passed')
  else
    Say(Format('%d scenario(s) did not pass',[Bad]));
  DoneCriticalSection(StateLock);
  DoneCriticalSection(OutLock);
  Halt(Bad);
end.