fpc-msgbase/tests/adversarial/test_fuzz_jam.pas

{
  test_fuzz_jam.pas - corruption-resilience tests for the JAM
  driver.  The invariant we test is: no matter how a .JHR / .JDT /
  .JDX / .JLR is mangled, the library either refuses to open or
  returns a bounded, internally-consistent result.  No crashes, no
  OOM, no runaway loops.

  Test IDs:
    F-JAM-1  empty .JHR: Open succeeds with MessageCount = 0
    F-JAM-2  truncated .JHR (half a header)
    F-JAM-3  .JHR with garbage signature
    F-JAM-4  missing .JDX -> MessageCount = 0
    F-JAM-5  .JDX full of random garbage
    F-JAM-6  header claims SubfieldLen = 2 GB  -> bounded read
    F-JAM-7  header TxtOffset past .JDT -> empty body, no crash
    F-JAM-8  header TxtLen = MaxInt -> body capped
    F-JAM-9  .JLR with size not a multiple of 16 -> terminates
}

program test_fuzz_jam;

{$mode objfpc}{$H+}

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

const
  SCRATCH = '/tmp/mb_fuzz_jam';

procedure FreshDir;
begin
  if DirectoryExists(SCRATCH) then begin
    { Quick wipe - leave it to the OS to reclaim }
  end;
  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;

{ Build a minimal-valid 1024-byte JamHdrInfo with the 'JAM\0' sig. }
procedure WriteMinimalJhrInfo(const APath: string);
var
  fs: TFileStream;
  sig: array[1..4] of char;
  zeros: array[0..1019] of byte;
begin
  FillChar(zeros, SizeOf(zeros), 0);
  sig[1] := 'J'; sig[2] := 'A'; sig[3] := 'M'; sig[4] := #0;
  fs := TFileStream.Create(APath, fmCreate);
  try
    fs.Write(sig[1], 4);
    fs.Write(zeros, SizeOf(zeros));
  finally fs.Free; end;
end;

{ Try to open the base via the unified API.  Never crash; surface
  any exception as the test failure reason. }
