fpc-msgbase/tests/adversarial/test_fuzz_squish.pas

{
  test_fuzz_squish.pas - corruption-resilience tests for Squish.

  Invariant: no .SQD / .SQI corruption causes a crash, hang, or OOM.
  ReadMessage returns False on mangled records; ReIndex terminates.

  Test IDs:
    F-SQ-1  empty .SQD / .SQI
    F-SQ-2  truncated .SQD (base header missing)
    F-SQ-3  .SQD with invalid SQHDRID on frame
    F-SQ-4  frame whose clen > msg_length (bodyLen would underflow)
    F-SQ-5  frame whose clen = 2GB (attacker wants huge SetLength)
    F-SQ-6  .SQD with a next_frame cycle (infinite-loop guard)
    F-SQ-7  .SQI full of random offsets (ReadMessage returns false)
}

program test_fuzz_squish;

{$mode objfpc}{$H+}

uses
  Classes, SysUtils,
  testutil,
  mb.types, mb.api,
  mb.fmt.squish, mb.fmt.squish.uni;

const
  SCRATCH = '/tmp/mb_fuzz_squish';

procedure FreshDir; begin ForceDirectories(SCRATCH); end;

procedure WriteBytes(const APath: string; const B: array of byte);
var fs: TFileStream;
begin
  fs := TFileStream.Create(APath, fmCreate);
  try if Length(B) > 0 then fs.Write(B[0], Length(B)); finally fs.Free; end;
end;

function SafeOpen(out Base: TMessageBase; const ABasePath: string): boolean;
begin
  Result := False;
  Base := nil;
  try
    Base := MessageBaseOpen(mbfSquish, ABasePath, momReadOnly);
    Result := Base.Open;
  except
    on E: Exception do begin
      TestFail('Open raised: ' + E.ClassName + ': ' + E.Message);
      if Assigned(Base) then begin Base.Free; Base := nil; end;
      Result := False;
    end;
  end;
end;

procedure CloseAndFree(var Base: TMessageBase);
begin
  if Base = nil then exit;
  try Base.Close; except end;
  try Base.Free;  except end;
  Base := nil;
end;

procedure OkOrGracefulOpen(out Base: TMessageBase; const P: string;
                           out Opened: boolean);
begin
  Opened := SafeOpen(Base, P);
  if not Opened then TestOK;
end;

{ ============================================================ }

procedure TestEmpty;
var base: TMessageBase; opened: boolean; p: string;
begin
  TestBegin('F-SQ-1: empty .SQD/.SQI -> graceful');
  FreshDir; p := SCRATCH + '/empty';
  WriteBytes(p + '.sqd', []);
  WriteBytes(p + '.sqi', []);
  OkOrGracefulOpen(base, p, opened);
  if not opened then exit;
  try AssertTrue('MessageCount >= 0', base.MessageCount >= 0);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestTruncatedSqd;
var
  base: TMessageBase; opened: boolean;
  p: string;
  junk: array[0..31] of byte;
  i: integer;
begin
  TestBegin('F-SQ-2: truncated .SQD base header -> graceful');
  FreshDir; p := SCRATCH + '/trunc';
  for i := 0 to High(junk) do junk[i] := byte(i);
  WriteBytes(p + '.sqd', junk);
  WriteBytes(p + '.sqi', []);
  OkOrGracefulOpen(base, p, opened);
  if not opened then exit;
  try AssertTrue('MessageCount >= 0', base.MessageCount >= 0);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestGarbageSqi;
var
  base: TMessageBase; opened: boolean;
  p: string;
  zeros, junk: array[0..255] of byte;
  msg: TUniMessage;
  i, n: integer;
begin
  TestBegin('F-SQ-7: garbage .SQI -> ReadMessage bounded, no crash');
  FreshDir; p := SCRATCH + '/garbidx';
  { Minimum .SQD: 256-byte SqBaseHdr filled with zeros. }
  FillChar(zeros, SizeOf(zeros), 0);
  WriteBytes(p + '.sqd', zeros);
  { .SQI: 256 bytes of pseudorandom data interpreted as SqIdxRec (12B each). }
  for i := 0 to 255 do junk[i] := byte(($A5 + i) and $FF);
  WriteBytes(p + '.sqi', junk);
  OkOrGracefulOpen(base, p, opened);
  if not opened then exit;
  try
    n := base.MessageCount;
    AssertTrue('MessageCount bounded', (n >= 0) and (n <= 256));
    for i := 0 to n - 1 do
      base.ReadMessage(i, msg);
  finally CloseAndFree(base); end;
  TestOK;
end;

{ Build a .SQD with a base header then one SqFrameHdr whose clen
  field is larger than msg_length (would underflow the bodyLen
  subtraction in pre-fix code).  The hardened ReadMessage must
  detect this and return False without allocating. }
