// *** Delphi example of secure private video chat server ***


unit uMain;


interface

uses
  ActiveX, Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ComCtrls, ToolWin, Menus, ActnList, ImgList, StrUtils, Contnrs,
  ExtCtrls, Registry, Variants, ShellAPI, Buttons, IniFiles,
  bsErrors, bsVidChatSrv_TLB;

type
  TPeer = class
    Handle: Integer;
    Username: WideString;
    ListItem: TListItem;
    UpFileName, DnFileName: String;
    UpFileHandle, UpFileSize, UpFileCount: Integer;
    DnFileHandle, DnFileSize, DnFileCount: Integer;
    UpFileItem, DnFileItem: TListItem;
  end;


  TfMain = class(TForm)
    StatusBar: TStatusBar;
    GroupBox2: TGroupBox;
    btnRemove: TButton;
    lvPeers: TListView;
    GroupBox3: TGroupBox;
    mmLog: TMemo;
    btnClearLog: TButton;
    GroupBox1: TGroupBox;
    btnStart: TButton;
    btnStop: TButton;
    btnSettings: TButton;
    btnUsers: TButton;
    btnMyIP: TButton;
    btnAbout: TButton;
    btnExit: TButton;

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

    procedure btnExitClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
    procedure btnMyIPClick(Sender: TObject);
    procedure lvPeersChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure FormShow(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
    procedure btnSettingsClick(Sender: TObject);
    procedure btnUsersClick(Sender: TObject);
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);

  private
    { Private declarations }

    MyPeers: TObjectList;

    procedure LoadForm;
    procedure SaveForm;
    procedure SetSettings;
    procedure LogMsg(aText: String);
    procedure UpdateStatus;
    procedure RemovePeer(aPeer: TPeer);


    //Event handlers
    procedure GoConnectionRequest(Sender: TObject; aHandle: Integer; const aUsername: WideString; var aPassword: WideString; var aAction: Integer);
    procedure GoPeerConnected(Sender: TObject; aHandle: Integer);
    procedure GoPeerRejected(Sender: TObject; aHandle: Integer; aCode: Integer);
    procedure GoPeerDisconnected(Sender: TObject; aHandle: Integer);
  public
    { Public declarations }

    VidSrv: TbsVidChatSrvX;
  end;

var
  fMain: TfMain;



implementation

uses uAbout, uSettings, uAdd, uAccess;

{$R *.DFM}



// *** Misc



//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 name
function UN(aName: WideString): String;
begin
  Result := aName;
  if Result > '' then Exit;
  Result := 'Guest';
end;



// *** General

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

  VidSrv.OnConnectionRequest := GoConnectionRequest;
  VidSrv.OnPeerConnected := GoPeerConnected;
  VidSrv.OnPeerRejected := GoPeerRejected;
  VidSrv.OnPeerDisconnected := GoPeerDisconnected;
end;







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


procedure TfMain.FormShow(Sender: TObject);
begin
  SetSettings;
  btnStart.Click;
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
  VidSrv.ListeningPort := StrToIntDef(fSettings.edPort.Text, 0);

  VidSrv.ListeningPort := StrToIntDef(fSettings.edPort.Text, 0);
  VidSrv.SecurityMode := fSettings.SecurityMode;
  VidSrv.PublicKey := fSettings.mmPublic.Text;
  VidSrv.PrivateKey := fSettings.mmPrivate.Text;
  VidSrv.SecretKey := fSettings.edSecret.Text;
  VidSrv.Fingerprints := fSettings.lstFingerprints.Items.CommaText;

  VidSrv.ListeningPort := StrToIntDef(fSettings.edPort.Text, 0);
  VidSrv.BindAddress := fSettings.edSrvAddr.Text;

  UpdateStatus;
end;



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



