Bbs.pas

unit Bbs;

interface

uses
  Classes, SysUtils, StrUtils, Math,
  Transport;

type
  TBbs = class(TObject)
  private
    FTransport: TTransport;
    function SearchFileName(FileName: string; AttachName: string; var Stamp: string; var Id: string): integer;
  public
    function Load(FileName: string; Regist: boolean = true): string;
    procedure NewBoard(BoardName: string; BoardComment: string; Trip: string; DoPost: boolean);
    procedure NewTopic(BoardFile: string; TopicName: string; Trip: string; WebFlag: boolean; DoPost: boolean);
    function Post(FileName: string; Subject: string; Name: string; Trip: string; Mail: string; Body: string; Ext: string; Attach: string; AttachFileName: string; DoPost: boolean; Error: boolean): string;
    function GetRecord(FileName: string; Stamp: string = ''; Id: string = ''): string;
    function GetAttachFile(FileName: string; Stamp: string; Id: string; Ext: string; IsAttach: boolean = false): string;
    function GetStat(FileName: string; var LastStamp: integer): integer;
    procedure RemoveRecord(FileName: string; Range: string = '');
    constructor Create(Transport: TTransport);
  end;

function GetField(Name: string; Dat: string): string;

implementation

uses
  apollo,
  Cache, Config, Zstr, StrSub;

constructor TBbs.Create(Transport: TTransport);
begin
  inherited Create;
  FTransport := Transport;
end;

function RandomName: string;
var
  d: string;
  i: integer;
  k: integer;
begin
  d := '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz';
  result := '';
  for i := 0 to 16 - 1 do begin
    k := random(62);
    result := result + Copy(d, k + 1, 1);
  end;
end;

procedure TBbs.NewBoard(BoardName: string; BoardComment: string; Trip: string; DoPost: boolean);
var
  fileName: string;
  boardFile: string;
  stamp: string;
  id: string;
  pubkey: string;
  secretkey: string;
  sign: string;
  s: string;
