fpc-msgbase/tests/test_hwm.pas

{
  test_hwm.pas - High-Water Mark API tests.

  Verifies the per-user HWM mechanism each backend exposes (or
  doesn't):
  - JAM: native via .JLR file, CRC32-keyed by lowercased username.
  - Squish, Hudson, GoldBase, EzyCom, Wildcat: TBD in 0.3.1 / 0.3.2
  - PCBoard, MSG, PKT: SupportsHWM = false; GetHWM always returns -1.

  Also exercises the auto-bump behaviour through ActiveUser: when
  set, ReadMessage moves the HWM forward as new messages are
  scanned, but never backwards.

  Each backend's regression here doubles as the contract test
  callers (NetReader, Allfix, Fimail) can read to know what to
  expect.
}

program test_hwm;

{$mode objfpc}{$H+}
{$modeswitch advancedrecords}

uses
  SysUtils,
  testutil,
  mb.types, mb.events, mb.api,
  mb.fmt.hudson,   mb.fmt.hudson.uni,
  mb.fmt.jam,      mb.fmt.jam.uni,
  mb.fmt.squish,   mb.fmt.squish.uni,
  mb.fmt.msg,      mb.fmt.msg.uni,
  mb.fmt.pcboard,  mb.fmt.pcboard.uni,
  mb.fmt.ezycom,   mb.fmt.ezycom.uni,
  mb.fmt.goldbase, mb.fmt.goldbase.uni;

const
  SCRATCH_ROOT = '/tmp/ma_hwm';

procedure CleanDir(const APath: string);
var
  sr: TSearchRec;
begin
  if not DirectoryExists(APath) then exit;
  if FindFirst(APath + '/*', faAnyFile, sr) = 0 then
  try
    repeat
      if (sr.Attr and faDirectory) = 0 then
        DeleteFile(APath + '/' + sr.Name);
    until FindNext(sr) <> 0;
  finally
    FindClose(sr);
  end;
end;

procedure SeedJam(const APath: string; N: longint);
var
  base: TMessageBase;
  msg: TUniMessage;
  i: longint;
begin
  base := MessageBaseOpen(mbfJam, APath, momCreate);
  try
    base.Open;
    for i := 1 to N do begin
      msg.Attributes.Clear;
      msg.Attributes.SetValue('from',    'Sender' + IntToStr(i));
      msg.Attributes.SetValue('to',      'Dest');
      msg.Attributes.SetValue('subject', 'Msg ' + IntToStr(i));
      msg.Attributes.SetDate('date.written', Now);
      msg.Body := 'Body ' + IntToStr(i);
      base.WriteMessage(msg);
    end;
  finally
    base.Close;
    base.Free;
  end;
end;

procedure TestJamCapability;
var
  base: TMessageBase;
begin
  TestBegin('JAM: SupportsHWM = true');
  ForceDirectories(SCRATCH_ROOT + '/jam_cap');
  CleanDir(SCRATCH_ROOT + '/jam_cap');
  base := MessageBaseOpen(mbfJam, SCRATCH_ROOT + '/jam_cap/echo', momCreate);
  try
    AssertTrue('Open', base.Open);
    AssertTrue('SupportsHWM', base.SupportsHWM);
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestJamSetGet;
var
  base: TMessageBase;
begin
  TestBegin('JAM: SetHWM / GetHWM round-trip');
  ForceDirectories(SCRATCH_ROOT + '/jam_setget');
  CleanDir(SCRATCH_ROOT + '/jam_setget');
  SeedJam(SCRATCH_ROOT + '/jam_setget/echo', 10);

  base := MessageBaseOpen(mbfJam, SCRATCH_ROOT + '/jam_setget/echo',
                          momReadWrite);
  try
    AssertTrue('Open RW', base.Open);
    AssertEquals('Initial HWM (no record yet)', -1, base.GetHWM('NetReader'));

    base.SetHWM('NetReader', 5);
    AssertEquals('After SetHWM(5)', 5, base.GetHWM('NetReader'));

    base.SetHWM('NetReader', 7);
    AssertEquals('After SetHWM(7)', 7, base.GetHWM('NetReader'));

    { Different user gets its own slot. }
    AssertEquals('Allfix HWM independent', -1, base.GetHWM('Allfix'));
    base.SetHWM('Allfix', 3);
    AssertEquals('Allfix HWM = 3', 3, base.GetHWM('Allfix'));
    AssertEquals('NetReader HWM still 7', 7, base.GetHWM('NetReader'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestJamPersistence;
var
  base: TMessageBase;
begin
  TestBegin('JAM: HWM persists across Open/Close');
  ForceDirectories(SCRATCH_ROOT + '/jam_persist');
  CleanDir(SCRATCH_ROOT + '/jam_persist');
  SeedJam(SCRATCH_ROOT + '/jam_persist/echo', 5);

  { Write HWM in first session. }
  base := MessageBaseOpen(mbfJam, SCRATCH_ROOT + '/jam_persist/echo',
                          momReadWrite);
  try
    AssertTrue('Open RW (write)', base.Open);
    base.SetHWM('NetReader', 3);
  finally
    base.Close;
    base.Free;
  end;

  { Read HWM in second session. }
  base := MessageBaseOpen(mbfJam, SCRATCH_ROOT + '/jam_persist/echo',
                          momReadOnly);
  try
    AssertTrue('Open RO (read)', base.Open);
    AssertEquals('HWM persisted', 3, base.GetHWM('NetReader'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestJamAutoBump;
var
  base: TMessageBase;
  msg: TUniMessage;
  i, hwm, lastNum: longint;
begin
  TestBegin('JAM: ActiveUser auto-bumps HWM during ReadMessage');
  ForceDirectories(SCRATCH_ROOT + '/jam_auto');
  CleanDir(SCRATCH_ROOT + '/jam_auto');
  SeedJam(SCRATCH_ROOT + '/jam_auto/echo', 5);

  base := MessageBaseOpen(mbfJam, SCRATCH_ROOT + '/jam_auto/echo',
                          momReadWrite);
  try
    AssertTrue('Open RW', base.Open);

    { Read the last message first to capture what msg.num it has,
      so the assertion is independent of JAM's BaseMsgNum default. }
    base.ReadMessage(base.MessageCount - 1, msg);
    lastNum := msg.Attributes.GetInt('msg.num', -1);
    AssertTrue('Last message has a msg.num', lastNum >= 0);

    { Now enable auto-bump and walk the whole base. }
    base.ActiveUser := 'NetReader';
    for i := 0 to base.MessageCount - 1 do
      base.ReadMessage(i, msg);

    hwm := base.GetHWM('NetReader');
    AssertEquals('HWM matches last message msg.num', lastNum, hwm);
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestJamAutoBumpNoDecrement;
var
  base: TMessageBase;
  msg: TUniMessage;
  hwm0, hwm1: longint;
begin
  TestBegin('JAM: auto-bump never decrements HWM');
  ForceDirectories(SCRATCH_ROOT + '/jam_nodec');
  CleanDir(SCRATCH_ROOT + '/jam_nodec');
  SeedJam(SCRATCH_ROOT + '/jam_nodec/echo', 5);

  base := MessageBaseOpen(mbfJam, SCRATCH_ROOT + '/jam_nodec/echo',
                          momReadWrite);
  try
    AssertTrue('Open RW', base.Open);
    base.SetHWM('NetReader', 4);
    base.ActiveUser := 'NetReader';

    { Read message 0 (low msg.num) -- HWM must NOT drop to 1. }
    base.ReadMessage(0, msg);
    hwm0 := base.GetHWM('NetReader');
    AssertEquals('HWM unchanged after reading low message',
                 4, hwm0);

    { Read message 4 (high msg.num) -- HWM may advance. }
    base.ReadMessage(4, msg);
    hwm1 := base.GetHWM('NetReader');
    AssertTrue('HWM did not decrease', hwm1 >= 4);
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure SeedSquish(const APath: string; N: longint);
var
  base: TMessageBase;
  msg: TUniMessage;
  i: longint;
begin
  base := MessageBaseOpen(mbfSquish, APath, momCreate);
  try
    base.Open;
    for i := 1 to N do begin
      msg.Attributes.Clear;
      msg.Attributes.SetValue('from',    'Sender' + IntToStr(i));
      msg.Attributes.SetValue('to',      'Dest');
      msg.Attributes.SetValue('subject', 'Msg ' + IntToStr(i));
      msg.Attributes.SetDate('date.written', Now);
      msg.Body := 'Body ' + IntToStr(i);
      base.WriteMessage(msg);
    end;
  finally
    base.Close;
    base.Free;
  end;
end;

procedure TestSquishCapability;
var
  base: TMessageBase;
begin
  TestBegin('Squish: SupportsHWM = true');
  ForceDirectories(SCRATCH_ROOT + '/sq_cap');
  CleanDir(SCRATCH_ROOT + '/sq_cap');
  base := MessageBaseOpen(mbfSquish, SCRATCH_ROOT + '/sq_cap/sq', momCreate);
  try
    AssertTrue('Open', base.Open);
    AssertTrue('SupportsHWM', base.SupportsHWM);
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestSquishSetGetPersistence;
var
  base: TMessageBase;
begin
  TestBegin('Squish: SetHWM / GetHWM round-trip + persistence');
  ForceDirectories(SCRATCH_ROOT + '/sq_setget');
  CleanDir(SCRATCH_ROOT + '/sq_setget');
  SeedSquish(SCRATCH_ROOT + '/sq_setget/sq', 5);

  base := MessageBaseOpen(mbfSquish, SCRATCH_ROOT + '/sq_setget/sq',
                          momReadWrite);
  try
    AssertTrue('Open RW', base.Open);
    AssertEquals('Initial HWM', -1, base.GetHWM('NetReader'));
    base.SetHWM('NetReader', 4);
    AssertEquals('After SetHWM(4)', 4, base.GetHWM('NetReader'));
    base.SetHWM('Allfix', 2);
    AssertEquals('NetReader still 4', 4, base.GetHWM('NetReader'));
    AssertEquals('Allfix is 2',       2, base.GetHWM('Allfix'));
  finally
    base.Close;
    base.Free;
  end;

  base := MessageBaseOpen(mbfSquish, SCRATCH_ROOT + '/sq_setget/sq',
                          momReadOnly);
  try
    AssertTrue('Reopen RO', base.Open);
    AssertEquals('NetReader HWM persisted', 4, base.GetHWM('NetReader'));
    AssertEquals('Allfix HWM persisted',    2, base.GetHWM('Allfix'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestUnsupportedFormatsReturnNeg1;
var
  msgBase: TMessageBase;
begin
  TestBegin('MSG: SupportsHWM = false, GetHWM = -1');
  ForceDirectories(SCRATCH_ROOT + '/unsupp_msg');
  CleanDir(SCRATCH_ROOT + '/unsupp_msg');

  msgBase := MessageBaseOpen(mbfMsg, SCRATCH_ROOT + '/unsupp_msg/',
                             momCreate);
  try
    AssertTrue('Open MSG base', msgBase.Open);
    AssertEquals('MSG SupportsHWM = false', 'False',
                 BoolToStr(msgBase.SupportsHWM, True));
    AssertEquals('MSG GetHWM = -1', -1, msgBase.GetHWM('NetReader'));
    msgBase.SetHWM('NetReader', 99);  { no-op, no exception }
    AssertEquals('MSG GetHWM still -1 after SetHWM',
                 -1, msgBase.GetHWM('NetReader'));
  finally
    msgBase.Close;
    msgBase.Free;
  end;

  { PKT moved to fpc-ftn-transport; its HWM coverage (also -1)
    is verified there. }

  TestOK;
end;

procedure TestHudsonRequiresMapUserAndBoard;
var
  base: TMessageBase;
begin
  TestBegin('Hudson: GetHWM needs MapUser AND Board context');
  ForceDirectories(SCRATCH_ROOT + '/hudson_setup');
  CleanDir(SCRATCH_ROOT + '/hudson_setup');
  base := MessageBaseOpen(mbfHudson, SCRATCH_ROOT + '/hudson_setup/',
                          momCreate);
  try
    AssertTrue('Open Hudson', base.Open);
    AssertTrue('SupportsHWM = true',  base.SupportsHWM);

    { Without MapUser: -1. }
    AssertEquals('No MapUser yet -> -1',
                 -1, base.GetHWM('NetReader'));

    { MapUser without Board: still -1 (Board context missing). }
    base.MapUser('NetReader', 60001);
    AssertEquals('Map but no Board -> -1',
                 -1, base.GetHWM('NetReader'));

    { Board set, but no HWM written yet: -1. }
    base.Board := 5;
    AssertEquals('No HWM written for board 5 -> -1',
                 -1, base.GetHWM('NetReader'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestGoldBaseSetGet;
var
  base: TMessageBase;
begin
  TestBegin('GoldBase: per-(user,board) HWM round-trip + persistence');
  ForceDirectories(SCRATCH_ROOT + '/gb_setget');
  CleanDir(SCRATCH_ROOT + '/gb_setget');

  base := MessageBaseOpen(mbfGoldBase, SCRATCH_ROOT + '/gb_setget/',
                          momCreate);
  try
    AssertTrue('Open RW', base.Open);
    AssertTrue('SupportsHWM', base.SupportsHWM);
    base.MapUser('NetReader', 60001);
    base.Board := 250;       { exercise GoldBase wider board range }
    base.SetHWM('NetReader', 1234);
    AssertEquals('Same session', 1234, base.GetHWM('NetReader'));
  finally
    base.Close;
    base.Free;
  end;

  base := MessageBaseOpen(mbfGoldBase, SCRATCH_ROOT + '/gb_setget/',
                          momReadOnly);
  try
    AssertTrue('Reopen RO', base.Open);
    base.MapUser('NetReader', 60001);
    base.Board := 250;
    AssertEquals('Persisted', 1234, base.GetHWM('NetReader'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

procedure TestHudsonSetGetPersistence;
var
  base: TMessageBase;
begin
  TestBegin('Hudson: per-(user,board) HWM round-trip + persistence');
  ForceDirectories(SCRATCH_ROOT + '/hudson_setget');
  CleanDir(SCRATCH_ROOT + '/hudson_setget');

  { Write HWM in first session for two users on two boards. }
  base := MessageBaseOpen(mbfHudson, SCRATCH_ROOT + '/hudson_setget/',
                          momCreate);
  try
    AssertTrue('Open RW', base.Open);
    base.MapUser('NetReader', 60001);
    base.MapUser('Allfix',    60002);

    base.Board := 5;
    base.SetHWM('NetReader', 42);
    base.SetHWM('Allfix',    17);

    base.Board := 10;
    base.SetHWM('NetReader', 100);

    { Verify in same session. }
    base.Board := 5;
    AssertEquals('NR board 5', 42, base.GetHWM('NetReader'));
    AssertEquals('AF board 5', 17, base.GetHWM('Allfix'));
    base.Board := 10;
    AssertEquals('NR board 10', 100, base.GetHWM('NetReader'));
    AssertEquals('AF board 10 (never set) -> 0',
                 0, base.GetHWM('Allfix'));
  finally
    base.Close;
    base.Free;
  end;

  { Reopen in a new session, re-register users, verify persistence. }
  base := MessageBaseOpen(mbfHudson, SCRATCH_ROOT + '/hudson_setget/',
                          momReadOnly);
  try
    AssertTrue('Reopen RO', base.Open);
    base.MapUser('NetReader', 60001);
    base.MapUser('Allfix',    60002);

    base.Board := 5;
    AssertEquals('NR board 5 persisted', 42, base.GetHWM('NetReader'));
    AssertEquals('AF board 5 persisted', 17, base.GetHWM('Allfix'));
    base.Board := 10;
    AssertEquals('NR board 10 persisted', 100, base.GetHWM('NetReader'));
  finally
    base.Close;
    base.Free;
  end;
  TestOK;
end;

begin
  WriteLn('fpc-msgbase: HWM API tests (milestone 0.3.0 — JAM only)');
  WriteLn;

  ForceDirectories(SCRATCH_ROOT);

  TestJamCapability;
  TestJamSetGet;
  TestJamPersistence;
  TestJamAutoBump;
  TestJamAutoBumpNoDecrement;
  TestSquishCapability;
  TestSquishSetGetPersistence;
  TestUnsupportedFormatsReturnNeg1;
  TestHudsonRequiresMapUserAndBoard;
  TestHudsonSetGetPersistence;
  TestGoldBaseSetGet;

  Halt(TestsSummary);
end.