fpc-msgbase/src/mb.paths.pas

{ mb.paths - per-backend filename derivation and
  case-insensitive existence resolution (tries path, UPPER, lower
  before giving up). }

unit mb.paths;

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils,
  mb.types;

{ Directory/basename joining that always uses PathDelim. }
function PathJoin(const ADir, ATail: AnsiString): AnsiString;
function PathAppendSep(const ADir: AnsiString): AnsiString;

{ True when ATail is safe to use as a single path component below a
  trusted base directory: non-empty, no NUL, no directory separators,
  no '..', not an absolute path, not a drive-letter prefix.
  The caller is the trust boundary; once a name has been validated it
  is safe to feed into PathJoin. }
function IsSafePathComponent(const ATail: AnsiString): boolean;

{ Raise EInOutError when ATail is not a safe component.  Used on
  entry points that accept an area tag or filename derived from
  outside data (.pkt filenames, flow-file lines, config values). }
procedure EnforceSafePathComponent(const ATail: AnsiString;
                                   const AWhere: AnsiString = '');

{ Try APath as-is, then UpperCase(basename), then LowerCase(basename).
  Returns the first that exists, or APath unchanged when nothing
  resolves (so the caller can produce a useful error message). }
function FindExistingFile(const APath: AnsiString): AnsiString;

{ Produce the canonical constructor argument each backend expects.

    Format          AAreaPath         AAreaTag         Returns
    --------------  ----------------- ---------------- ----------------
    mbfHudson       <dir>             ignored          <dir>
    mbfGoldBase     <dir>             ignored          <dir>
    mbfJam          <dir>             <tag>            <dir>/<tag>
    mbfSquish       <dir>             <tag>            <dir>/<tag>
    mbfPCBoard      <dir>             <basename>       <dir>/<basename>
    mbfMsg          <dir>             ignored          <dir>
    mbfPkt          <dir>             <filename>       <dir>/<filename>
    mbfEzyCom       <dir>             <boardNumStr>    <dir>         (+ AAreaTag)
    mbfWildcat      <wcroot>          <confNumStr>     <wcroot>      (+ AAreaTag)
}
function MessageBasePathFor(AFormat: TMsgBaseFormat;
                            const AAreaPath: AnsiString;
                            const AAreaTag: AnsiString = ''): AnsiString;

{ Compose the per-file name a backend reads/writes.  E.g.
    HudsonFilePath(dir, 'MSGINFO.BBS') -> <dir>/MSGINFO.BBS, with
  case-insensitive resolution.  Callers use this internally so
  DOS-era mixed-case file layouts keep working on case-sensitive
  Unix filesystems. }
function HudsonFilePath(const ADir, ABaseName: AnsiString): AnsiString;
function GoldBaseFilePath(const ADir, ABaseName: AnsiString): AnsiString;
function JamFilePath(const ABaseName, AExt: AnsiString): AnsiString;
function SquishFilePath(const ABaseName, AExt: AnsiString): AnsiString;
function PCBoardFilePath(const ABaseName, AExt: AnsiString): AnsiString;
function MsgDirFile(const ADir: AnsiString; AMsgNum: longint): AnsiString;
function EzyComFilePath(const ADir: AnsiString;
                        ABoard: word;
                        const APrefix, AExt: AnsiString): AnsiString;

{ Derived sentinel file name for mb.lock.  Backends that share a
  file layout should agree on the same sentinel so cross-process
  locks work even with other tools in the ecosystem (e.g. Squish
  uses .SQL per the format spec). }
function LockFilePath(AFormat: TMsgBaseFormat;
                      const ABasePath: AnsiString;
                      const AAreaTag: AnsiString = ''): AnsiString;

implementation

function PathAppendSep(const ADir: AnsiString): AnsiString;
begin
  if ADir = '' then
    Result := ''
  else if ADir[Length(ADir)] = PathDelim then
    Result := ADir
  else
    Result := ADir + PathDelim;
end;

function PathJoin(const ADir, ATail: AnsiString): AnsiString;
begin
  if ATail = '' then Result := ADir
  else if ADir = ''  then Result := ATail
  else Result := PathAppendSep(ADir) + ATail;
end;

function IsSafePathComponent(const ATail: AnsiString): boolean;
var
  i: integer;
  c: AnsiChar;
