© BigSpeed Computing Inc. - Secure private networking



// *** Delphi example of private peer-to-peer agent ***



unit uMain;


interface

uses
  ActiveX, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ShlObj, StdCtrls, ComCtrls, ToolWin, Menus, ActnList, ImgList, StrUtils, Contnrs,
  ExtCtrls, Registry, Variants, ShellAPI, Buttons, IniFiles,
  bsP2PAgent_TLB, ErrMsg, uAlert, uChat, uFiles, uSearch, Globals, 
  uSettings;



type
  TfMain = class(TForm)
    StatusBar: TStatusBar;
    Timer1: TTimer;
    GroupBox3: TGroupBox;
    btnConnect: TButton;
    btnDisconnect: TButton;
    btnCancel: TButton;
    btnExit: TButton;
    btnAbout: TButton;
    GroupBox1: TGroupBox;
    lvPeers: TListView;
    btnRemove: TButton;
    btnFiles: TButton;
    btnChat: TButton;
    btnSearch: TButton;
    GroupBox2: TGroupBox;
    mmLog: TMemo;
    btnClearLog: TButton;
    btnUsers: TButton;
    btnAlert: TButton;
    btnSettings: TButton;
    btnMyIP: TButton;

    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);

    procedure btnExitClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
    procedure btnConnectClick(Sender: TObject);
    procedure btnCancelClick(Sender: TObject);
    procedure btnDisconnectClick(Sender: TObject);
    procedure btnClearLogClick(Sender: TObject);
    procedure btnUsersClick(Sender: TObject);
    procedure lvPeersChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure btnRemoveClick(Sender: TObject);
    procedure btnChatClick(Sender: TObject);
    procedure btnAlertClick(Sender: TObject);
    procedure btnFilesClick(Sender: TObject);
    procedure btnSearchClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnSettingsClick(Sender: TObject);
    procedure btnMyIPClick(Sender: TObject);

  private
    { Private declarations }

    procedure LogMsg(aText: String);
    function SelectPeer(aHandle: Integer): Boolean;
    procedure LoadForm;
    procedure SaveForm;
    procedure SetSettings;
    procedure UpdateStatus;
    procedure UpdateButtons;
    procedure DeletePeer(aPeer: TPeer);

    //Event handlers
    procedure doSessionOpen(Sender: TObject);
    procedure doSessionClosed(Sender: TObject);
    procedure doSessionRejected(Sender: TObject);

    procedure GoPeerConnected(Sender: TObject; aHandle: Integer);
    procedure GoPeerDisconnected(Sender: TObject; aHandle: Integer);

    procedure GoHaveAlertMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
    procedure GoHaveChatMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);

    procedure GoNeedFileList(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoHaveFileItem(Sender: TObject; aHandle: Integer; const aName: WideString; aFolder:WordBool; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
    procedure GoListDone(Sender: TObject; aHandle: Integer; aCode: Integer);

    procedure GoNeedCreateFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoCreateFolderDone(Sender: TObject; aHandle: Integer; aCode: Integer);

    procedure GoNeedRenameFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoRenameFolderDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoNeedRenameFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoRenameFileDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoNeedDeleteFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoDeleteFolderDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoNeedDeleteFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoDeleteFileDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoDownloadClientDone(Sender: TObject; aHandle, aCode: Integer);
    procedure GoDownloadClientProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
    procedure GoNeedDownload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoDownloadServerDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoClientUploadDone(Sender: TObject; aHandle, aCode: Integer);
    procedure GoUploadClientProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
    procedure GoNeedUpload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoServerUploadDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoNeedZip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoZipProgress(Sender: TObject; aHandle, aFileCount, aFileTotal, aByteCountLo, aByteCountHi, aByteTotalLo, aByteTotalHi: Integer);
    procedure GoClientZipDone(Sender: TObject; aHandle, aCode: Integer);
    procedure GoServerZipDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoNeedUnzip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoUnzipProgress(Sender: TObject; aHandle, aFileCount, aFileTotal, aByteCountLo, aByteCountHi, aByteTotalLo, aByteTotalHi: Integer);
    procedure GoClientUnzipDone(Sender: TObject; aHandle, aCode: Integer);
    procedure GoServerUnzipDone(Sender: TObject; aHandle, aCode: Integer);

    procedure GoNeedSearch(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure GoHaveFindFile(Sender: TObject; aHandle: Integer; const aName: WideString; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
    procedure GoSearchProgress(Sender: TObject; aHandle, aCount: Integer);
    procedure GoClientSearchDone(Sender: TObject; aHandle, aCode: Integer);
    procedure GoServerSearchDone(Sender: TObject; aHandle, aCode: Integer);
  public
    { Public declarations }

    SelPeer: TPeer;
    P2pAgent: TBSP2PAgentX;
    MyPeers: TObjectList;

    procedure CheckError(aCode: Integer);
  end;

var
  fMain: TfMain;



//Public functions
function UN(aName: WideString): String;
function Make64(aLo, aHi: Integer): Int64;
function FileTimeToDateTime(FileTime: TFileTime): TDateTime;
function FileTimeToText(aFileTime: TFileTime): String;
function AddSlash(aPath: String): String;
function SlashOff(aPath: String): String;
function PreSlash(aPath: String): String;
function SizeStr(aSize: Int64): String;




implementation

uses uAbout, uAdd, uConnect, uRights;

{$R *.DFM}



// *** Misc functions


//Format size number
function SizeStr(aSize: Int64): String;
var
  i,j: Integer;
  S: String;
begin
  Result := '';
  S := IntToStr(aSize);
  i := Length(S);
  j := 3;
  while i > 0 do
  begin
    if j = 0 then
    begin
      Result := ',' + Result;
      j := 3;
    end;
    Result := S[i] + Result;
    dec(i);
    dec(j);
  end;
end;


function Make64(aLo, aHi: Integer): Int64;
begin
  Result := aHi;
  Result := Result shl 32;
  Result := Result + Cardinal(aLo);
end;




function FileTimeToDateTime(FileTime: TFileTime): TDateTime;
var
  ModifiedTime: TFileTime;
  SystemTime: TSystemTime;
begin
  Result := 0;
  if (FileTime.dwLowDateTime = 0) and (FileTime.dwHighDateTime = 0) then Exit;
  try
    FileTimeToLocalFileTime(FileTime, ModifiedTime);
    FileTimeToSystemTime(ModifiedTime, SystemTime);
    Result := SystemTimeToDateTime(SystemTime);
  except
    Result := Now;  // Something to return in case of error
  end;
end;


function FileTimeToText(aFileTime: TFileTime): String;
begin
  Result := '';
  if (aFileTime.dwLowDateTime = 0) and (aFileTime.dwHighDateTime = 0) then Exit;
  try
    Result := DateTimeToStr(FileTimeToDateTime(aFileTime));
  except
    Result := '';
  end;
end;



//Add a trailing slash
function AddSlash(aPath: String): String;
begin
  Result := aPath;
  if RightStr(Result, 1) = '\' then Exit;
  Result := Result + '\';
end;


//Remove the trailing slash
function SlashOff(aPath: String): String;
begin
  Result := aPath;
  if RightStr(Result, 1) <> '\' then Exit;
  Delete(Result, Length(Result), 1);
end;


//Insert a leading slash
function PreSlash(aPath: String): String;
begin
  Result := aPath;
  if LeftStr(Result, 1) = '\' then Exit;
  Result := '\' + Result;
end;


//Check for empty user name
function UN(aName: WideString): String;
begin
  Result := aName;
  if Result > '' then Exit;
  Result := 'Guest';
end;


// *** General



procedure TfMain.LogMsg(aText: String);
begin
  mmLog.Lines.Add(TimeToStr(Now) + ': ' + aText);
end;


//Retrieve a peer object by it's handle
function TfMain.SelectPeer(aHandle: Integer): Boolean;
begin
  Result := False;
  try
    SelPeer := TPeer(P2pAgent.GetMoniker(aHandle));
    if SelPeer = nil then Exit;
    Result := True;
  except
  end;
end;



procedure TfMain.FormCreate(Sender: TObject);
begin
  LoadForm;
  MyPeers := TObjectList.Create;

  P2pAgent := TBSP2PAgentX.Create(Self);
  P2pAgent.Parent := Self;

  P2pAgent.OnSessionOpen := doSessionOpen;
  P2pAgent.OnSessionClosed := doSessionClosed;
  P2pAgent.OnSessionRejected := doSessionRejected;
  P2pAgent.OnPeerConnected := GoPeerConnected;
  P2pAgent.OnPeerDisconnected := GoPeerDisconnected;

  P2pAgent.OnHaveAlertMessage := GoHaveAlertMessage;
  P2pAgent.OnHaveChatMessage := GoHaveChatMessage;

  P2pAgent.OnNeedListFolder := GoNeedFileList;
  P2pAgent.OnHaveFileItem := GoHaveFileItem;
  P2pAgent.OnListFolderDone := GoListDone;

  P2pAgent.OnNeedCreateFolder := GoNeedCreateFolder;
  P2pAgent.OnCreateFolderDone := GoCreateFolderDone;

  P2pAgent.OnNeedDeleteFolder := GoNeedDeleteFolder;
  P2pAgent.OnDeleteFolderDone := GoDeleteFolderDone;

  P2pAgent.OnNeedDeleteFile := GoNeedDeleteFile;
  P2pAgent.OnDeleteFileDone := GoDeleteFileDone;

  P2pAgent.OnNeedRenameFolder := GoNeedRenameFolder;
  P2pAgent.OnRenameFolderDone := GoRenameFolderDone;

  P2pAgent.OnNeedRenameFile := GoNeedRenameFile;
  P2pAgent.OnRenameFileDone := GoRenameFileDone;

  P2pAgent.OnNeedDownload := GoNeedDownload;
  P2pAgent.OnDownloadProgress := GoDownloadClientProgress;
  P2pAgent.OnClientDownloadDone := GoDownloadClientDone;
  P2pAgent.OnServerDownloadDone := GoDownloadServerDone;

  P2pAgent.OnNeedUpload := GoNeedUpload;
  P2pAgent.OnUploadProgress := GoUploadClientProgress;
  P2pAgent.OnClientUploadDone := GoClientUploadDone;
  P2pAgent.OnServerUploadDone := GoServerUploadDone;

  P2pAgent.OnNeedZip := GoNeedZip;
  P2pAgent.OnZipProgress := GoZipProgress;
  P2pAgent.OnClientZipDone := GoClientZipDone;
  P2pAgent.OnServerZipDone := GoServerZipDone;

  P2pAgent.OnNeedUnzip := GoNeedUnzip;
  P2pAgent.OnServerUnzipDone := GoServerUnzipDone;
  P2pAgent.OnUnzipProgress := GoUnzipProgress;
  P2pAgent.OnClientUnzipDone := GoClientUnzipDone;

  P2pAgent.OnNeedSearch := GoNeedSearch;
  P2pAgent.OnServerSearchDone := GoServerSearchDone;
  P2pAgent.OnHaveFindFile := GoHaveFindFile;
  P2pAgent.OnSearchProgress := GoSearchProgress;
  P2pAgent.OnClientSearchDone := GoClientSearchDone;

  UpdateStatus;
end;



procedure TfMain.FormDestroy(Sender: TObject);
begin
  SaveForm;
  MyPeers.Free;
end;


procedure TfMain.FormShow(Sender: TObject);
begin
  SetSettings;
end;


//Initializations
procedure TfMain.LoadForm;
var
  Ini: TIniFile;
begin
  try
    Ini := TIniFile.Create(ExtractFilePath(Application.ExeName)+'settings.ini');
  except
    Ini := nil;
  end;
  if Ini = nil then Exit;

  try
    with Ini do
    begin
      Left := ReadInteger('Last', 'Left', Left);
      Top := ReadInteger('Last', 'Top', Top);
    end;
  finally
    Ini.Free;
  end;
end;





procedure TfMain.SaveForm;
var
  Ini: TIniFile;
begin
  try
    Ini := TIniFile.Create(ExtractFilePath(Application.ExeName)+'settings.ini');
  except
    Ini := nil;
  end;
  if Ini = nil then Exit;

  try
    with Ini do
    begin
      WriteInteger('Last', 'Left', Left);
      WriteInteger('Last', 'Top', Top);
    end;
  finally
    Ini.Free;
  end;
end;




//Set the component properties
procedure TfMain.SetSettings;
begin
  P2pAgent.SecurityMode := fSettings.SecurityMode;
  P2pAgent.PublicKey := fSettings.mmPublic.Text;
  P2pAgent.PrivateKey := fSettings.mmPrivate.Text;
  P2pAgent.SecretKey := fSettings.edSecret.Text;
  P2pAgent.Fingerprints := fSettings.lstFingerprints.Items.CommaText;

  P2pAgent.ListeningPort := StrToIntDef(fSettings.edPort.Text, 0);
  P2pAgent.BindAddress := fSettings.edAddr.Text;
  P2pAgent.UseCompression := fSettings.cbxCompression.Checked;

  P2pAgent.SocksServer         := Trim(fSettings.edSocksServer.Text);
  P2pAgent.SocksPort           := StrToIntDef(fSettings.edSocksPort.Text, 0);
  P2pAgent.SocksUsername       := Trim(fSettings.edSocksUser.Text);
  P2pAgent.SocksPassword       := Trim(fSettings.edSocksPass.Text);
  if fSettings.radSocks5.Checked then
    P2pAgent.SocksVersion := 5
  else
    P2pAgent.SocksVersion := 4;


  UpdateStatus;
end;



//Display an error message, if any
procedure TfMain.CheckError(aCode: Integer);
begin
  if aCode = 0 then Exit;
  MessageBox(Handle, PChar(bsErrorDescription(aCode)), 'Error', MB_OK or MB_ICONERROR);
end;




//Update the button state and the status text
procedure TfMain.UpdateStatus;
begin
  if P2pAgent.SessionOpen then
  begin
    //already connected
    btnConnect.Enabled := False;
    btnCancel.Enabled := False;
    btnDisconnect.Enabled := True;
    StatusBar.Panels[0].Text := ' Session open';
    StatusBar.Panels[1].Text := ' Hub: ' + P2pAgent.HubAddress + ':' + IntToStr(P2pAgent.HubPort);
    if P2pAgent.Username > '' then
      StatusBar.Panels[2].Text := ' User: ' + P2pAgent.Username
    else
      StatusBar.Panels[2].Text := ' User: not signed in';
  end
  else
  begin
    StatusBar.Panels[1].Text := '';
    StatusBar.Panels[2].Text := '';

    if P2pAgent.SessionCall then
    begin
      //now connecting
      btnConnect.Enabled := False;
      btnCancel.Enabled := True;
      btnDisconnect.Enabled := False;
      StatusBar.Panels[0].Text := ' Connecting to the hub';
    end
    else
    begin
      //not connected
      btnConnect.Enabled := True;
      btnCancel.Enabled := False;
      btnDisconnect.Enabled := False;
      StatusBar.Panels[0].Text := ' Session closed';
    end;
  end;

  UpdateButtons;
end;



procedure TfMain.UpdateButtons;
begin
  btnAlert.Enabled := lvPeers.Items.Count > 0;
  btnChat.Enabled := lvPeers.SelCount > 0;
  btnFiles.Enabled := lvPeers.SelCount > 0;
  btnSearch.Enabled := lvPeers.SelCount > 0;
  btnRemove.Enabled := lvPeers.SelCount > 0;
end;




procedure TfMain.lvPeersChange(Sender: TObject; Item: TListItem;
  Change: TItemChange);
begin
  if Change <> ctState then Exit;
  UpdateButtons;
end;



procedure TfMain.DeletePeer(aPeer: TPeer);
begin
  if aPeer = nil then Exit;
//  LogMsg('Remove user ' + aPeer.Username + ' ' + P2pHub.GetRemoteAddress(aPeer.Handle) + ':' + IntToStr(P2pHub.GetRemotePort(aPeer.Handle)));
  P2pAgent.RemovePeer(aPeer.Handle);
  lvPeers.Items.Delete(aPeer.ListItem.Index);
  aPeer.fChat.Free;
  aPeer.fFiles.Free;
  MyPeers.Remove(aPeer);
end;





// <<< Peer events


//Hub is just connected
procedure TfMain.doSessionOpen(Sender: TObject);
begin
  UpdateStatus;
  LogMsg('Connected to the hub ' + P2pAgent.HubAddress + ':' + IntToStr(P2pAgent.HubPort));
end;


//Hub is just disconnected
procedure TfMain.doSessionClosed(Sender: TObject);
begin
//  lvFiles.Enabled := False;
//  pnlFolder.Caption := '';
//  lvFiles.Clear;

  UpdateStatus;
  LogMsg('Disconnected from the hub');
end;


//Unsuccessful call
procedure TfMain.doSessionRejected(Sender: TObject);
begin
  LogMsg('Cannot open a session to' + fConnect.edHost.Text + ':' + fConnect.edHubPort.Text + '   Error- ' + bsErrorDescription(P2pAgent.LastError));
  ShowMessage('Cannot open the session!'#13#13'Error: ' + bsErrorDescription(P2pAgent.LastError));
  UpdateStatus;
end;



//A new peer is just connected
procedure TfMain.GoPeerConnected(Sender: TObject; aHandle: Integer);
var
  LI: TListItem;
  Pr: TPeer;
begin
  Pr := TPeer.Create;
  MyPeers.Add(Pr);
  Pr.Handle := aHandle;
  Pr.Username := UN(P2pAgent.GetPeerName(Pr.Handle));
  P2pAgent.SetIncomingBandwidth(aHandle, StrToIntDef(fSettings.edIncomingBandwidth.Text, 0));
  P2pAgent.SetOutgoingBandwidth(aHandle, StrToIntDef(fSettings.edOutgoingBandwidth.Text, 0));

  Application.CreateForm(TfChat, Pr.fChat);
  TfChat(Pr.fChat).Peer := Pr;
  Pr.fChat.Caption := 'Chat with ' + Pr.Username;

  Application.CreateForm(TfFiles, Pr.fFiles);
  TfFiles(Pr.fFiles).Peer := Pr;
  Pr.fFiles.Caption := Pr.Username + '''s shared files';

  Application.CreateForm(TfSearch, Pr.fSearch);
  TfSearch(Pr.fSearch).Peer := Pr;
  Pr.fSearch.Caption := 'Search in ' + Pr.Username + '''s files';

  LI := lvPeers.Items.Add;
  LI.Data := Pointer(Pr);
  Pr.ListItem := LI;

  LI.Caption := UN(Pr.Username);
  LI.Subitems.Add(P2pAgent.GetPeerAddress(aHandle));
  LI.Subitems.Add(IntToStr(P2pAgent.GetPeerPort(aHandle)));
  LI.Subitems.Add(TimeToStr(Now));
  P2pAgent.SetMoniker(aHandle, Integer(Pr));

  if lvPeers.Items.Count = 1 then
    lvPeers.Items[0].Selected := True;

  UpdateStatus;
  LogMsg('New peer at ' + LI.SubItems[0] + ':' + LI.SubItems[1]);
end;



//A peer is just disconnected
procedure TfMain.GoPeerDisconnected(Sender: TObject; aHandle: Integer);
var
  Pr: TPeer;
begin
  Pr := TPeer(P2pAgent.GetMoniker(aHandle));
  if Pr = nil then Exit;
  LogMsg('Disconnected peer ' + Pr.ListItem.Caption + ' ' + Pr.ListItem.SubItems[0] + ':' + IntToStr(P2pAgent.GetPeerPort(aHandle)));
  DeletePeer(Pr);
end;





// <<< list files

//Open the file browser
procedure TfMain.btnFilesClick(Sender: TObject);
begin
  ShowForm(TPeer(lvPeers.Selected.Data).fFiles);
end;


//A request to list the folder is received (server module)
procedure TfMain.GoNeedFileList(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arList);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': list folder ' + PreSlash(aPath));
end;



//A file item is received
procedure TfMain.GoHaveFileItem(Sender: TObject; aHandle: Integer; const aName: WideString; aFolder:WordBool; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).HaveFileItem(aName, aFolder, aSizeLo, aSizeHi, aTimeLo, aTimeHi);
end;



//The whole folder contents is received (client module)
procedure TfMain.GoListDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).ListDone(aCode);
end;


// >>> list files


// <<< create folder


//A request to create a folder is received (server module)
procedure TfMain.GoNeedCreateFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arCreateFolder);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': list folder ' + PreSlash(aPath));
end;

//The folder creation is completed (client module)
procedure TfMain.GoCreateFolderDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).CreateFolderDone(aCode);
end;