begin
  s := ConvToHtml(BoardName) + '<>' + ConvToHtml(BoardComment) + '<><><><>type:list<>nop:' + RandomName;
  if Trip <> '' then begin
    RSAkeycreate512(pubkey, secretkey, Trip);
    sign := RSAsign(Base64EncodeStr(MD5String(s)), pubkey, secretkey);
    s := s + '<>pubkey:' + pubkey + '<>sign:' + sign;
  end;
  boardFile := MD5String(s);
  if BoardName <> '' then begin
    FCache.AppendRecord(boardFile, '0000000000<>' + MD5String(s) + '<>' + s + #$0a, true);
    s := boardFile + '<>' + BoardName;
    stamp := IntToStr2(ConvTimeT(Now) + Round(60.0 * RandG(0.0, 1.0)));
    id := MD5String(s);
    fileName := 'menu';
    FCache.AppendRecord(FileName, stamp + '<>' + id + '<>' + s + #$0a);
    if DoPost then begin
      FCache.PushOrder('@update<>' + FileName + '<>' + stamp + '<>' + id + '<>');
    end;
  end;
end;

procedure TBbs.NewTopic(BoardFile: string; TopicName: string; Trip: string; WebFlag: boolean; DoPost: boolean);
var
  topicFile: string;
  stamp: string;
  id: string;
  pubkey: string;
  secretkey: string;
  sign: string;
  s: string;
begin
  if WebFlag then begin
    s := ConvToHtml(TopicName) + '<><><><><>type:web<>nop:' + RandomName;
  end else begin
    s := ConvToHtml(TopicName) + '<><><><><>type:thread<>nop:' + RandomName;
  end;
  if Trip <> '' then begin
    RSAkeycreate512(pubkey, secretkey, Trip);
    sign := RSAsign(Base64EncodeStr(MD5String(s)), pubkey, secretkey);
    s := s + '<>pubkey:' + pubkey + '<>sign:' + sign;
  end;
  topicFile := MD5String(s);
  if TopicName <> '' then begin
    FCache.AppendRecord(topicFile, '0000000000<>' + MD5String(s) + '<>' + s + #$0a, true);
    s := topicFile + '<>' + ConvToHtml(TopicName);
    stamp := IntToStr2(ConvTimeT(Now) + Round(60.0 * RandG(0.0, 1.0)));
    id := MD5String(s);
    FCache.AppendRecord(BoardFile, stamp + '<>' + id + '<>' + s + #$0a);
    if DoPost then begin
      FCache.PushOrder('@update<>' + BoardFile + '<>' + stamp + '<>' + id + '<>');
    end;
  end;
end;

function TBbs.Post(FileName: string; Subject: string; Name: string; Trip: string; Mail: string; Body: string; Ext: string; Attach: string; AttachFileName: string; DoPost: boolean; Error: boolean): string;
var
  stamp: string;
  id: string;
  pubkey: string;
  secretkey: string;
  sign: string;
  s: string;
begin
  s := ConvToHtml(Mail) + '<>' + ConvToHtml(Body) + '<>' +
    ConvToHtml(Ext) + '<>' + Base64encodeStr(Attach);
  if Subject <> '' then begin
    s := s + '<>subject:' + Subject;
  end;
  if AttachFileName <> '' then begin
    s := s + '<>filename:' + AttachFileName;
  end;
  s := ConvToHtml(Name) + '<>' + s;
  if Trip <> '' then begin
    RSAkeycreate512(pubkey, secretkey, Trip);
    sign := RSAsign(Base64EncodeStr(MD5String(s)), pubkey, secretkey);
    s := s + '<>pubkey:' + pubkey + '<>sign:' + sign;
  end;
  if Error then begin
    stamp := IntToStr2(ConvTimeT(Now) + Round(60.0 * RandG(0.0, 1.0)));
  end else begin
    stamp := IntToStr2(ConvTimeT(Now));
  end;
  id := MD5String(s);
  if (Body <> '') or (Attach <> '') then begin
    FCache.AppendRecord(fileName, stamp + '<>' + id + '<>' + s + #$0a);
    if DoPost then begin
      FCache.PushOrder('@update<>' + fileName + '<>' + stamp + '<>' + id + '<>');
    end;
  end;
  result := id;
end;

function CheckSign(Ln: TZstr; var Trip: string): boolean;
var
  zTmp: TZstr;
  zLn1: TZstr;
  zLn2: TZstr;
  zLn3: TZstr;
  pubkey: string;
  sign: string;
  s: string;
  s2: string;
begin
  result := false;
  Trip := '';
  pubkey := '';
  sign := '';
  ZstrSeparateBracket(Ln, zTmp);  // id
  ZstrSeparateBracket(Ln, zTmp);  // stmp
  zLn1 := Ln;
  ZstrSeparateBracket(Ln, zTmp);  // name
  ZstrSeparateBracket(Ln, zTmp);  // mail
  ZstrSeparateBracket(Ln, zTmp);  // body
  ZstrSeparateBracket(Ln, zTmp);  // ext
  ZstrSeparateBracket(Ln, zTmp);  // attach
  while ZstrLength(Ln) > 0 do begin
    zLn2 := Ln;
    ZstrSeparateBracket(Ln, zTmp);
    s := ZstrToString(zTmp);
    s2 := SeparateWord(':', s);
    if s2 = 'pubkey' then begin
      if pubkey <> '' then begin
        exit;
      end;
      zLn3 := zLn1;
      zLn3.tail := zLn2.top - 2;
      pubkey := s;
      Trip := triphash(pubkey);
    end else if s2 = 'sign' then begin
      if sign <> '' then begin
        exit;
      end;
      sign := s;
    end;
  end;
  if (pubkey = '') or (sign = '') then begin
    exit;
  end;
  if RSAverify(Base64EncodeStr(MD5String(ZstrToString(zLn3))), sign, pubkey) then begin
    result := true;
  end;
end;

procedure UpdateCache(FileName: string);
var
  topicId: string;
  Dat: string;
  newDat: string;
  zDat: TZstr;
  zLn: TZstr;
  zLn2: TZstr;
  zLn3: TZstr;
  zLn4: TZstr;
  zStamp: TZstr;
  zId: TZstr;
  zName: TZstr;
  zMail: TZstr;
  zBody: TZstr;
  zExt: TZstr;
  zAttach: TZstr;
  zNew: TZstr;
  zTmp: TZstr;
  argSignOk: boolean;
  argName: string;
  argTrip: string;
  argExt: string;
  argAttach: string;
  k: integer;
  k2: integer;
  lastStamp: integer;
  f: TMemoryStream;
  width: integer;
  height: integer;
  count: integer;
  s: string;
  s2: string;
  d1: TDateTime;
  d2: TDateTime;
  d3: TDateTime;
begin
  FCache.Lock;
  d1 := FCache.GetFileDate('dat\' + FileName + '.dat');
  d2 := FCache.GetFileDate('cache\' + FileName + '.web');
  d3 := FCache.GetFileDate('cache\' + FileName + '.ctrl');
  if (d1 <> 0.0) and (d2 <> 0.0) and (d3 <> 0.0) and (d2 >= d1) and (d3 >= d1) then begin
    FCache.Unlock;
    exit;
  end;
  if d1 = 0.0 then begin
    FCache.DeleteFile('cache\' + FileName + '.web');
    FCache.DeleteFile('cache\' + FileName + '.ctrl');
    FCache.Unlock;
    exit;
  end;
  Dat := FCache.LoadFile('dat\' + FileName + '.dat');
  SetLength(newDat, Length(Dat));
  zNew := StringToZstr(newDat);
  ZstrClear(zNew);
  zDat := StringToZstr(dat);
  count := 0;
  lastStamp := 0;
  while ZstrLength(zDat) > 0 do begin
    ZstrSeparateLf(zDat, zLn);
    zLn2 := zLn;
    k := ZstrCountWord(zLn, '<>');
    ZstrSeparateBracket(zLn, zStamp);
    ZstrSeparateBracket(zLn, zId);
    zLn4 := zLn;
    ZstrSeparateBracket(zLn, zName);
    ZstrSeparateBracket(zLn, zMail);
    ZstrSeparateBracket(zLn, zBody);
    ZstrSeparateBracket(zLn, zExt);
    ZstrSeparateBracket(zLn, zAttach);
    zLn3 := zLn;
    topicId := ZstrToString(zId);
    k2 := StrToInt2(ZstrToString(zStamp));
    if k2 > lastStamp then begin
      lastStamp := k2;
    end;
    if ZstrLength(zLn4) = 0 then begin
      ZstrAppend(zNew, zStamp);
      ZstrAppend(zNew, '<>');
      ZstrAppend(zNew, zId);
      ZstrAppend(zNew, #$0a);
    end else begin
      if (k2 = 0) then begin
        count := 1;
      end else begin
        if count = 0 then begin
          count := 1;
        end;
        Inc(count);
      end;
      ZstrAppend(zNew, zStamp);
      ZstrAppend(zNew, '<>');
      ZstrAppend(zNew, zId);
      ZstrAppend(zNew, '<>');

      argSignOk := CheckSign(zLn2, argTrip);
      argName := ZstrToString(zName);
      ZstrAppend(zNew, argName);

      if k >= 3 then begin
        ZstrAppend(zNew, '<>');
        ZstrAppend(zNew, zMail);
      end;
      if k >= 4 then begin
        ZstrAppend(zNew, '<>');
        ZstrAppend(zNew, zBody);
      end;
      if k >= 5 then begin
        ZstrAppend(zNew, '<>');
        ZstrAppend(zNew, zExt);
      end;
      if k >= 6 then begin
        if ZStrLength(zAttach) > 0 then begin
          argExt := ZstrToString(zExt);
          if
            (LowerCase(argExt) = 'jpeg') or
            (LowerCase(argExt) = 'jpg') or
            (LowerCase(argExt) = 'jpe') or
            (LowerCase(argExt) = 'gif') or
            (LowerCase(argExt) = 'png')
          then begin
            argAttach := Base64DecodeStr(ZstrToString(zAttach));
            f := TMemoryStream.Create;
            f.Write(argAttach[1], Length(argAttach));
            f.Position := 0;
            GetImageSize(f, '.' + argExt, width, height);
            f.Free;
            ZstrAppend(zNew, '<>#' + IntToStr(ZStrLength(zAttach) * 3 div 4) + '(' + IntToStr(width) + 'x' + IntToStr(height) + ')');
          end else begin
            ZstrAppend(zNew, '<>#' + IntToStr(ZStrLength(zAttach) * 3 div 4));
          end;
        end else begin
          ZstrAppend(zNew, '<>');
        end;
      end;
      while ZstrLength(zLn) > 0 do begin
        ZstrSeparateBracket(zLn, zTmp);
        ZstrAppend(zNew, '<>');
        s := ZstrToString(zTmp);
        s2 := SeparateWord(':', s);
        if s2 = 'sign' then begin
          if argSignOk then begin
            ZstrAppend(zNew, 'sign:ok:' + argTrip);
          end else begin
            ZstrAppend(zNew, 'sign:bad:' + argTrip);
          end;
        end else begin
          ZstrAppend(zNew, zTmp);
        end;
      end;
      ZstrAppend(zNew, #$0a);
    end;
  end;
  SetLength(newDat, ZstrLength(zNew));
  FCache.SaveFile('cache\' + FileName + '.web', newDat);
  FCache.SaveFile('cache\' + FileName + '.ctrl',
    IntToStr2(lastStamp) + '<>' + IntToStr(count) + #$0a
  );
  FCache.SetFileDate('cache\' + FileName + '.web', d1);
  FCache.SetFileDate('cache\' + FileName + '.ctrl', d1);
  FCache.Unlock;
end;

function TBbs.Load(FileName: string; Regist: boolean = true): string;
var
  d1: TDateTime;
  timeout: TDateTime;
begin
  result := '';
  if FileName = '' then begin
    exit;
  end;
  if Regist then begin
    if FCache.GetFileSize('dat\' + FileName + '.dat') <= 0 then begin
      timeout := 5.0;
      if not FCache.FileExists('dat\' + FileName + '.dat') then begin
        timeout := 15.0;
        FCache.AppendRecord(FileName, '');
      end;
      FCache.PushSync(FileName + '.dat' + #$0a);
      d1 := Now;
      while true do begin
        if FTerminateFlag or ((Now - d1) > (1.0 / (24.0 * 60.0 * 60) * timeout)) then begin
          exit;
        end;
        if FCache.GetFileSize('dat\' + FileName + '.dat') > 0 then begin
          break;
        end;
        sleep(1000);
      end;
    end;
  end;
  UpdateCache(FileName);
  result := FCache.LoadFile('cache\' + FileName + '.web');
end;

function TBbs.GetStat(FileName: string; var LastStamp: integer): integer;
var
  dat: string;
  ln: string;
begin
  LastStamp := 0;
  result := 0;
  if FileName = '' then begin
    exit;
  end;
  UpdateCache(FileName);
  dat := FCache.LoadFile('cache\' + FileName + '.ctrl');
  if dat = '' then begin
    exit;
  end;
  ln := SeparateLf(dat);
  LastStamp := StrToInt2(SeparateBracket(ln));
  result := StrToInt2(SeparateBracket(ln));
end;

function GetField(Name: string; Dat: string): string;
var
  s: string;
  s2: string;
begin
  result := '';
  SeparateBracket(Dat); // stamp
  SeparateBracket(Dat); // id
  SeparateBracket(Dat); // name
  SeparateBracket(Dat); // mail
  SeparateBracket(Dat); // body
  SeparateBracket(Dat); // ext
  SeparateBracket(Dat); // attach
  while dat <> '' do begin
    s := SeparateBracket(Dat);
    s2 := SeparateWord(':', s);
    if s2 = Name then begin
      result := s;
      break;
    end;
  end;
end;

function TBbs.GetRecord(FileName: string; Stamp: string = ''; Id: string = ''): string;
var
  dat: string;
  zDat: TZstr;
  zLn: TZstr;
  zTmp: TZstr;
  zStamp: TZstr;
  zId: TZstr;
  zRes: TZstr;
begin
  result := Load(FileName, false);
  if result = '' then begin
    exit;
  end;
  if (Stamp <> '') or (Id <> '') then begin
    dat := result;
    zDat := StringToZstr(dat);
    zRes := StringToZstr(result);
    ZstrClear(zRes);
    while ZstrLength(zDat) > 0 do begin
      ZstrSeparateLf(zDat, zLn);
      zTmp := zLn;
      ZstrSeparateBracket(zTmp, zStamp);
      ZstrSeparateBracket(zTmp, zId);
      if (ZstrLength(zTmp) > 0) and (Stamp = ZstrToString(zStamp)) and (Id = ZstrToString(zId)) then begin
        ZstrAppend(zRes, zLn);
        ZstrAppend(zRes, #$0a);
      end;
    end;
    SetLength(result, ZstrLength(zRes));
  end;
end;

function TBbs.SearchFileName(FileName: string; AttachName: string; var Stamp: string; var Id: string): integer;
var
  dat: string;
  zDat: TZstr;
  zLn: TZstr;
  zStamp: TZstr;
  zId: TZstr;
  s1: string;
  s2: string;
begin
  result := 0;
  Stamp := '';
  Id := '';
  dat := Load(FileName, false);
  zDat := StringToZstr(dat);
  while ZstrLength(zDat) > 0 do begin
    ZstrSeparateLf(zDat, zLn);
    s1 := GetField('filename', ZstrToString(zLn));
    s2 := GetField('subject', ZstrToString(zLn));
    ZstrSeparateBracket(zLn, zStamp);
    ZstrSeparateBracket(zLn, zId);
    if s1 = AttachName then begin
      Stamp := ZstrToString(zStamp);
      Id := ZstrToString(zId);
      result := 1;
    end else if s2 = AttachName then begin
      Stamp := ZstrToString(zStamp);
      Id := ZstrToString(zId);
      result := 2;
    end;
  end;
end;

function TBbs.GetAttachFile(FileName: string; Stamp: string; Id: string; Ext: string; IsAttach: boolean = false): string;
var
  d1: TDateTime;
  d2: TDateTime;
  stamp2: string;
  id2: string;
  attachType: integer;
begin
  FCache.Lock;
  d1 := FCache.GetFileDate('cache\' + FileName + '-' + Stamp + '-' + Id + '.' + Ext);
  d2 := FCache.GetFileDate('dat\' + FileName + '.dat');
  if (d1 = 0.0) or (d2 = 0.0) or (d1 < d2) then begin
    if (Stamp = '') and (not IsAttach) then begin
      if Id = '' then begin
        attachType := 0;
        result := FCache.GetRecord(FileName);
      end else begin
        attachType := 2;
        result := FCache.GetRecord(FileName, '/' + Id);
      end;
    end else begin
      if Id = '_' then begin
        stamp2 := Stamp;
        if Ext <> '' then begin
          stamp2 := stamp2 + '.' + Ext;
        end;
        attachType := SearchFileName(FileName, stamp2, stamp2, id2);
        result := FCache.GetRecord(FileName, stamp2 + '/' + id2);
      end else begin
        attachType := 1;
        result := FCache.GetRecord(FileName, Stamp + '/' + Id);
      end;
    end;
    if attachType = 1 then begin
      SeparateBracket(result); // stamp
      SeparateBracket(result); // id
      SeparateBracket(result); // name
      SeparateBracket(result); // mail
      SeparateBracket(result); // body
      SeparateBracket(result); // ext
      result := SeparateBracket(result);
      if result <> '' then begin
        result := Base64DecodeStr(result);
      end;
    end else if attachType = 2 then begin
      SeparateBracket(result); // stamp
      SeparateBracket(result); // id
      SeparateBracket(result); // name
      SeparateBracket(result); // mail
      result := SeparateBracket(result);
      if result <> '' then begin
        result := ReverseFromHtml(result);
      end;
    end;
    if result <> '' then begin
      if d2 = 0.0 then begin
        if d1 <> 0.0 then begin
          FCache.DeleteFile('cache\' + FileName + '-' + Stamp + '-' + Id + '.' + Ext);
        end;
      end else begin
        FCache.SaveFile('cache\' + FileName + '-' + Stamp + '-' + Id + '.' + Ext, result);
        FCache.SetFileDate('cache\' + FileName + '-' + Stamp + '-' + Id + '.' + Ext, d2)
      end;
    end;
  end else begin
    result := FCache.LoadFile('cache\' + FileName + '-' + Stamp + '-' + Id + '.' + Ext);
  end;
  FCache.Unlock;
end;

procedure TBbs.RemoveRecord(FileName: string; Range: string = '');
begin
  FCache.RemoveRecord(FileName, Range);
end;

end.