begin
  Result := False;
  if ATail = '' then exit;
  if (ATail = '.') or (ATail = '..') then exit;
  { Block absolute paths and Windows drive-letter prefixes. }
  if ATail[1] in ['/', '\'] then exit;
  if (Length(ATail) >= 2) and (ATail[2] = ':') then exit;
  for i := 1 to Length(ATail) do begin
    c := ATail[i];
    if (c = #0) or (c = '/') or (c = '\') then exit;
  end;
  { Reject any occurrence of '..' as a sub-component; after the
    separator check above we also know there are no separators, so
    a literal '..' substring can only mean dot-dot traversal in a
    tail that was hand-built by concatenation. }
  if Pos('..', ATail) > 0 then exit;
  Result := True;
end;

procedure EnforceSafePathComponent(const ATail: AnsiString;
                                   const AWhere: AnsiString);
begin
  if not IsSafePathComponent(ATail) then begin
    if AWhere = '' then
      raise EInOutError.CreateFmt(
        'mb.paths: unsafe path component %s', [AnsiQuotedStr(ATail, '"')])
    else
      raise EInOutError.CreateFmt(
        'mb.paths: unsafe path component %s in %s',
        [AnsiQuotedStr(ATail, '"'), AWhere]);
  end;
end;

function FindExistingFile(const APath: AnsiString): AnsiString;
var
  dir, name, upper, lower: AnsiString;
begin
  Result := APath;
  if APath = '' then exit;
  if FileExists(APath) then exit;

  dir  := ExtractFilePath(APath);
  name := ExtractFileName(APath);
  if name = '' then exit;

  upper := dir + UpperCase(name);
  if FileExists(upper) then begin Result := upper; exit; end;

  lower := dir + LowerCase(name);
  if FileExists(lower) then begin Result := lower; exit; end;
end;

function MessageBasePathFor(AFormat: TMsgBaseFormat;
                            const AAreaPath: AnsiString;
                            const AAreaTag: AnsiString): AnsiString;
begin
  case AFormat of
    mbfHudson, mbfGoldBase, mbfMsg:
      Result := PathAppendSep(AAreaPath);

    mbfJam, mbfSquish, mbfPCBoard, mbfPkt:
      { mbfPkt's path resolution stays here -- the enum value is
        defined in mb.types so the factory can register from
        fpc-ftn-transport, and the .pkt is a single file (same
        shape as JAM/Squish/PCBoard). }
      if AAreaTag = '' then
        Result := AAreaPath
      else
        Result := PathJoin(AAreaPath, AAreaTag);

    mbfEzyCom, mbfWildcat:
      Result := PathAppendSep(AAreaPath);
  else
    Result := AAreaPath;
  end;
end;

function HudsonFilePath(const ADir, ABaseName: AnsiString): AnsiString;
begin
  Result := FindExistingFile(PathJoin(ADir, ABaseName));
end;

function GoldBaseFilePath(const ADir, ABaseName: AnsiString): AnsiString;
begin
  Result := FindExistingFile(PathJoin(ADir, ABaseName));
end;

function JamFilePath(const ABaseName, AExt: AnsiString): AnsiString;
begin
  Result := FindExistingFile(ABaseName + AExt);
end;

function SquishFilePath(const ABaseName, AExt: AnsiString): AnsiString;
begin
  Result := FindExistingFile(ABaseName + AExt);
end;

function PCBoardFilePath(const ABaseName, AExt: AnsiString): AnsiString;
begin
  Result := FindExistingFile(ABaseName + AExt);
end;

function MsgDirFile(const ADir: AnsiString; AMsgNum: longint): AnsiString;
begin
  Result := FindExistingFile(PathJoin(ADir,
                                      Format('%d.msg', [AMsgNum])));
end;

function EzyComFilePath(const ADir: AnsiString;
                        ABoard: word;
                        const APrefix, AExt: AnsiString): AnsiString;
var
  fn: AnsiString;
begin
  { EzyCom on-disk naming:  AREAn/MH#####.BBS }
  fn := Format('AREA%d%s%s%.5d%s',
               [ABoard, PathDelim, APrefix, ABoard, AExt]);
  Result := FindExistingFile(PathJoin(ADir, fn));
end;

function LockFilePath(AFormat: TMsgBaseFormat;
                      const ABasePath: AnsiString;
                      const AAreaTag: AnsiString): AnsiString;
begin
  case AFormat of
    mbfHudson, mbfGoldBase:
      Result := PathJoin(ABasePath, 'msgbase.lck');
    mbfJam:
      Result := ABasePath + '.lck';
    mbfSquish:
      { Squish's native lock is .SQL -- share it so other Squish
        tools notice us (and we notice them). }
      Result := ABasePath + '.sql';
    mbfPCBoard:
      Result := ABasePath + '.lck';
    mbfMsg:
      Result := PathJoin(ABasePath, 'msgdir.lck');
    mbfPkt:
      Result := ABasePath + '.lck';
    mbfEzyCom:
      Result := PathJoin(ABasePath, 'ezycom.lck');
    mbfWildcat:
      Result := PathJoin(ABasePath, 'wildcat.lck');
  else
    Result := ABasePath + '.lck';
  end;
  if AAreaTag <> '' then ;  { reserved for future per-area sentinels }
end;

end.