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 = true (SMAPI scalar via msg-1 placeholder)');
  ForceDirectories(SCRATCH_ROOT + '/unsupp_msg');
  CleanDir(SCRATCH_ROOT + '/unsupp_msg');

  { SDM has ONE area-wide HWM, stored in msg 1 with from = "-=|smapi
    internal|=-" and the value in replyto.  The library API is
    per-user; the MSG adapter ignores the user-name and returns the
    same scalar for every user.  This matches SMAPI / HPT / Husky
    semantics and is what classic netmail tossers depend on for
    incremental scan.  Pre-0.8 the adapter reported SupportsHWM=false
    and lost every HWM update; the gap broke "scan only new messages"
    against any HPT-tossed netmail base.  Asserting the new behaviour
    here so a regression to the old no-HWM path fails loudly. }
  msgBase := MessageBaseOpen(mbfMsg, SCRATCH_ROOT + '/unsupp_msg/',
                             momCreate);
  try
    AssertTrue('Open MSG base', msgBase.Open);
    AssertEquals('MSG SupportsHWM = true', 'True',
                 BoolToStr(msgBase.SupportsHWM, True));
    { Empty area: no msg-1 placeholder yet, GetHWM = 0. }
    AssertEquals('MSG empty-area GetHWM = 0', 0,
                 msgBase.GetHWM('NetReader'));
    msgBase.SetHWM('NetReader', 42);
    { In-memory HWM round-trips before close. }
    AssertEquals('MSG GetHWM round-trip in same session',
                 42, msgBase.GetHWM('NetReader'));
  finally
    msgBase.Close;
    msgBase.Free;
  end;

  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.