fpc-msgbase/tests/adversarial/test_fuzz_msg.pas

{
  test_fuzz_msg.pas - corruption-resilience for the *.MSG dir driver.

  Invariant: a directory full of weird *.MSG files does not crash,
  hang, or OOM the reader.  Body reads stay bounded.

  Test IDs:
    F-MSG-1  empty dir -> MessageCount = 0
    F-MSG-2  zero-byte 1.MSG -> ReadMessage either False or empty body
    F-MSG-3  1.MSG with no NUL terminator at all (large) -> body capped
    F-MSG-4  1.MSG with header but truncated body
    F-MSG-5  a.MSG / ../evil.MSG filenames ignored by Scan
}

program test_fuzz_msg;

{$mode objfpc}{$H+}

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

const
  SCRATCH = '/tmp/mb_fuzz_msg';
  MSG_HDR_SIZE = 190;   { NetMail record size }

procedure FreshDir;
var
  sr: TSearchRec;
begin
  ForceDirectories(SCRATCH);
  if FindFirst(SCRATCH + '/*', faAnyFile, sr) = 0 then begin
    repeat
      if (sr.Name <> '.') and (sr.Name <> '..') and
         ((sr.Attr and faDirectory) = 0) then
        DeleteFile(SCRATCH + '/' + sr.Name);
    until FindNext(sr) <> 0;
    FindClose(sr);
  end;
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 ADir: string): boolean;
begin
  Result := False; Base := nil;
  try
    Base := MessageBaseOpen(mbfMsg, ADir, 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;
    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 TestEmptyDir;
var base: TMessageBase;
begin
  TestBegin('F-MSG-1: empty dir -> MessageCount = 0');
  FreshDir;
  if not SafeOpen(base, SCRATCH) then begin TestOK; exit; end;
  try AssertEquals('MessageCount', 0, base.MessageCount);
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestZeroByteMsg;
var
  base: TMessageBase;
  msg: TUniMessage;
begin
  TestBegin('F-MSG-2: zero-byte 1.MSG -> ReadMessage handled, no crash');
  FreshDir;
  WriteBytes(SCRATCH + '/1.MSG', []);
  if not SafeOpen(base, SCRATCH) then begin TestOK; exit; end;
  try
    if base.MessageCount > 0 then
      base.ReadMessage(0, msg);  { may return false; must not crash }
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestHugeBodyNoNul;
const
  BIG = 50 * 1024 * 1024;   { 50 MB of non-NUL body }
var
  fs: TFileStream;
  hdr: array[0..MSG_HDR_SIZE - 1] of byte;
  base: TMessageBase;
  msg: TUniMessage;
  buf: array[0..4095] of byte;
  body: string;
  written: longint;
begin
  TestBegin('F-MSG-3: 50MB .MSG with no NUL -> body capped at 16 MiB');
  FreshDir;
  FillChar(hdr, SizeOf(hdr), 0);
  FillChar(buf, SizeOf(buf), byte('X'));
  fs := TFileStream.Create(SCRATCH + '/1.MSG', fmCreate);
  try
    fs.Write(hdr, SizeOf(hdr));
    written := 0;
    while written < BIG do begin
      fs.Write(buf, SizeOf(buf));
      Inc(written, SizeOf(buf));
    end;
    { deliberately no trailing NUL }
  finally fs.Free; end;
  if not SafeOpen(base, SCRATCH) then begin TestOK; exit; end;
  try
    AssertTrue('MessageCount > 0', base.MessageCount > 0);
    if base.ReadMessage(0, msg) then begin
      body := msg.Body;
      AssertTrue('body capped at 16 MiB',
                 Length(body) <= 16 * 1024 * 1024);
    end;
  finally CloseAndFree(base); end;
  TestOK;
end;

procedure TestStrangeNames;
var
  base: TMessageBase;
begin
  TestBegin('F-MSG-5: non-numeric .MSG names ignored by Scan');
  FreshDir;
  WriteBytes(SCRATCH + '/a.MSG',     []);
  WriteBytes(SCRATCH + '/evil.MSG',  []);
  WriteBytes(SCRATCH + '/1.MSG',     []);
  WriteBytes(SCRATCH + '/-5.MSG',    []);   { negative -- Val rejects }
  if not SafeOpen(base, SCRATCH) then begin TestOK; exit; end;
  try
    AssertTrue('MessageCount bounded', (base.MessageCount >= 0) and
                                        (base.MessageCount <= 10));
  finally CloseAndFree(base); end;
  TestOK;
end;

begin
  WriteLn('fpc-msgbase: *.MSG corruption-resilience fuzz');
  WriteLn;
  TestEmptyDir;
  TestZeroByteMsg;
  TestStrangeNames;
  TestHugeBodyNoNul;
  Halt(TestsSummary);
end.