// >>> create folder


// <<< rename folder


//A request to rename a folder is received
procedure TfMain.GoNeedRenameFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arRenameFolder);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': rename folder ' + PreSlash(aPath));
end;


//The folder renaming is completed (client module)
procedure TfMain.GoRenameFolderDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).RenameFolderDone(aCode);
end;


// <<< rename file


//A request to rename a file is received (server module)
procedure TfMain.GoNeedRenameFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arRenameFile);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': rename file ' + PreSlash(aPath));
end;


//The file renaming is completed (client module)
procedure TfMain.GoRenameFileDone(Sender: TObject;  aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).RenameFileDone(aCode);
end;


// <<< delete folder


//A request to delete a folder is received (server module)
procedure TfMain.GoNeedDeleteFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arDeleteFolder);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': delete folder ' + PreSlash(aPath));
end;


//The folder deletion is completed (client module)
procedure TfMain.GoDeleteFolderDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).DeleteFolderDone(aCode);
end;



// <<< delete file


//A request to delete a file is received (server module)
procedure TfMain.GoNeedDeleteFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arDeleteFile);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': delete file ' + PreSlash(aPath));
end;



//The file deletion is completed (client module)
procedure TfMain.GoDeleteFileDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).DeleteFileDone(aCode);
end;





// <<< downloading


