© 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