function SafeOpen(out Base: TMessageBase; const ABasePath: string): boolean;
begin
  Result := False;
  Base := nil;
  try
    Base := MessageBaseOpen(mbfJam, 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 TestEmptyJhr;
var
  base: TMessageBase;
  basename: string;
begin
  TestBegin('F-JAM-1: empty .JHR opens with MessageCount = 0');
  FreshDir;
  basename := SCRATCH + '/empty';
  WriteBytes(basename + '.jhr', []);
  WriteBytes(basename + '.jdt', []);
  WriteBytes(basename + '.jdx', []);
  WriteBytes(basename + '.jlr', []);
  if not SafeOpen(base, basename) then begin
    TestOK;   { graceful refusal to open is also a valid outcome }
    exit;
  end;
  try
    AssertEquals('MessageCount', 0, base.MessageCount);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestTruncatedJhr;
var
  base: TMessageBase;
  basename: string;
  half: array[0..511] of byte;
begin
  TestBegin('F-JAM-2: half-header .JHR does not crash');
  FreshDir;
  basename := SCRATCH + '/trunc';
  FillChar(half, SizeOf(half), $AA);
  WriteBytes(basename + '.jhr', half);
  WriteBytes(basename + '.jdt', []);
  WriteBytes(basename + '.jdx', []);
  if not SafeOpen(base, basename) then begin
    TestOK;   { graceful refusal to open is also a valid outcome }
    exit;
  end;
  try
    AssertEquals('MessageCount', 0, base.MessageCount);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestGarbageSignature;
var
  base: TMessageBase;
  basename: string;
  junk: array[0..1023] of byte;
  i: integer;
begin
  TestBegin('F-JAM-3: garbage .JHR signature does not crash');
  FreshDir;
  basename := SCRATCH + '/garbsig';
  for i := 0 to High(junk) do junk[i] := byte(i mod 256);
  WriteBytes(basename + '.jhr', junk);
  WriteBytes(basename + '.jdt', []);
  WriteBytes(basename + '.jdx', []);
  if not SafeOpen(base, basename) then begin
    TestOK;   { graceful refusal to open is also a valid outcome }
    exit;
  end;
  try
    { Library may accept or reject; must not crash and MessageCount
      must be a sane bounded integer. }
    AssertTrue('MessageCount non-negative', base.MessageCount >= 0);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestMissingJdx;
var
  base: TMessageBase;
  basename: string;
begin
  TestBegin('F-JAM-4: missing .JDX handled gracefully');
  FreshDir;
  basename := SCRATCH + '/nojdx';
  WriteMinimalJhrInfo(basename + '.jhr');
  WriteBytes(basename + '.jdt', []);
  { deliberately no .jdx }
  if not SafeOpen(base, basename) then begin
    { Refusing to open is a perfectly graceful outcome. }
    TestOK;
    exit;
  end;
  try
    AssertEquals('MessageCount', 0, base.MessageCount);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestGarbageJdx;
var
  base: TMessageBase;
  basename: string;
  msg: TUniMessage;
  junk: array[0..255] of byte;
  i, n: integer;
begin
  TestBegin('F-JAM-5: garbage .JDX -> ReadMessage returns false, no crash');
  FreshDir;
  basename := SCRATCH + '/garbjdx';
  WriteMinimalJhrInfo(basename + '.jhr');
  WriteBytes(basename + '.jdt', []);
  for i := 0 to High(junk) do junk[i] := byte(($DE + i) and $FF);
  WriteBytes(basename + '.jdx', junk);
  if not SafeOpen(base, basename) then begin
    TestOK;   { graceful refusal to open is also a valid outcome }
    exit;
  end;
  try
    n := base.MessageCount;
    AssertTrue('MessageCount non-negative', n >= 0);
    AssertTrue('MessageCount bounded', n <= 32);
    for i := 0 to n - 1 do
      { Either returns False or returns True with zero-ish fields.
        We only care that it doesn't crash. }
      base.ReadMessage(i, msg);
  finally CloseAndFree(base); end;
  TestOK;
end;

{ Build an artificial JHR with one header claiming a huge SubfieldLen
  and TxtOffset/TxtLen way past the .JDT size, then a matching JDX
  pointing at it.  The hardened ReadMessage must return bounded
  content without allocating gigabytes or seeking off into nowhere. }
procedure TestHugeSubfieldLen;
var
  base: TMessageBase;
  basename: string;
  jhr: TFileStream;
  sig: array[1..4] of char;
  zeros: array[0..1019] of byte;
  hdr: array[0..79] of byte;
  idx: array[0..7] of byte;
  msg: TUniMessage;
  hdrOffset: longword;
  subfieldLen: longint;
  txtOffset, txtLen: longint;
begin
  TestBegin('F-JAM-6: huge SubfieldLen / TxtLen yield bounded read');
  FreshDir;
  basename := SCRATCH + '/huge';

  { ---- .JHR: HdrInfo (1024) + one JamHdr (80) ---- }
  sig[1] := 'J'; sig[2] := 'A'; sig[3] := 'M'; sig[4] := #0;
  FillChar(zeros, SizeOf(zeros), 0);
  jhr := TFileStream.Create(basename + '.jhr', fmCreate);
  try
    jhr.Write(sig[1], 4);
    jhr.Write(zeros, SizeOf(zeros));
    hdrOffset := jhr.Position;   { where JamHdr #0 starts }
    FillChar(hdr, SizeOf(hdr), 0);
    hdr[0] := Ord('J'); hdr[1] := Ord('A'); hdr[2] := Ord('M'); hdr[3] := 0;
    { SubfieldLen field starts at offset 8 (4 sig + 2*word). }
    subfieldLen := $7FFFFFFF;
    Move(subfieldLen, hdr[8], 4);
    { TxtOffset at offset 68 (8 + 14*4), TxtLen at offset 72. }
    txtOffset := 100000;
    txtLen    := $7FFFFFFF;
    Move(txtOffset, hdr[68], 4);
    Move(txtLen,    hdr[72], 4);
    jhr.Write(hdr, SizeOf(hdr));
  finally jhr.Free; end;

  { ---- .JDT: 8 bytes of junk (way less than TxtOffset) ---- }
  WriteBytes(basename + '.jdt', [$00, $01, $02, $03, $04, $05, $06, $07]);

  { ---- .JDX: one record UserCRC=$FFFFFFFF, HdrOffset=hdrOffset ---- }
  FillChar(idx, SizeOf(idx), $FF);
  Move(hdrOffset, idx[4], 4);
  WriteBytes(basename + '.jdx', idx);

  if not SafeOpen(base, basename) then begin
    TestOK;   { graceful refusal to open is also a valid outcome }
    exit;
  end;
  try
    AssertEquals('MessageCount', 1, base.MessageCount);
    { Must not raise or hang.  Body may be empty or a small clamp. }
    base.ReadMessage(0, msg);
    AssertTrue('body bounded',
               Length(msg.Body) <= 128 * 1024 * 1024);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestOddJlrSize;
var
  base: TMessageBase;
  basename: string;
  junk: array[0..30] of byte;   { 31 bytes — not a multiple of 16 }
  i: integer;
begin
  TestBegin('F-JAM-9: odd-sized .JLR does not hang GetLastRead');
  FreshDir;
  basename := SCRATCH + '/oddjlr';
  WriteMinimalJhrInfo(basename + '.jhr');
  WriteBytes(basename + '.jdt', []);
  WriteBytes(basename + '.jdx', []);
  for i := 0 to High(junk) do junk[i] := byte($5A xor i);
  WriteBytes(basename + '.jlr', junk);
  if not SafeOpen(base, basename) then begin
    TestOK;   { graceful refusal to open is also a valid outcome }
    exit;
  end;
  try
    { Just making sure Open + MessageCount doesn't trip over .JLR. }
    AssertEquals('MessageCount', 0, base.MessageCount);
  finally CloseAndFree(base); end;
  TestOK;
end;

begin
  WriteLn('fpc-msgbase: JAM corruption-resilience fuzz');
  WriteLn;

  TestEmptyJhr;
  TestTruncatedJhr;
  TestGarbageSignature;
  TestMissingJdx;
  TestGarbageJdx;
  TestHugeSubfieldLen;
  TestOddJlrSize;

  Halt(TestsSummary);
end.