// *** Delphi 7 example of secure file sharing 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,
  bsFileSrvLib_TLB;

const
  WM_MYMEMO_ENTER = WM_USER + 500;

type

  TClient = 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;
    GroupBox3: TGroupBox;
    mmLog: TMemo;
    GroupBox2: TGroupBox;
    lvClients: TListView;
    btnRemove: TButton;
    btnClearLog: TButton;
    CoolBar1: TCoolBar;
    ToolBar1: TToolBar;
    ToolButton3: TToolButton;
    ToolButton2: TToolButton;
    ToolButton4: TToolButton;
    ToolButton5: TToolButton;
    btnStart: TToolButton;
    btnStop: TToolButton;
    btnSettings: TToolButton;
    btnUsers: TToolButton;
    ToolButton1: TToolButton;

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

    procedure btnExitClick(Sender: TObject);
    procedure btnAboutClick(Sender: TObject);
    procedure btnSettingsClick(Sender: TObject);
    procedure btnMyIPClick(Sender: TObject);
    procedure lvClientsChange(Sender: TObject; Item: TListItem; Change: TItemChange);
    procedure btnStartClick(Sender: TObject);
    procedure btnStopClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
    procedure mmLogChange(Sender: TObject);
    procedure mmLogEnter(Sender: TObject);
    procedure mmLogExit(Sender: TObject);
    procedure btnClearLogClick(Sender: TObject);
    procedure btnUsersClick(Sender: TObject);

  private
    { Private declarations }

    FileSrv: TBSFileSrvX;
    MyClients: TObjectList;

    procedure WMMYMEMOENTER(var Message: TMessage); message WM_MYMEMO_ENTER;
    procedure LoadForm;
    procedure SaveForm;
    procedure SetProperties;
    procedure LogMsg(aText: String);
    procedure UpdateStatus;
    procedure RemoveClient(aCln: TClient);


    //Event handlers
    procedure doNewClient(Sender: TObject; aHandle: Integer);
    procedure doClientDisconnected(Sender: TObject; aHandle: Integer);
    procedure doKeyChanged(Sender: TObject; aHandle: Integer);
    procedure doSignin(Sender: TObject; aHandle, aCode: Integer);
    procedure doSignout(Sender: TObject; aHandle: Integer);
    procedure doNeedPassword(Sender: TObject; aHandle: Integer; const aUsername: WideString; var aOkay: WordBool; var aPassword: WideString);
    procedure doNeedList(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doNeedCreateFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doNeedDeleteFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doNeedDeleteFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doNeedRenameFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doNeedRenameFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doNeedDownload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doDownloadDone(Sender: TObject; aHandle: Integer; aCode: Integer);
    procedure doNeedUpload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doUploadDone(Sender: TObject; aHandle: Integer; aCode: Integer);
    procedure doNeedOpenStream(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doStreamClosed(Sender: TObject; aHandle: Integer; aCode: Integer);
    procedure doNeedZip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doZipDone(Sender: TObject; aHandle: Integer; aCode: Integer);
    procedure doNeedUnzip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doUnzipDone(Sender: TObject; aHandle: Integer; aCode: Integer);
    procedure doNeedSearch(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
    procedure doSearchDone(Sender: TObject; aHandle: Integer; aCode: Integer);

  public
    { Public declarations }
  end;

var
  fMain: TfMain;



implementation

uses uAbout, uSettings, uAdd, uUsers;

{$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;


//Set a name to the default user
function DUN(aName: WideString): String;
begin
  Result := aName;
  if Result > '' then Exit;
  Result := 'default user';
end;



// *** General

procedure TfMain.FormCreate(Sender: TObject);
begin
  LoadForm;

  MyClients := TObjectList.Create;
  try
    FileSrv := TBSFileSrvX.Create(Self);
    FileSrv.Parent := Self;
    FileSrv.OnNewClient := doNewClient;
    FileSrv.OnClientDisconnected := doClientDisconnected;
    FileSrv.OnKeyChanged := doKeyChanged;
    FileSrv.OnSignin := doSignin;
    FileSrv.OnSignout := doSignout;
    FileSrv.OnNeedPassword := doNeedPassword;
    FileSrv.OnNeedListFolder := doNeedList;
    FileSrv.OnNeedCreateFolder := doNeedCreateFolder;
    FileSrv.OnNeedDeleteFolder := doNeedDeleteFolder;
    FileSrv.OnNeedDeleteFile := doNeedDeleteFile;
    FileSrv.OnNeedRenameFolder := doNeedRenameFolder;
    FileSrv.OnNeedRenameFile := doNeedRenameFile;
    FileSrv.OnNeedDownload := doNeedDownload;
    FileSrv.OnDownloadDone := doDownloadDone;
    FileSrv.OnNeedUpload := doNeedUpload;
    FileSrv.OnUploadDone := doUploadDone;
    FileSrv.OnNeedOpenStream := doNeedOpenStream;
    FileSrv.OnStreamClosed := doStreamClosed;
    FileSrv.OnNeedZip := doNeedZip;
    FileSrv.OnZipDone := doZipDone;
    FileSrv.OnNeedUnzip := doNeedUnzip;
    FileSrv.OnUnzipDone := doUnzipDone;
    FileSrv.OnNeedSearch := doNeedSearch;
    FileSrv.OnSearchDone := doSearchDone;
  except
    MessageDlg('BigSpeed File Server control is not registered on your system!', mtError, [mbOk], 0);
    Halt;
  end;
end;







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


procedure TfMain.FormShow(Sender: TObject);
begin
  SetProperties;
  btnStart.Click;
end;




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;



procedure TfMain.SetProperties;
begin
  FileSrv.ListeningPort := fSettings.edPort.Text;
  FileSrv.CryptoKey := fSettings.edKey.Text;
  FileSrv.UseCompression := fSettings.cbxCompression.Checked;
end;



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



//Update the status text
procedure TfMain.UpdateStatus;
begin
  if FileSrv.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 lvClients.Items.Count = 0 then
    StatusBar.Panels[1].Text := ' No active connection'
  else
    StatusBar.Panels[1].Text := ' ' + IntToStr(lvClients.Items.Count) + ' connection(s)';
end;



procedure TfMain.RemoveClient(aCln: TClient);
begin
  if aCln = nil then Exit;
  LogMsg('Remove user ' + aCln.Username + ' ' + FileSrv.GetClientAddress(aCln.Handle) + ':' + FileSrv.GetClientPort(aCln.Handle));
  FileSrv.RemoveClient(aCln.Handle);
  lvClients.Items.Delete(aCln.ListItem.Index);
  MyClients.Remove(aCln);
end;








//*** Hide log box caret

procedure TfMain.WMMYMEMOENTER(var Message: TMessage) ;
begin
   CreateCaret(mmLog.Handle,0,0,0) ;
end;

procedure TfMain.mmLogChange(Sender: TObject);
begin
  CreateCaret(mmLog.handle,0,0,0);
end;

procedure TfMain.mmLogEnter(Sender: TObject);
begin
  PostMessage(Handle, WM_MYMEMO_ENTER, 0, 0);
end;

procedure TfMain.mmLogExit(Sender: TObject);
begin
  CreateCaret(mmLog.handle,1,1,1);
end;





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


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


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


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



procedure TfMain.btnMyIPClick(Sender: TObject);
begin
  ShowMessage(FileSrv.LocalIP);
end;


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


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


//Stop the server
procedure TfMain.btnStopClick(Sender: TObject);
var
  Cln: TClient;
  i: Integer;
begin
  FileSrv.Stop;

  for i := lvClients.Items.Count-1 downto 0 do
  begin
    Cln := TClient(lvClients.Items[i].Data);
    RemoveClient(Cln);
  end;

  UpdateStatus;
  LogMsg('Server stopped');
end;


//Remove a client connection
procedure TfMain.btnRemoveClick(Sender: TObject);
var
  Cln: TClient;
begin
  if lvClients.Selected = nil then Exit;
  Cln := TClient(lvClients.Selected.Data);
  RemoveClient(Cln);
end;

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

//Edit the user's rights
procedure TfMain.btnUsersClick(Sender: TObject);
begin
  fUsers.Ask;
end;






// *** Client events


//A new connection is available
procedure TfMain.doNewClient(Sender: TObject; aHandle: Integer);
var
  LI: TListItem;
  Cln: TClient;
begin
  Cln := TClient.Create;
  MyClients.Add(Cln);
  Cln.Handle := aHandle;

  LI := lvClients.Items.Add;
  LI.Data := Pointer(Cln);
  Cln.ListItem := LI;

  LI.Caption := 'Not signed in';
  LI.Subitems.Add(FileSrv.GetClientAddress(aHandle));
  LI.Subitems.Add(FileSrv.GetClientPort(aHandle));
  LI.Subitems.Add(TimeToStr(Now));
  LI.Subitems.Add('Connected');
  FileSrv.SetMoniker(aHandle, Integer(Cln));
  UpdateStatus;
  LogMsg('New connection from ' + LI.SubItems[0] + ':' + LI.SubItems[1]);
end;


//A connection is broken
procedure TfMain.doClientDisconnected(Sender: TObject; aHandle: Integer);
var
  Cln: TClient;
begin
  Cln := TClient(FileSrv.GetMoniker(aHandle));
  if Cln = nil then Exit;
  LogMsg('Disconnected ' + Cln.Username + ' ' + FileSrv.GetClientAddress(aHandle) + ':' + FileSrv.GetClientPort(aHandle));
  RemoveClient(Cln);
end;


//Key matching is changed
procedure TfMain.doKeyChanged(Sender: TObject; aHandle: Integer);
var
  Cln: TClient;
begin
  Cln := TClient(FileSrv.GetMoniker(aHandle));
  if Cln = nil then Exit;
  LogMsg('Key changed for ' + Cln.Username + ' ' + FileSrv.GetClientAddress(aHandle) + ':' + FileSrv.GetClientPort(aHandle));
  if FileSrv.WrongKey(Cln.Handle) then
    Cln.ListItem.Subitems[3] := 'Wrong key'
  else
    Cln.ListItem.Subitems[3] := 'Connected';
end;


//An user is signed-in
procedure TfMain.doSignin(Sender: TObject; aHandle, aCode: Integer);
var
  Cln: TClient;
  S: String;
begin
  Cln := TClient(FileSrv.GetMoniker(aHandle));
  if Cln = nil then Exit;
  Cln.Username := DUN(FileSrv.GetUserName(aHandle));
  Cln.ListItem.Caption := Cln.Username;
  S :=  'User ' + Cln.Username + ' ' + FileSrv.GetClientAddress(aHandle) + ':' + FileSrv.GetClientPort(aHandle);

  if aCode = 0 then
    S := S + ' signed in successfully'
  else
    S := S + ' failed sign-in';

  LogMsg(S);
end;


//An user is signed-out
procedure TfMain.doSignout(Sender: TObject; aHandle: Integer);
var
  Cln: TClient;
  S: String;
begin
  Cln := TClient(FileSrv.GetMoniker(aHandle));
  if Cln = nil then Exit;
  S :=  'User ' + Cln.ListItem.Caption + ' ' + FileSrv.GetClientAddress(aHandle) + ':' + FileSrv.GetClientPort(aHandle);
  S := S + ' signed out';
  LogMsg(S);
  Cln.ListItem.Caption := 'Not signed in';
end;


//Request for a password
procedure TfMain.doNeedPassword(Sender: TObject; aHandle: Integer; const aUsername: WideString; var aOkay: WordBool; var aPassword: WideString);
begin
  aOkay := fUsers.GetPassword(aUsername, aPassword);
end;


//Request to list the folder content
procedure TfMain.doNeedList(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arList);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': list folder ' + PreSlash(aPath));
end;


//Request to create a folder
procedure TfMain.doNeedCreateFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arCreateFolder);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': create folder ' + aPath);
end;


//Request to delete a folder
procedure TfMain.doNeedDeleteFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arDeleteFolder);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': delete folder ' + aPath);
end;


