{
  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.

  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 normal nine-scenario run and is expected to fail or crash.

  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;


{ ---------------------------------------------------------------------
  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;
    Procedure DoMessage(Sender : TObject; Const aMessage : TWSMessage);
    Procedure DoDisconnect(Sender : TObject);
  Public
    Constructor Create(aPort : Word; aPump : TWSMessagePump; aUseSSL : Boolean = False;
                       aInstrument : 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;
    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);
begin
  InitCriticalSection(FLastLock);
  InitCriticalSection(FTermLock);
  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.DoMessage(Sender : TObject; Const aMessage : TWSMessage);
begin
  EnterCriticalSection(FLastLock);
  try
    FLast:=aMessage.AsString;
  finally
    LeaveCriticalSection(FLastLock);
  end;
  BumpCounter(FMessages);
end;

Procedure TTestClient.DoDisconnect(Sender : TObject);
begin
  BumpCounter(FDisconnects);
  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;
    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;
    Function LastError : String;
    Property Handshakes : LongInt Read FHandshakes;
    Property HalfSent : LongInt Read FHalfSent;
    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;
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; only a shutdown or close can free it. }
      While not Terminated do
        Sleep(50);
    except
      On E : Exception do
        NoteError('connection: '+E.Message);
    end;
  finally
    Data.Free;
  end;
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;

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

Type
  TScenarioProc = Procedure;

Const
  ScenarioCount = 9;

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';
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 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.