//A request to download is received (server module)
procedure TfMain.GoNeedDownload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arDownload);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': start downloading ' + PreSlash(aPath));
end;



//The download operation is completed (server module)
procedure TfMain.GoDownloadServerDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  LogMsg(UN(SelPeer.Username) + ': finished download - ' + bsErrorDescription(aCode));
end;


//The download operation is completed (client module)
procedure TfMain.GoDownloadClientDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).DownloadDone(aCode);
end;


//New progress information is available for the download operation (client module)
procedure TfMain.GoDownloadClientProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).DownloadProgress(aCountLo, aCountHi, aSizeLo, aSizeHi);
end;




//  *** uploading ***


//A request to upload a file is received (server module)
procedure TfMain.GoNeedUpload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arUpload);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': start uploading ' + PreSlash(aPath));
end;


//The upload operation is completed (server module)
procedure TfMain.GoServerUploadDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  LogMsg(UN(SelPeer.Username) + ': finished upload - ' + bsErrorDescription(aCode));
end;


//New progress information is available for the upload operation (client module)
procedure TfMain.GoUploadClientProgress(Sender: TObject; aHandle, aCountLo, aCountHi, aSizeLo, aSizeHi: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).UploadProgress(aCountLo, aCountHi, aSizeLo, aSizeHi);
end;