//Request to delete a file
procedure TfMain.doNeedDeleteFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arDeleteFile);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': delete file ' + aPath);
end;


//Request to rename a folder
procedure TfMain.doNeedRenameFolder(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arRenameFolder);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': rename folder ' + aPath);
end;


//Request to rename a file
procedure TfMain.doNeedRenameFile(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arRenameFile);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': rename file ' + aPath);
end;


//Request to download
procedure TfMain.doNeedDownload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arDownload);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': start downloading ' + aPath);
end;


//Download is completed
procedure TfMain.doDownloadDone(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg(DUN(FileSrv.GetUserName(aHandle)) + ': finish downloading - ' + IntToStr(aCode));
end;


//Request to upload
procedure TfMain.doNeedUpload(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arUpload);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': start uploading ' + aPath);
end;


//Upload is completed
procedure TfMain.doUploadDone(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg(DUN(FileSrv.GetUserName(aHandle)) + ': finish uploading - ' + IntToStr(aCode));
end;


//Request to open a stream
procedure TfMain.doNeedOpenStream(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arOpenStream);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': open stream ' + aPath);
end;


//Stream is closed
procedure TfMain.doStreamClosed(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg(DUN(FileSrv.GetUserName(aHandle)) + ': stream closed');
end;


//Request to zip
procedure TfMain.doNeedZip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arZip);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': start zipping to ' + aPath);
end;


//Zip is completed
procedure TfMain.doZipDone(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg(DUN(FileSrv.GetUserName(aHandle)) + ': finish zipping - ' + IntToStr(aCode));
end;


//Request to unzip
procedure TfMain.doNeedUnzip(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arUnzip);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': start unzipping from ' + aPath);
end;


//Unzip is completed
procedure TfMain.doUnzipDone(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg(DUN(FileSrv.GetUserName(aHandle)) + ': finish unzipping - ' + IntToStr(aCode));
end;


//Request to search
procedure TfMain.doNeedSearch(Sender: TObject; aHandle: Integer; const aPath: WideString; var aOkay: WordBool; var aRoot: WideString);
var
  User: String;
begin
  User := FileSrv.GetUserName(aHandle);
  aOkay := fUsers.HasRight(User, arSearch);
  if not aOkay then Exit;
  aRoot := fUsers.GetRoot(User);
  LogMsg(DUN(User) + ': start searching in ' + aPath);
end;


//Search is completed
procedure TfMain.doSearchDone(Sender: TObject; aHandle: Integer; aCode: Integer);
begin
  LogMsg(DUN(FileSrv.GetUserName(aHandle)) + ': finish searching - ' + IntToStr(aCode));
end;






end.