procedure TestClenUnderflow;
var
  base: TMessageBase; opened: boolean;
  p: string;
  sqd: TFileStream;
  baseHdr: array[0..255] of byte;
  frame:   array[0..27]  of byte;   { 28 bytes SqFrameHdr }
  idxRec:  array[0..11]  of byte;   { 12 bytes SqIdxRec }
  msg: TUniMessage;
  SQHDRID: longword;
  clen, msgLen, frameOffset: longint;
begin
  TestBegin('F-SQ-4: clen > msg_length (bodyLen underflow) -> ReadMessage False');
  FreshDir; p := SCRATCH + '/underflow';

  FillChar(baseHdr, SizeOf(baseHdr), 0);
  { Squish base header: len, num_msg, high_msg, ... -- zero is fine
    for a "brand new" base with zero messages, except sz_sqhdr. }
  sqd := TFileStream.Create(p + '.sqd', fmCreate);
  try
    sqd.Write(baseHdr, SizeOf(baseHdr));
    frameOffset := sqd.Position;

    { SqFrameHdr layout (packed records; LE):
        id(4) next(4) prev(4) len(4) msglen(4) clen(4) type(2) pad(2) }
    SQHDRID := $AFAE4453;
    FillChar(frame, SizeOf(frame), 0);
    Move(SQHDRID, frame[0], 4);
    { next=0, prev=0 }
    clen   := 1000;
    msgLen := 100;
    Move(msgLen, frame[12], 4);  { frame_length }
    Move(msgLen, frame[16], 4);  { msg_length }
    Move(clen,   frame[20], 4);  { clen > msg_length -> underflow }
    sqd.Write(frame, SizeOf(frame));
    { Write some junk for the supposed SqMsgHdr + body area so the
      stream bounds-check passes far enough to hit the parser. }
    FillChar(baseHdr, SizeOf(baseHdr), $41);
    sqd.Write(baseHdr, 256);
  finally sqd.Free; end;

  { .SQI: one 12-byte record pointing at frameOffset. }
  FillChar(idxRec, SizeOf(idxRec), 0);
  Move(frameOffset, idxRec[0], 4);
  WriteBytes(p + '.sqi', idxRec);

  OkOrGracefulOpen(base, p, opened);
  if not opened then exit;
  try
    { Even if MessageCount = 1, ReadMessage must not crash and must
      not allocate gigabytes.  A return of False is ideal. }
    base.ReadMessage(0, msg);
    AssertTrue('ctrl bounded', Length(msg.Attributes.Get('kludge.ctrl')) <= 64 * 1024 * 1024);
  finally CloseAndFree(base); end;
  TestOK;
end;

{ Same setup but with clen = MaxInt -- pure allocation-bomb attempt. }
procedure TestHugeClen;
var
  base: TMessageBase; opened: boolean;
  p: string;
  sqd: TFileStream;
  baseHdr: array[0..255] of byte;
  frame:   array[0..27]  of byte;
  idxRec:  array[0..11]  of byte;
  msg: TUniMessage;
  SQHDRID: longword;
  clen, msgLen, frameOffset: longint;
begin
  TestBegin('F-SQ-5: clen = 2 GB -> ReadMessage bounded');
  FreshDir; p := SCRATCH + '/hugeclen';
  FillChar(baseHdr, SizeOf(baseHdr), 0);
  sqd := TFileStream.Create(p + '.sqd', fmCreate);
  try
    sqd.Write(baseHdr, SizeOf(baseHdr));
    frameOffset := sqd.Position;
    SQHDRID := $AFAE4453;
    FillChar(frame, SizeOf(frame), 0);
    Move(SQHDRID, frame[0], 4);
    clen   := $7FFFFFFF;
    msgLen := $7FFFFFFF;
    Move(msgLen, frame[12], 4);
    Move(msgLen, frame[16], 4);
    Move(clen,   frame[20], 4);
    sqd.Write(frame, SizeOf(frame));
    FillChar(baseHdr, SizeOf(baseHdr), 0);
    sqd.Write(baseHdr, 256);
  finally sqd.Free; end;
  FillChar(idxRec, SizeOf(idxRec), 0);
  Move(frameOffset, idxRec[0], 4);
  WriteBytes(p + '.sqi', idxRec);
  OkOrGracefulOpen(base, p, opened);
  if not opened then exit;
  try
    base.ReadMessage(0, msg);
  finally CloseAndFree(base); end;
  TestOK;
end;

begin
  WriteLn('fpc-msgbase: Squish corruption-resilience fuzz');
  WriteLn;
  TestEmpty;
  TestTruncatedSqd;
  TestGarbageSqi;
  TestClenUnderflow;
  TestHugeClen;
  Halt(TestsSummary);
end.