//The upload operation is completed (client module)
procedure TfMain.GoClientUploadDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).UploadDone(aCode);
end;



// <<< zipping

//A request to zip a file is received (server module)
procedure TfMain.GoNeedZip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arZip);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': start zipping ' + PreSlash(aPath));
end;


//The zip operation is completed (server module)
procedure TfMain.GoServerZipDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  LogMsg(UN(SelPeer.Username) + ': finished zip - ' + bsErrorDescription(aCode));
end;


//The zip operation is completed (client module)
procedure TfMain.GoClientZipDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).ZipDone(aCode);
end;


//New progress information is available for the zip operation (client module)
procedure TfMain.GoZipProgress(Sender: TObject; aHandle, aFileCount, aFileTotal, aByteCountLo, aByteCountHi, aByteTotalLo, aByteTotalHi: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).ZipProgress(aFileCount, aFileTotal, aByteCountLo, aByteCountHi, aByteTotalLo, aByteTotalHi);
end;









// <<< unzipping



//A request to unzip a file is received
procedure TfMain.GoNeedUnzip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arUnzip);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': start unzipping ' + PreSlash(aPath));
end;


//The unzip operation is completed (server module)
procedure TfMain.GoServerUnzipDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  LogMsg(UN(SelPeer.Username) + ': finished unzip - ' + bsErrorDescription(aCode));
end;