//Update the status text
procedure TfMain.UpdateStatus;
begin
  if VidSrv.Running then
  begin
    StatusBar.Panels[0].Text := ' Started';
    btnStart.Enabled := False;
    btnStop.Enabled := True;
  end
  else
  begin
    StatusBar.Panels[0].Text := ' Stopped';
    btnStart.Enabled := True;
    btnStop.Enabled := False;
  end;

  if lvPeers.Items.Count = 0 then
    StatusBar.Panels[1].Text := ' No active connection'
  else
    StatusBar.Panels[1].Text := ' ' + IntToStr(lvPeers.Items.Count) + ' connection(s)';
end;




procedure TfMain.RemovePeer(aPeer: TPeer);
begin
  if aPeer = nil then Exit;
  lvPeers.Items.Delete(aPeer.ListItem.Index);
  MyPeers.Remove(aPeer);
end;








//*** Hide log box caret



//************  User Events



//Start the server
procedure TfMain.btnStartClick(Sender: TObject);
begin
  if VidSrv.Start then
    LogMsg('server is started')
  else
    ShowMessage('Cannot start the server!');
  UpdateStatus;
end;


//Stop the server
procedure TfMain.btnStopClick(Sender: TObject);
var
  Pr: TPeer;
  i: Integer;
begin
  VidSrv.Stop;

  for i := lvPeers.Items.Count-1 downto 0 do
  begin
    Pr := TPeer(lvPeers.Items[i].Data);
    VidSrv.DisconnectPeer(Pr.Handle);
//    RemovePeer(Pr);
  end;

  UpdateStatus;
  LogMsg('server is stopped');
end;


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


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


procedure TfMain.btnMyIPClick(Sender: TObject);
begin
  ShowMessage(VidSrv.LocalIPList);
end;


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


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



procedure TfMain.lvPeersChange(Sender: TObject; Item: TListItem; Change: TItemChange);
begin
  if Change <> ctState then Exit;
  btnRemove.Enabled := lvPeers.SelCount = 1;
  UpdateStatus;
end;




//Remove a peer connection
procedure TfMain.btnRemoveClick(Sender: TObject);
var
  Pr: TPeer;
begin
  if lvPeers.Selected = nil then Exit;
  Pr := TPeer(lvPeers.Selected.Data);
  VidSrv.DisconnectPeer(Pr.Handle);
//  RemovePeer(Pr);
end;







// *** Peer events



//A request for a session
procedure TfMain.GoConnectionRequest(Sender: TObject; aHandle: Integer; const aUsername: WideString; var aPassword: WideString; var aAction: Integer);
begin
  aAction := 1;
  aPassword := fAccess.GetPassword(aUsername);
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;

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

  LI.Caption := UN(VidSrv.GetPeerName(aHandle));
  LI.Subitems.Add(VidSrv.GetPeerAddress(aHandle));
  LI.Subitems.Add(IntToStr(VidSrv.GetPeerPort(aHandle)));
  LI.Subitems.Add(TimeToStr(Now));
  LI.Subitems.Add('Connected');
  VidSrv.SetMoniker(aHandle, Integer(Pr));
  UpdateStatus;
  LogMsg('New peer at ' + LI.SubItems[0] + ':' + LI.SubItems[1]);
end;


//A connection is rejected
procedure TfMain.GoPeerRejected(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg('Rejected peer from ' + VidSrv.GetPeerAddress(aHandle) + ':' + IntToStr(VidSrv.GetPeerPort(aHandle)) + '   Error: ' + bsErrorDescription(aCode));
end;



//A connection is broken
procedure TfMain.GoPeerDisconnected(Sender: TObject; aHandle: Integer);
var
  Pr: TPeer;
begin
  Pr := TPeer(VidSrv.GetMoniker(aHandle));
  if Pr = nil then Exit;
  LogMsg('Disconnected peer ' + Pr.Username + ' ' + VidSrv.GetPeerAddress(aHandle) + ':' + IntToStr(VidSrv.GetPeerPort(aHandle)));
  RemovePeer(Pr);
end;


end.