//New progress information is available for the unzip operation (client module)
procedure TfMain.GoUnzipProgress(Sender: TObject; aHandle, aFileCount, aFileTotal, aByteCountLo, aByteCountHi, aByteTotalLo, aByteTotalHi: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).UnzipProgress(aFileCount, aFileTotal, aByteCountLo, aByteCountHi, aByteTotalLo, aByteTotalHi);
end;


//The unzip operation is completed (client module)
procedure TfMain.GoClientUnzipDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfFiles(SelPeer.fFiles).UnzipDone(aCode);
end;








// <<< Search


//*** client

procedure TfMain.btnSearchClick(Sender: TObject);
begin
  ShowForm(TPeer(lvPeers.Selected.Data).fSearch);
end;


//The search operation is completed (client module)
procedure TfMain.GoClientSearchDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfSearch(SelPeer.fSearch).SearchDone(aCode);
end;

//A new file item has been found (client module)
procedure TfMain.GoHaveFindFile(Sender: TObject; aHandle: Integer; const aName: WideString; aSizeLo, aSizeHi, aTimeLo, aTimeHi: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfSearch(SelPeer.fSearch).HaveFindFile(aName, aSizeLo, aSizeHi, aTimeLo, aTimeHi);
end;


//New progress information is available for the search operation (client module)
procedure TfMain.GoSearchProgress(Sender: TObject; aHandle, aCount: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  TfSearch(SelPeer.fSearch).SearchProgress(aCount);
end;



//*** server


//A request to search for files is received
procedure TfMain.GoNeedSearch(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  aOkay := fRights.HasRight(SelPeer.Username, arSearch);
  if not aOkay then Exit;
  aRoot := fRights.GetRoot(SelPeer.Username);
  LogMsg(UN(SelPeer.Username) + ': start searching in ' + PreSlash(aPath));
end;

//The search operation is completed (client module)
procedure TfMain.GoServerSearchDone(Sender: TObject; aHandle, aCode: Integer);
begin
  if not SelectPeer(aHandle) then Exit;
  LogMsg(UN(SelPeer.Username) + ': finished search - ' + bsErrorDescription(aCode));
end;




// >>> Search




// <<< ALerts


//Send an alert message
procedure TfMain.btnAlertClick(Sender: TObject);
var
  i: Integer;
begin
  fAlert.mmText.Text := '';
  if lvPeers.SelCount > 0 then
  begin
    fAlert.raSingle.Caption := 'User ' + lvPeers.Selected.Caption;
    fAlert.raSingle.Enabled := True;
    fAlert.raSingle.Checked := True;
  end
  else
  begin
    fAlert.raAll.Checked := True;
    fAlert.raSingle.Caption := 'Single user';
    fAlert.raSingle.Enabled := False;
  end;

  if fAlert.ShowModal <> mrOk then Exit;

  if fAlert.raSingle.Checked then
    P2pAgent.SendAlertMessage(TPeer(lvPeers.Selected.Data).Handle, fAlert.mmText.Text)
  else
  begin
    for i := lvPeers.Items.Count-1 downto 0 do
      P2pAgent.SendAlertMessage(TPeer(lvPeers.Items[i].Data).Handle, fAlert.mmText.Text);
  end;
end;



//An alert message is received
procedure TfMain.GoHaveAlertMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
begin
  MessageBox(0, PChar(String(aMessage)), PChar('Alert from ' + UN(P2pAgent.GetPeerName(aHandle))), MB_OK or MB_ICONWARNING or MB_SYSTEMMODAL);
end;


// >>> ALerts




// <<< Chat

//Open a chat session
procedure TfMain.btnChatClick(Sender: TObject);
begin
  ShowForm(TPeer(lvPeers.Selected.Data).fChat);
end;


//A chat message is received
procedure TfMain.GoHaveChatMessage(Sender: TObject; aHandle: Integer; const aMessage: WideString);
begin
  if not SelectPeer(aHandle) then Exit;
  TfChat(SelPeer.fChat).HaveChatMessage(aMessage);
end;


// >>> Chat



// <<<  Misc button clicks


//Open a new session
procedure TfMain.btnConnectClick(Sender: TObject);
begin
  if fConnect.ShowModal <> mrOk then Exit;
  if not P2pAgent.OpenSession(
    fConnect.edHost.Text,
    StrToIntDef(fConnect.edHubPort.Text, 0),
    fConnect.edUsername.Text,
    fConnect.edPassword.Text) then
      ShowMessage('Cannot initiate a new session: ' + IntToStr(P2pAgent.LastError));
  UpdateStatus;
end;


//Cancel the session call
procedure TfMain.btnCancelClick(Sender: TObject);
begin
  if not P2pAgent.SessionCall then Exit;
  P2pAgent.CloseSession;
end;


//Close an open session
procedure TfMain.btnDisconnectClick(Sender: TObject);
begin
  P2pAgent.CloseSession;
end;


//Remove a connected peer
procedure TfMain.btnRemoveClick(Sender: TObject);
begin
  if lvPeers.SelCount = 0 then Exit;
  DeletePeer(TPeer(lvPeers.Selected.Data));
end;





procedure TfMain.btnClearLogClick(Sender: TObject);
begin
  mmLog.Clear;
end;


procedure TfMain.btnSettingsClick(Sender: TObject);
begin
  if fSettings.ShowModal <> mrOk then Exit;
  SetSettings;
end;


procedure TfMain.btnUsersClick(Sender: TObject);
begin
  fRights.Ask;
end;


procedure TfMain.btnExitClick(Sender: TObject);
begin
  Application.Terminate;
end;


procedure TfMain.btnAboutClick(Sender: TObject);
begin
  fAbout.ShowModal;
end;


//Show my IP
procedure TfMain.btnMyIPClick(Sender: TObject);
begin
  ShowMessage(P2pAgent.LocalIPList);
end;

end.


© BigSpeed Computing Inc. - Secure private networking