Zaki/Password-Manager
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
25dc52458542c852630196a34fc90929c0d1a836
Password-Manager/mainApk.pas
T
r-zakarya 65e6ba6a54 fix(android): draw the search hint ourselves, TextPrompt needs a style object 
Dark.style has no object for the prompt text, so the search field sat there
empty and mute. A label inside the field, hit-test off so the tap goes
through, shown only while the field is empty.

Fourth time today the same conclusion: whatever FMX renders through a style
template may or may not exist in the style actually loaded. Built explicitly,
it is there.

Also noted: the row height was never wrong. 56 logical units on a 3x display
are the ~166 device pixels the screenshot showed - only the second line was
missing.

Co-Authored-By: Claude Opus 5 <noreply@anthropic.com>
2026-08-15 16:04:01 +01:00

1395 lines
47 KiB
ObjectPascal
Raw Blame History

unit mainApk;
{
Client Android en LECTURE SEULE : deverrouiller, chercher, copier.
Trois ecrans dans une seule forme, montres a tour de role - une forme par
ecran couterait un fichier .fmx chacun pour trois dispositions triviales.
1. Deverrouillage : ouvre le coffre local (biometrie), ou telecharge le
conteneur et le dechiffre si l'appareil n'en a pas encore.
2. Liste : recherche + entrees.
3. Detail : les champs d'une entree, mot de passe masque.
DEUX REGLES DE SURETE tenues ici, pas ailleurs :
- le coffre en clair est EFFACE des que l'application passe en arriere-plan
(sinon il reste dans l'apercu des applications recentes) ;
- le presse-papiers est VIDE apres un delai, et seulement si son contenu
est toujours celui qu'on y a mis.
L'ecriture n'existe pas : le poste Windows reste la source. Modifier ici
demanderait le PUT cote serveur et une fusion cote client.
}
interface
uses
System.SysUtils, System.Types, System.UITypes, System.Classes,
System.Diagnostics, System.Rtti, System.NetEncoding, System.DateUtils,
System.Generics.Collections,
FMX.Types, FMX.Controls, FMX.Forms, FMX.Graphics, FMX.Dialogs, FMX.Platform,
FMX.Controls.Presentation, FMX.StdCtrls, FMX.Memo, FMX.Memo.Types,
FMX.ScrollBox, FMX.Layouts, FMX.Edit, FMX.ListBox, FMX.Objects,
PMA.Vault;
const
// VALEURS DE PREMIER LANCEMENT UNIQUEMENT. Des que l'appareil a enregistre
// ses reglages, elles ne servent plus a rien : LoadDeviceSettings les
// remplace. Rien de secret ne doit vivre ici - le jeton et le mot de passe
// viennent du fichier local hors depot, plus bas.
//
// Le port differe selon la plateforme : sur Windows on attaque Apache
// directement (80), sur Android on passe par "adb reverse tcp:8080 tcp:80",
// qui fait voir le PC comme 127.0.0.1 - ce qui satisfait au passage
// l'exemption HTTPS de l'endpoint, reservee a la boucle locale.
{$IF DEFINED(ANDROID)}
FIRSTRUN_URL = 'http://127.0.0.1:8080/server-php/sync.php';
{$ELSE}
FIRSTRUN_URL = 'http://127.0.0.1/server-php/sync.php';
{$ENDIF}
// Assez pour aller coller dans une autre application, trop court pour qu'un
// mot de passe traine dans l'historique du presse-papiers.
CLIPBOARD_CLEAR_SECONDS = 45;
// Verrouillage sur inactivite au premier plan. Le passage en arriere-plan
// verrouille deja ; ceci couvre le telephone pose sur une table, ecran
// allume, application ouverte.
AUTOLOCK_MINUTES = 3;
// FIRSTRUN_TOKEN et TEST_PWD viennent d'un fichier LOCAL, hors depot : le
// jeton authentifie l'appareil, le mot de passe ouvre le coffre entier. Ni
// l'un ni l'autre n'a sa place dans un depot, meme sans remote. Absents apres
// un clone -> recopier PMA.LocalConfig.template.inc.
{$I android-client\PMA.LocalConfig.inc}
type
/// Une ligne du detail, avant tout controle. Site, identifiant, mot de
/// passe et champs personnalises se ramenent tous a la meme chose : un
/// intitule, une valeur, et le fait qu'elle soit secrete ou non. Les traiter
/// separement dupliquerait revelation et copie quatre fois.
TDetRow = record
Caption, Value: string;
Secret: Boolean;
end;
TForm8 = class(TForm)
private
FVault: TVault;
FFiltered: TArray<Integer>; // indices dans FVault, resultat de la recherche
FCurrent: TVaultEntry;
// L'ETag n'est conserve QUE si le dechiffrement qui a suivi a reussi :
// envoyer If-None-Match sans detenir le clair correspondant fait
// economiser un telechargement pour se retrouver sans donnees.
FETag: string;
FBusy: Boolean;
// Mot de passe de sync tel qu'il a ete range avec le coffre. Il rend le
// rafraichissement de fond silencieux : sans lui, chaque modification
// faite sur le poste ferait apparaitre une invite au lancement.
FSyncPwd: string;
// --- ecran 1 : deverrouillage
FLayUnlock: TLayout;
FUrl, FToken, FPwd: TEdit;
FBtnOpen, FBtnSync, FBtnSettings: TButton;
FLaySettings: TLayout;
FStatus: TLabel;
FLog: TMemo;
// --- ecran 2 : liste
FLayList: TLayout;
FSearch: TEdit;
FSearchHint: TLabel;
FFolderBox: TComboBox;
FList: TListBox;
FCount: TLabel;
/// Icones decodees une fois par coffre, pas a chaque frappe : la liste est
/// reconstruite a chaque caractere tape, et decoder du PNG a ce rythme se
/// voit. Cle = indice dans le coffre.
FIcons: TObjectDictionary<Integer, TBitmap>;
// --- ecran 3 : detail
// Les lignes sont construites PAR ENTREE : leur nombre depend des champs
// personnalises. On garde de quoi les detruire et de quoi retrouver
// l'etiquette de valeur d'une ligne pour la reveler.
FLayDetail: TLayout;
FDetBody: TVertScrollBox;
FDetTitle, FDetToast: TLabel;
FRows: TArray<TDetRow>;
FRowCtls: TArray<TLayout>;
FRowValues: TArray<TLabel>;
FRowShown: TArray<Boolean>;
// --- TOTP : une ligne vivante, rafraichie chaque seconde
FTotpTimer: TTimer;
FTotpValue: TLabel;
FTotpCode: string;
// --- presse-papiers
FClipTimer: TTimer;
FCopied: string;
// --- verrouillage sur inactivite
FIdleTimer: TTimer;
FLastActivity: TDateTime;
procedure Touch;
procedure OnIdleTimer(Sender: TObject);
procedure BuildUnlock;
procedure BuildList;
procedure BuildDetail;
procedure ShowUnlock;
procedure ShowList;
procedure ShowDetail(AVaultIndex: Integer);
procedure ClearDetailRows;
procedure OnTotpTick(Sender: TObject);
procedure DoOpenLocal(Sender: TObject);
/// AAuto : declenche par l'ouverture automatique au lancement, pas par
/// l'utilisateur. Une action automatique ne detruit jamais le cache.
procedure OpenVault(AAuto: Boolean);
// Separee de DoOpenLocal : une methode anonyme ne peut pas appeler une
// procedure imbriquee (E2555), et le rappel de la biometrie en est une.
procedure OpenLocalNow;
procedure DoSync(Sender: TObject);
/// ASilent : rafraichissement de fond. Le coffre local est deja affiche,
/// donc un echec reseau ne doit rien reclamer a l'utilisateur - il garde
/// ce qu'il a. Seul un instantane NOUVEAU se voit.
procedure FetchAndDecrypt(const AUrl, ATok, APwd: string;
ASilent: Boolean = False);
procedure AdoptVault(const APlainJson: string);
procedure LockVault;
procedure OnSearchChanged(Sender: TObject);
procedure PopulateFolders;
procedure RebuildIcons;
procedure OnItemTap(const Sender: TCustomListBox; const AItem: TListBoxItem);
procedure OnRevealTap(Sender: TObject);
procedure OnCopyTap(Sender: TObject);
procedure OnBackTap(Sender: TObject);
procedure OnToggleSettings(Sender: TObject);
procedure OnClipTimer(Sender: TObject);
procedure OnHardwareBack(Sender: TObject; var Key: Word;
var KeyChar: WideChar; Shift: TShiftState);
procedure CopyToClipboard(const AText, ALabel: string);
function HandleAppEvent(AAppEvent: TApplicationEvent; AContext: TObject): Boolean;
procedure Log(const AMsg: string);
procedure Status(const AMsg: string);
procedure SetBusy(ABusy: Boolean);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
end;
var
Form8: TForm8;
implementation
uses
PMA.Crypto, PMA.SyncClient, PMA.Store, PMA.Biometric, PMA.Totp,
PMA.ScreenGuard, PMA.Clipboard;
{$R *.fmx}
const
// Puces en points de code, PAS en caracteres litteraux : un .pas sans BOM
// est lu comme de l'ANSI, et un bullet UTF-8 y devient trois glyphes.
BULLET = #$2022;
MASK = BULLET+BULLET+BULLET+BULLET+BULLET+BULLET+
BULLET+BULLET+BULLET+BULLET+BULLET+BULLET;
{ ----------------------------------------------------------------------------
Construction
---------------------------------------------------------------------------- }
constructor TForm8.Create(AOwner: TComponent);
var
LEvents: IFMXApplicationEventService;
begin
inherited;
Caption := 'Coffre';
SecureScreen; // avant tout affichage de contenu
FVault := TVault.Create;
FIcons := TObjectDictionary<Integer, TBitmap>.Create([doOwnsValues]);
BuildDetail; // cree en dernier a l'ecran = au-dessus des autres
BuildList;
BuildUnlock;
FClipTimer := TTimer.Create(Self);
FClipTimer.Enabled := False;
FClipTimer.Interval := CLIPBOARD_CLEAR_SECONDS * 1000;
FClipTimer.OnTimer := OnClipTimer;
FTotpTimer := TTimer.Create(Self);
FTotpTimer.Enabled := False;
FTotpTimer.Interval := 1000;
FTotpTimer.OnTimer := OnTotpTick;
// Tick grossier : on compare des horodatages, il ne sert qu'a echantillonner.
// Une seconde de precision n'apporterait rien et reveillerait l'appareil.
FIdleTimer := TTimer.Create(Self);
FIdleTimer.Enabled := False;
FIdleTimer.Interval := 15000;
FIdleTimer.OnTimer := OnIdleTimer;
// Le bouton retour materiel arrive comme une touche : sans ce gestionnaire
// il ferme l'application depuis le detail, au lieu de revenir a la liste.
OnKeyUp := OnHardwareBack;
if TPlatformServices.Current.SupportsPlatformService(
IFMXApplicationEventService, LEvents) then
LEvents.SetApplicationEventHandler(HandleAppEvent);
ShowUnlock;
// Ouverture automatique du coffre local. Differee apres la construction :
// l'invite biometrique s'afficherait sinon avant la premiere peinture de la
// fenetre, sur un fond vide.
if HasVault then
TThread.ForceQueue(nil, procedure begin OpenVault(True); end);
end;
destructor TForm8.Destroy;
begin
FIcons.Free;
FVault.Free;
inherited;
end;
/// Cree un bouton empile en haut. En FMX, des controles alignes en haut
/// s'empilent A REBOURS de leur creation : le dernier cree se retrouve tout en
/// haut. Chaque Build* cree donc du bas vers le haut.
function TopButton(AParent: TFmxObject; const AText: string;
AOnClick: TNotifyEvent; AHeight: Single = 48): TButton;
begin
Result := TButton.Create(AParent);
Result.Parent := AParent;
Result.Align := TAlignLayout.Top;
Result.Margins.Rect := RectF(8, 4, 8, 0);
Result.Height := AHeight;
Result.Text := AText;
Result.OnClick := AOnClick;
end;
function TopEdit(AParent: TFmxObject; const APrompt, AText: string;
APassword: Boolean = False): TEdit;
begin
Result := TEdit.Create(AParent);
Result.Parent := AParent;
Result.Align := TAlignLayout.Top;
Result.Margins.Rect := RectF(8, 4, 8, 0);
Result.TextPrompt := APrompt;
Result.Text := AText;
Result.Password := APassword;
end;
procedure TForm8.BuildUnlock;
var
LUrl, LToken: string;
begin
FLayUnlock := TLayout.Create(Self);
FLayUnlock.Parent := Self;
FLayUnlock.Align := TAlignLayout.Client;
// Journal en bas : il ne sert plus qu'au diagnostic, mais un echec reseau ou
// JNI sans trace se debugue a l'aveugle.
FLog := TMemo.Create(Self);
FLog.Parent := FLayUnlock;
FLog.Align := TAlignLayout.Bottom;
FLog.Height := 150;
FLog.Margins.Rect := RectF(8, 8, 8, 8);
FLog.ReadOnly := True;
// Sans repli, un message d'exception est coupe net au bord du memo - et
// c'est toujours la fin qui nomme la cause.
FLog.WordWrap := True;
FLog.TextSettings.Font.Family := 'monospace';
FLog.TextSettings.Font.Size := 11;
// --- du bas vers le haut (voir TopButton)
FLaySettings := TLayout.Create(Self);
FLaySettings.Parent := FLayUnlock;
FLaySettings.Align := TAlignLayout.Top;
FLaySettings.Height := 116;
FLaySettings.Visible := False;
FToken := TopEdit(FLaySettings, 'jeton Bearer', FIRSTRUN_TOKEN);
FUrl := TopEdit(FLaySettings, 'URL de l''endpoint', FIRSTRUN_URL);
// Ce que l'appareil a retenu l'emporte sur les valeurs de premier lancement.
if LoadDeviceSettings(LUrl, LToken) then
begin
FUrl.Text := LUrl;
if LToken <> '' then FToken.Text := LToken;
end;
FBtnSettings := TopButton(FLayUnlock, 'Reglages du serveur',
OnToggleSettings, 36);
FBtnSettings.TextSettings.Font.Size := 12;
FBtnSync := TopButton(FLayUnlock, 'Synchroniser', DoSync);
FBtnOpen := TopButton(FLayUnlock, 'Ouvrir le coffre', DoOpenLocal);
// Pre-rempli depuis le fichier local, jamais depuis ce fichier-ci.
FPwd := TopEdit(FLayUnlock, 'mot de passe de sync', TEST_PWD, True);
FPwd.Margins.Top := 12;
FStatus := TLabel.Create(Self);
FStatus.Parent := FLayUnlock;
FStatus.Align := TAlignLayout.Top;
FStatus.Margins.Rect := RectF(8, 16, 8, 0);
FStatus.Height := 24;
FStatus.StyledSettings := FStatus.StyledSettings - [TStyledSetting.Size];
FStatus.TextSettings.Font.Size := 15;
end;
procedure TForm8.BuildList;
var
LBar, LTop: TLayout;
LBtnLock: TButton;
begin
FLayList := TLayout.Create(Self);
FLayList.Parent := Self;
FLayList.Align := TAlignLayout.Client;
FLayList.Visible := False;
LBar := TLayout.Create(Self);
LBar.Parent := FLayList;
LBar.Align := TAlignLayout.Bottom;
LBar.Height := 52;
LBtnLock := TButton.Create(Self);
LBtnLock.Parent := LBar;
LBtnLock.Align := TAlignLayout.Left;
LBtnLock.Margins.Rect := RectF(8, 4, 0, 8);
LBtnLock.Width := 130;
LBtnLock.Text := 'Verrouiller';
LBtnLock.OnClick := OnBackTap;
LBtnLock.Tag := 1; // 1 = verrouiller, 0 = simple retour (voir OnBackTap)
FCount := TLabel.Create(Self);
FCount.Parent := LBar;
FCount.Align := TAlignLayout.Client;
FCount.Margins.Rect := RectF(12, 4, 8, 8);
FCount.TextSettings.HorzAlign := TTextAlign.Trailing;
FCount.TextSettings.VertAlign := TTextAlign.Center;
FList := TListBox.Create(Self);
FList.Parent := FLayList;
FList.Align := TAlignLayout.Client;
FList.Margins.Rect := RectF(4, 0, 4, 0);
FList.ItemHeight := 56;
FList.OnItemClick := OnItemTap;
LTop := TLayout.Create(Self);
LTop.Parent := FLayList;
LTop.Align := TAlignLayout.Top;
LTop.Height := 48;
LTop.Margins.Rect := RectF(8, 8, 8, 8);
// Pas de filtre d'etiquette : la recherche texte couvre deja les etiquettes,
// en taper le nom suffit. Les dossiers, eux, ne se devinent pas.
FFolderBox := TComboBox.Create(Self);
FFolderBox.Parent := LTop;
FFolderBox.Align := TAlignLayout.Right;
FFolderBox.Width := 140;
FFolderBox.Margins.Left := 8;
FFolderBox.OnChange := OnSearchChanged;
FSearch := TEdit.Create(Self);
FSearch.Parent := LTop;
FSearch.Align := TAlignLayout.Client;
FSearch.OnChangeTracking := OnSearchChanged;
// Invite dessinee par nous, pas par TextPrompt : Dark.style ne comporte pas
// l'objet que le style est cense fournir pour l'afficher, et le champ
// restait donc vide et muet. HitTest desactive pour que le clic traverse
// jusqu'au champ.
FSearchHint := TLabel.Create(FSearch);
FSearchHint.Parent := FSearch;
FSearchHint.Align := TAlignLayout.Client;
FSearchHint.Margins.Left := 10;
FSearchHint.HitTest := False;
FSearchHint.Opacity := 0.45;
FSearchHint.Text := 'Rechercher';
end;
/// Intitule discret au-dessus d'une valeur. Meme forme pour toutes les
/// lignes, y compris celle du TOTP.
/// AOrder fixe la place de la ligne dans la liste d'enfants du parent.
///
/// SANS LUI L'ORDRE N'EST PAS STABLE : observe sur appareil, le formulaire
/// s'affichait dans le bon ordre a la premiere ouverture puis a l'envers apres
/// un verrouillage. Les conventions d'empilement de FMX different deja entre
/// TLayout et TVertScrollBox ; apres destruction et recreation des lignes,
/// elles ne sont meme plus constantes. On ne s'y fie donc pas du tout.
function MakeRow(AParent: TFmxObject; const ACaption: string; AOrder: Integer;
out AValue: TLabel): TLayout;
var
LCap: TLabel;
begin
Result := TLayout.Create(nil); // detruite a la main, voir ClearDetailRows
Result.Parent := AParent;
Result.Index := AOrder;
Result.Align := TAlignLayout.Top;
Result.Height := 62;
Result.Margins.Rect := RectF(12, 10, 12, 0);
LCap := TLabel.Create(Result);
LCap.Parent := Result;
LCap.Align := TAlignLayout.Top;
LCap.Height := 20;
LCap.Text := ACaption;
LCap.Opacity := 0.6;
LCap.StyledSettings := LCap.StyledSettings - [TStyledSetting.Size];
LCap.TextSettings.Font.Size := 12;
AValue := TLabel.Create(Result);
AValue.Parent := Result;
AValue.Align := TAlignLayout.Client;
AValue.StyledSettings := AValue.StyledSettings - [TStyledSetting.Size];
AValue.TextSettings.Font.Size := 16;
end;
function AddRowButton(ARow: TLayout; const AText: string; ATag: Integer;
AOnClick: TNotifyEvent): TButton;
begin
Result := TButton.Create(ARow);
Result.Parent := ARow;
Result.Align := TAlignLayout.Right;
Result.Margins.Left := 6;
Result.Width := 90;
Result.Text := AText;
Result.Tag := ATag;
Result.OnClick := AOnClick;
end;
procedure TForm8.BuildDetail;
var
LBtnBack: TButton;
begin
FLayDetail := TLayout.Create(Self);
FLayDetail.Parent := Self;
FLayDetail.Align := TAlignLayout.Client;
FLayDetail.Visible := False;
LBtnBack := TButton.Create(Self);
LBtnBack.Parent := FLayDetail;
LBtnBack.Align := TAlignLayout.Bottom;
LBtnBack.Height := 48;
LBtnBack.Margins.Rect := RectF(8, 8, 8, 8);
LBtnBack.Text := 'Retour';
LBtnBack.Tag := 0;
LBtnBack.OnClick := OnBackTap;
FDetToast := TLabel.Create(Self);
FDetToast.Parent := FLayDetail;
FDetToast.Align := TAlignLayout.Bottom;
FDetToast.Height := 22;
FDetToast.Margins.Rect := RectF(12, 0, 12, 0);
FDetToast.StyledSettings := FDetToast.StyledSettings - [TStyledSetting.Size];
FDetToast.TextSettings.Font.Size := 12;
FDetToast.Opacity := 0.7;
// Le corps defilant n'est PAS cree ici : il est recree a chaque ouverture
// d'entree, voir ShowDetail.
FDetTitle := TLabel.Create(Self);
FDetTitle.Parent := FLayDetail;
FDetTitle.Align := TAlignLayout.Top;
FDetTitle.Height := 44;
FDetTitle.Margins.Rect := RectF(12, 12, 12, 0);
FDetTitle.StyledSettings := FDetTitle.StyledSettings - [TStyledSetting.Size];
FDetTitle.TextSettings.Font.Size := 22;
end;
{ ----------------------------------------------------------------------------
Navigation
---------------------------------------------------------------------------- }
procedure TForm8.ShowUnlock;
begin
FLayDetail.Visible := False;
FLayList.Visible := False;
FLayUnlock.Visible := True;
// Le bouton d'ouverture n'a de sens que si un coffre local existe ; sinon
// seul le telechargement peut en produire un.
FBtnOpen.Visible := HasVault;
if HasVault then
begin
if VaultNeedsAuth then
Status('Coffre present sur cet appareil - protege')
else
Status('Coffre present sur cet appareil');
FBtnSync.Text := 'Synchroniser';
end
else
begin
Status('Aucun coffre local - premier telechargement');
FBtnSync.Text := 'Telecharger le coffre';
end;
end;
procedure TForm8.ShowList;
begin
// Quitter le detail rend ses valeurs en clair, et arrete le compte a rebours.
ClearDetailRows;
FLayUnlock.Visible := False;
FLayDetail.Visible := False;
FLayList.Visible := True;
FSearch.Text := '';
OnSearchChanged(nil);
end;
function HumanSize(ABytes: Int64): string;
begin
if ABytes >= 1024 * 1024 then
Result := Format('%.1f Mo', [ABytes / (1024 * 1024)])
else if ABytes >= 1024 then
Result := Format('%.0f Ko', [ABytes / 1024])
else
Result := Format('%d o', [ABytes]);
end;
procedure TForm8.ClearDetailRows;
var
LRow: TLayout;
begin
// Appelable avant la fin du constructeur (ShowList), d'ou la garde.
if FTotpTimer <> nil then FTotpTimer.Enabled := False;
FTotpValue := nil;
FTotpCode := '';
// LE CONTENEUR ENTIER EST DETRUIT, pas seulement ses lignes.
//
// Reutiliser le TVertScrollBox donnait un ordre d'affichage qui ALTERNAIT :
// correct a la premiere ouverture, inverse a la suivante. Ni la convention
// d'empilement ni un Index explicite ne l'ont stabilise. Puisque la premiere
// population est fiable, on n'en fait jamais de seconde - un conteneur neuf
// par entree. Ca coute la creation d'un controle, ca supprime une classe
// entiere de bizarreries.
for LRow in FRowCtls do LRow.Free;
SetLength(FRowCtls, 0);
FreeAndNil(FDetBody);
SetLength(FRowValues, 0);
SetLength(FRowShown, 0);
SetLength(FRows, 0);
end;
procedure TForm8.ShowDetail(AVaultIndex: Integer);
var
LMeta, LPwdCaption: string;
I, LOrder: Integer;
LRow: TLayout;
LValue: TLabel;
procedure Add(const ACaption, AValue: string; ASecret: Boolean);
begin
if AValue = '' then Exit; // une ligne vide n'apprend rien
SetLength(FRows, Length(FRows) + 1);
FRows[High(FRows)].Caption := ACaption;
FRows[High(FRows)].Value := AValue;
FRows[High(FRows)].Secret := ASecret;
end;
begin
Touch;
ClearDetailRows;
// Conteneur neuf. Align=Client, donc il ne dispute sa place ni au titre
// (Top) ni au pied (Bottom) : l'ordre de creation lui est indifferent.
FDetBody := TVertScrollBox.Create(Self);
FDetBody.Parent := FLayDetail;
FDetBody.Align := TAlignLayout.Client;
FCurrent := FVault.Entry(AVaultIndex);
FDetTitle.Text := FCurrent.Display;
FDetToast.Text := '';
// Le corps d'une note est stocke dans le champ mot de passe : meme donnee,
// autre intitule, et pas de raison de la masquer comme un secret.
if FCurrent.IsNote then LPwdCaption := 'Contenu' else LPwdCaption := 'Mot de passe';
Add('Site', FCurrent.Site, False);
Add('Identifiant', FCurrent.Username, False);
Add(LPwdCaption, FCurrent.Password, not FCurrent.IsNote);
for I := 0 to High(FCurrent.Fields) do
Add(FCurrent.Fields[I].Caption, FCurrent.Fields[I].Value,
FCurrent.Fields[I].Secret);
LMeta := FCurrent.Folder;
if FCurrent.Tags <> '' then
begin
if LMeta <> '' then LMeta := LMeta + ' - ';
LMeta := LMeta + FCurrent.Tags;
end;
// Les pieces jointes ne sont pas encore enregistrables sur le telephone,
// mais taire leur existence serait pire : on saurait sur le poste qu'une
// entree porte un document, et pas ici.
// Taille dans l'INTITULE, pas collee au nom : un nom de fichier arabe suivi
// d'une taille latine melange deux sens de lecture dans la meme ligne, et le
// rendu bidirectionnel de FMX en fait n'importe quoi. Separes, chacun se
// lit dans son sens.
for I := 0 to High(FCurrent.Attachments) do
Add('Piece jointe - ' + HumanSize(FCurrent.Attachments[I].SizeBytes),
FCurrent.Attachments[I].FileName, False);
Add('Dossier / etiquettes', LMeta, False);
// Le sous-type n'existe que pour les modeles (carte, cle SSH, serveur...) ;
// Add ignore une valeur vide, donc rien a tester ici.
Add('Type', FCurrent.Template, False);
// Horodatage tel quel : c'est de l'ISO 8601 UTC, lisible, et le reformater
// demanderait de decider d'un fuseau alors qu'il n'y a rien a arbitrer.
Add('Modifie le', FCurrent.UpdatedAt, False);
SetLength(FRowValues, Length(FRows));
SetLength(FRowShown, Length(FRows));
SetLength(FRowCtls, Length(FRows));
// Le TOTP en tete d'ecran : c'est ce qu'on vient chercher sur un telephone.
// Seule ligne vivante, rafraichie chaque seconde.
LOrder := 0;
if FCurrent.Totp <> '' then
begin
LRow := MakeRow(FDetBody, 'Code 2FA', LOrder, FTotpValue);
Inc(LOrder);
SetLength(FRowCtls, Length(FRowCtls) + 1);
FRowCtls[High(FRowCtls)] := LRow;
FTotpValue.TextSettings.Font.Size := 26;
AddRowButton(LRow, 'Copier', -1, OnCopyTap);
OnTotpTick(nil); // pas d'attente d'une seconde a l'ouverture
FTotpTimer.Enabled := True;
end;
for I := 0 to High(FRows) do
begin
LRow := MakeRow(FDetBody, FRows[I].Caption, LOrder, LValue);
Inc(LOrder);
FRowCtls[I] := LRow;
FRowValues[I] := LValue;
FRowShown[I] := False;
if FRows[I].Secret then
begin
LValue.Text := MASK;
AddRowButton(LRow, 'Afficher', I, OnRevealTap);
end
else
LValue.Text := FRows[I].Value;
AddRowButton(LRow, 'Copier', I, OnCopyTap);
end;
// La derniere ligne affichee touche sinon le bord du defilement, ce qui la
// fait passer pour tronquee alors qu'elle est juste collee.
// La derniere ligne affichee touche sinon le bord du defilement, ce qui la
// fait passer pour tronquee alors qu'elle est juste collee.
if Length(FRows) > 0 then
FRowCtls[High(FRows)].Margins.Bottom := 12;
FLayList.Visible := False;
FLayDetail.Visible := True;
end;
procedure TForm8.OnTotpTick(Sender: TObject);
var
LLeft, LPeriod: Integer;
begin
if FTotpValue = nil then
begin
FTotpTimer.Enabled := False;
Exit;
end;
FTotpCode := TotpNow(FCurrent.Totp, LLeft, LPeriod);
if FTotpCode = '' then
begin
// Un secret illisible ne doit pas passer pour un code : le dire.
FTotpValue.Text := 'secret illisible';
FTotpTimer.Enabled := False;
Exit;
end;
// Coupe en deux, comme partout ailleurs : six chiffres d'affilee se
// recopient mal.
FTotpValue.Text := Copy(FTotpCode, 1, Length(FTotpCode) div 2) + ' ' +
Copy(FTotpCode, Length(FTotpCode) div 2 + 1, MaxInt) +
' ' + LLeft.ToString + ' s';
end;
procedure TForm8.OnBackTap(Sender: TObject);
begin
// Tag 1 = le bouton "Verrouiller" de la liste, 0 = le "Retour" du detail.
if (Sender is TButton) and (TButton(Sender).Tag = 1) then
LockVault
else
ShowList;
end;
procedure TForm8.OnHardwareBack(Sender: TObject; var Key: Word;
var KeyChar: WideChar; Shift: TShiftState);
begin
if Key <> vkHardwareBack then Exit;
if FLayDetail.Visible then
begin
ShowList;
Key := 0; // consomme : sinon Android ferme l'application
end
else if FLayList.Visible then
begin
LockVault;
Key := 0;
end;
end;
procedure TForm8.OnToggleSettings(Sender: TObject);
begin
FLaySettings.Visible := not FLaySettings.Visible;
end;
{ ----------------------------------------------------------------------------
Ouverture, synchronisation, verrouillage
---------------------------------------------------------------------------- }
procedure TForm8.LockVault;
begin
// Le clair dispararait de la memoire ET de l'ecran. Le fichier local reste :
// il est chiffre par le materiel, c'est tout l'interet du cache.
//
// L'ETAG PART AVEC LUI. Il decrit le clair detenu, pas un telechargement :
// le garder ferait repondre 304 au serveur alors qu'on n'a plus rien a
// afficher - et sur un poste sans cache local (hors Android), plus aucun
// moyen de rouvrir le coffre sans relancer l'application.
FETag := '';
FIdleTimer.Enabled := False;
FVault.Clear;
FList.Clear;
FIcons.Clear;
// Les lignes du detail portent des valeurs EN CLAIR (FRows) : les detruire
// fait partie du verrouillage, pas de l'affichage.
ClearDetailRows;
FCurrent := Default(TVaultEntry);
ShowUnlock;
end;
procedure TForm8.AdoptVault(const APlainJson: string);
begin
FVault.LoadFromJson(APlainJson);
Log(' ' + FVault.LiveCount.ToString + ' entrees, ' +
FVault.TrashCount.ToString + ' en corbeille');
RebuildIcons;
PopulateFolders;
Touch;
FIdleTimer.Enabled := True;
// Deja dans l'application : reconstruire la liste SANS y ramener
// l'utilisateur. Obligatoire meme s'il est dans le detail - les lignes de
// la liste portent des indices vers l'ancien coffre, et un appui ouvrirait
// la mauvaise entree.
if FLayList.Visible or FLayDetail.Visible then
OnSearchChanged(nil)
else
ShowList;
end;
procedure TForm8.OpenLocalNow;
var
LPlain, LETag, LPwd: string;
begin
if LoadVault(LPlain, LETag, LPwd) then
begin
FETag := LETag;
if LPwd <> '' then FSyncPwd := LPwd;
try
AdoptVault(LPlain);
// Afficher d'abord, synchroniser ensuite : le coffre est a l'ecran, le
// reseau se debrouille derriere. Sans mot de passe range, on ne peut
// rien ouvrir de nouveau - inutile d'aller voir.
if FSyncPwd <> '' then
FetchAndDecrypt(FUrl.Text.Trim, FToken.Text.Trim, FSyncPwd, True);
except
on E: Exception do
begin
// Un coffre local illisible se remplace, il ne se repare pas.
Log('Coffre local corrompu : ' + E.Message);
ClearVault;
ShowUnlock;
end;
end;
end
else
begin
// ShowUnlock AVANT le message : il repositionne le statut selon ce que
// l'appareil detient, et ecraserait donc l'explication.
ShowUnlock;
Log('Coffre local illisible : ' + LastStoreError);
Status('Coffre local illisible - voir le journal');
end;
end;
procedure TForm8.DoOpenLocal(Sender: TObject);
begin
OpenVault(False); // geste explicite de l'utilisateur
end;
procedure TForm8.OpenVault(AAuto: Boolean);
begin
if FBusy then Exit;
// L'authentification affiche un dialogue systeme : elle doit rester sur le
// thread principal, et PRECEDER toute lecture du coffre.
if not VaultNeedsAuth then
begin
OpenLocalNow;
Exit;
end;
if not AAuto then Status('Authentification...');
AuthenticateThen('Acceder au coffre',
procedure(AOutcome: TBioOutcome)
begin
case AOutcome of
boOK: OpenLocalNow;
boCancelled: Status('Annule');
boUnavailable:
// Reponse nette du systeme : plus rien pour authentifier sur cet
// appareil, donc la cle est perdue et le cache avec elle.
//
// UNE ACTION AUTOMATIQUE N'EFFACE JAMAIS LE CACHE. Au lancement on
// se contente de le dire : si le diagnostic est faux - service pas
// encore pret, etat transitoire - effacer imposerait un
// retelechargement et quatre secondes de derivation pour rien, et
// masquerait la vraie cause. L'utilisateur tranche en reessayant.
if AAuto then
begin
Log('Authentification indisponible au lancement - cache conserve');
Log(' ' + LastBiometricError);
Status('Authentification indisponible - reessayer');
end
else
begin
Log('Plus aucune protection sur l''appareil - cache efface');
Log(' ' + LastBiometricError);
ClearVault;
ShowUnlock;
end;
else
// boFailed : la couche Java a leve quelque chose. Cela ne dit rien de
// l'appareil, donc on ne touche a rien - on rapporte.
Log('Echec de l''authentification : ' + LastBiometricError);
Status('Echec de l''authentification');
end;
end);
end;
procedure TForm8.DoSync(Sender: TObject);
var
LUrl, LTok, LPwd: string;
begin
if FBusy then Exit;
// Lus ICI, sur le thread principal : toucher un controle FMX depuis le
// thread de travail est un plantage differe, pas une erreur de compilation.
LUrl := FUrl.Text.Trim;
LTok := FToken.Text.Trim;
// Ce qui est tape l'emporte : c'est ainsi qu'on corrige un mot de passe
// range qui ne convient plus.
LPwd := FPwd.Text;
if LPwd = '' then LPwd := FSyncPwd;
if LPwd = '' then
begin
Status('Mot de passe de sync requis');
Exit;
end;
FLog.Lines.Clear;
// MEME PORTE QUE « Ouvrir le coffre ». Sans cela la protection ne tenait
// qu'a un bouton pres : synchroniser reconstruit le coffre depuis le serveur
// et l'affiche, ce qui revient exactement au meme resultat sans passer par
// l'authentification. La condition est la presence d'un cache protege sur
// cet appareil - c'est lui qui exprime le choix de l'utilisateur.
if VaultNeedsAuth and (FVault.Count = 0) then
begin
Status('Authentification...');
AuthenticateThen('Acceder au coffre',
procedure(AOutcome: TBioOutcome)
begin
if AOutcome = boOK then
FetchAndDecrypt(LUrl, LTok, LPwd)
else
begin
Log('Synchronisation refusee : ' + LastBiometricError);
Status('Authentification requise');
end;
end);
Exit;
end;
FetchAndDecrypt(LUrl, LTok, LPwd);
end;
procedure TForm8.FetchAndDecrypt(const AUrl, ATok, APwd: string;
ASilent: Boolean);
var
LCanAuth: Boolean;
begin
SetBusy(True);
if not ASilent then Status('Telechargement...');
// NE JAMAIS FERMER LE CACHE DERRIERE UNE PORTE QU'ON NE SAIT PAS OUVRIR.
// Demander une cle protegee par authentification alors que l'invite ne peut
// pas s'afficher (permission absente, aucune protection configuree) produit
// un fichier definitivement illisible. Evalue ici, sur le thread principal :
// l'interrogation du service passe par la couche Java.
LCanAuth := BiometricAvailable;
TThread.CreateAnonymousThread(
procedure
var
LClient: TSyncClient;
LRes: TSyncResult;
LPlain, LCached, LCachedETag, LCachedPwd: string;
LSw: TStopwatch;
begin
// Le coffre local d'abord : s'il est la, on connait deja l'ETag et on
// evite les 4 secondes de derivation quand rien n'a change.
if (FETag = '') and LoadVault(LCached, LCachedETag, LCachedPwd) then
FETag := LCachedETag;
LClient := TSyncClient.Create(AUrl, ATok);
// try/finally et NON un simple enchainement : les Exit des branches
// d'erreur ci-dessous sautent la fin de la procedure, ce qui laissait
// l'interface bloquee apres le premier echec.
try
try
Log('GET ' + AUrl);
if FETag <> '' then Log(' If-None-Match: ' + FETag);
LSw := TStopwatch.StartNew;
LRes := LClient.Fetch(FETag);
LSw.Stop;
Log(' HTTP ' + LRes.HttpCode.ToString + ' en ' +
LSw.ElapsedMilliseconds.ToString + ' ms');
case LRes.Status of
ssNotModified:
begin
// C'est ICI que le cache paie : pas de telechargement, pas de
// derivation, le coffre vient du fichier local.
// Rien n'a change cote serveur : le clair est deja quelque part,
// soit en memoire, soit dans le cache lu en debut de procedure.
// Surtout PAS de relecture du fichier ici - elle peut echouer
// (authentification expiree) et laisserait l'utilisateur sans
// rien apres un appel pourtant reussi.
TThread.Queue(nil,
procedure
begin
if FVault.Count > 0 then
// Rien a faire : ce qui est affiche est deja a jour. En
// rafraichissement de fond c'est le cas courant, et il
// doit passer inapercu - surtout pas de retour a la liste
// alors que l'utilisateur consulte une entree.
Log(' 304 : inchange, coffre deja ouvert')
else if LCached <> '' then
begin
Log(' 304 : inchange, coffre servi depuis le cache');
try
AdoptVault(LCached);
except
on E: Exception do Status('Cache illisible : ' + E.Message);
end;
end
else
begin
// Un ETag sans clair correspondant : l'invariant est rompu.
// On le jette pour que l'appel suivant retelecharge.
FETag := '';
if not ASilent then
Status('Cache absent - appuyer a nouveau pour telecharger');
end;
end);
Exit;
end;
ssNoSnapshot:
begin
// Le serveur repond pareil dans les deux cas, par conception.
Log(' 404 : pas d''instantane OU jeton invalide');
if not ASilent then
TThread.Queue(nil, procedure
begin Status('Rien a telecharger (404)'); end);
Exit;
end;
ssRefused, ssHttpError, ssNetworkError:
begin
// En fond, un echec reseau ne se signale pas : le coffre local
// est affiche, hors ligne est un etat normal, et une alerte ici
// apprendrait a l'utilisateur a ignorer les alertes.
Log(' echec : ' + LRes.Error);
if not ASilent then
TThread.Queue(nil, procedure
begin Status('Echec reseau'); end);
Exit;
end;
end;
Log(' recu ' + Length(LRes.Container).ToString + ' octets');
if not ASilent then
TThread.Queue(nil, procedure begin Status('Dechiffrement...'); end);
LSw := TStopwatch.StartNew;
// Volontairement AVANT de retenir l'ETag : un echec ici doit laisser
// FETag vide pour que le prochain essai retelecharge.
LPlain := DecryptContainer(LRes.Container, APwd);
LSw.Stop;
FETag := LRes.ETag;
Log(' dechiffre en ' + LSw.ElapsedMilliseconds.ToString + ' ms');
// Ecrit APRES un dechiffrement reussi seulement, et avec son ETag :
// les deux doivent rester coherents.
try
// Le mot de passe part avec le coffre : c'est lui qui permettra au
// prochain lancement de rafraichir sans rien demander.
SaveVault(LPlain, FETag, APwd, LCanAuth);
// Ce qui vient de fonctionner merite d'etre retenu : on n'enregistre
// pas des reglages saisis, on enregistre des reglages EPROUVES.
SaveDeviceSettings(AUrl, ATok);
if VaultNeedsAuth then
Log(' cache ecrit - protege par biometrie/code')
else if LCanAuth then
Log(' cache ecrit - cle simple (Keystore a refuse la contrainte)')
else
Log(' cache ecrit - AUCUNE protection : pas d''authentification ici');
except
// La classe compte autant que le message : "methode introuvable"
// designe une signature JNI fausse, pas un probleme de stockage.
on E: Exception do
Log(' cache non ecrit : ' + E.ClassName + ' - ' + E.Message);
end;
TThread.Queue(nil,
procedure
begin
FSyncPwd := APwd; // il vient d'ouvrir un conteneur : il est bon
try
AdoptVault(LPlain);
except
on E: Exception do
if not ASilent then
Status('Instantane illisible : ' + E.Message);
end;
end);
except
on E: Exception do
begin
Log('ERREUR ' + E.ClassName + ' : ' + E.Message);
// Le cas de loin le plus frequent, et le message par defaut ne le
// dit pas : GCM echoue a la verification quand la cle est fausse.
//
// En fond, cela veut dire que le mot de passe range ne convient
// plus - le poste a change de mot de passe de sync. On ne le jette
// PAS : il faudra le retaper, mais garder l'ancien laisse au moins
// le champ prerempli, et le coffre local reste consultable.
if not ASilent then
TThread.Queue(nil, procedure
begin Status('Echec - mot de passe de sync incorrect ?'); end);
end;
end;
finally
LClient.Free;
TThread.Queue(nil, procedure begin SetBusy(False); end);
end;
end).Start;
end;
{ ----------------------------------------------------------------------------
Liste et recherche
---------------------------------------------------------------------------- }
/// Data URI -> bitmap, ou nil. Les icones peuvent etre du SVG, que FMX ne
/// sait pas charger : l'echec est normal et se solde par les initiales.
function BitmapFromDataUri(const AUri: string): TBitmap;
var
LComma: Integer;
LStream: TBytesStream;
begin
Result := nil;
if not AUri.StartsWith('data:') then Exit;
LComma := Pos(',', AUri);
if LComma = 0 then Exit;
try
LStream := TBytesStream.Create(TNetEncoding.Base64.DecodeStringToBytes(
Copy(AUri, LComma + 1, MaxInt)));
try
Result := TBitmap.Create;
Result.LoadFromStream(LStream);
finally
LStream.Free;
end;
except
FreeAndNil(Result);
end;
end;
procedure TForm8.RebuildIcons;
var
I: Integer;
LBmp: TBitmap;
begin
FIcons.Clear;
// ponytail: tout decode a l'adoption du coffre, sur le thread principal.
// Quelques centaines de vignettes de 16 px ne se sentent pas ; deporter
// dans un thread le jour ou l'ouverture marque un temps.
for I := 0 to FVault.Count - 1 do
begin
if FVault.Entry(I).IconB64 = '' then Continue;
LBmp := BitmapFromDataUri(FVault.Entry(I).IconB64);
if LBmp <> nil then FIcons.Add(I, LBmp);
end;
end;
procedure TForm8.PopulateFolders;
var
LF, LPrev: string;
I: Integer;
begin
// Le choix courant survit a un rafraichissement de fond : le voir retomber
// sur "tous" tout seul, sans avoir rien touche, serait deroutant.
LPrev := '';
if FFolderBox.ItemIndex > 0 then
LPrev := FFolderBox.Items[FFolderBox.ItemIndex];
FFolderBox.Items.BeginUpdate;
try
FFolderBox.Items.Clear;
FFolderBox.Items.Add('Tous les dossiers');
for LF in FVault.Folders do FFolderBox.Items.Add(LF);
finally
FFolderBox.Items.EndUpdate;
end;
I := FFolderBox.Items.IndexOf(LPrev);
if I < 0 then I := 0;
FFolderBox.ItemIndex := I;
end;
procedure TForm8.OnSearchChanged(Sender: TObject);
var
I: Integer;
LItem: TListBoxItem;
E: TVaultEntry;
LFolder: string;
LBmp: TBitmap;
LImg: TImage;
LBody: TLayout;
LTitle, LSub: TLabel;
begin
// ponytail: refonte complete de la liste a chaque frappe. Sur un coffre de
// quelques centaines d'entrees c'est imperceptible ; passer a un modele
// virtuel (TListView) le jour ou ca rame.
Touch;
FSearchHint.Visible := FSearch.Text = '';
LFolder := '';
if FFolderBox.ItemIndex > 0 then // 0 = tous les dossiers
LFolder := FFolderBox.Items[FFolderBox.ItemIndex];
FFiltered := FVault.Search(FSearch.Text, LFolder);
FList.BeginUpdate;
try
FList.Clear;
for I := 0 to High(FFiltered) do
begin
E := FVault.Entry(FFiltered[I]);
LItem := TListBoxItem.Create(FList);
LItem.Parent := FList;
LItem.Height := 56;
LItem.Tag := FFiltered[I]; // indice dans le coffre, pas dans la liste
// CONTENU CONSTRUIT A LA MAIN, sans passer par Text/Detail/Bitmap ni par
// un StyleLookup. Ces gabarits n'existent pas dans tous les styles :
// avec Dark.style, 'listboxitembottomdetail' disparait et emporte
// l'identifiant, l'icone et la hauteur de ligne. Deux enfants seulement,
// alignes Left et Client - il n'y a alors pas d'ordre a deviner.
if FIcons.TryGetValue(FFiltered[I], LBmp) then
begin
LImg := TImage.Create(LItem);
LImg.Parent := LItem;
LImg.Align := TAlignLayout.Left;
LImg.Width := 40;
LImg.Margins.Rect := RectF(4, 8, 8, 8);
LImg.HitTest := False; // le clic doit atteindre la ligne
LImg.Bitmap.Assign(LBmp);
end;
LBody := TLayout.Create(LItem);
LBody.Parent := LItem;
LBody.Align := TAlignLayout.Client;
LBody.Margins.Rect := RectF(8, 4, 8, 4);
LBody.HitTest := False;
LTitle := TLabel.Create(LBody);
LTitle.Parent := LBody;
LTitle.Align := TAlignLayout.Top;
LTitle.Height := 26;
LTitle.HitTest := False;
LTitle.StyledSettings := LTitle.StyledSettings - [TStyledSetting.Size];
LTitle.TextSettings.Font.Size := 16;
LTitle.Text := E.Display;
// Align=Client sur le second : avec un Top et un Client, la place de
// chacun est determinee, quel que soit l'ordre des enfants.
LSub := TLabel.Create(LBody);
LSub.Parent := LBody;
LSub.Align := TAlignLayout.Client;
LSub.HitTest := False;
LSub.Opacity := 0.6;
LSub.StyledSettings := LSub.StyledSettings - [TStyledSetting.Size];
LSub.TextSettings.Font.Size := 12;
LSub.Text := E.Username;
end;
finally
FList.EndUpdate;
end;
if (FSearch.Text.Trim = '') and (LFolder = '') then
FCount.Text := FVault.LiveCount.ToString + ' entrees'
else
FCount.Text := Length(FFiltered).ToString + ' / ' +
FVault.LiveCount.ToString;
end;
procedure TForm8.OnItemTap(const Sender: TCustomListBox; const AItem: TListBoxItem);
begin
if AItem <> nil then ShowDetail(AItem.Tag);
end;
{ ----------------------------------------------------------------------------
Detail : reveler et copier
---------------------------------------------------------------------------- }
procedure TForm8.OnRevealTap(Sender: TObject);
var
I: Integer;
begin
Touch;
if not (Sender is TButton) then Exit;
I := TButton(Sender).Tag;
if (I < 0) or (I > High(FRows)) then Exit;
FRowShown[I] := not FRowShown[I];
if FRowShown[I] then
begin
FRowValues[I].Text := FRows[I].Value;
TButton(Sender).Text := 'Masquer';
end
else
begin
FRowValues[I].Text := MASK;
TButton(Sender).Text := 'Afficher';
end;
end;
procedure TForm8.OnCopyTap(Sender: TObject);
var
I: Integer;
begin
Touch;
if not (Sender is TButton) then Exit;
I := TButton(Sender).Tag;
// -1 : la ligne du TOTP, qui n'est pas dans FRows - sa valeur change chaque
// periode et ne vit que dans FTotpCode. Copie sans l'espace d'affichage.
if I = -1 then
CopyToClipboard(FTotpCode, 'Code 2FA')
else if (I >= 0) and (I <= High(FRows)) then
CopyToClipboard(FRows[I].Value, FRows[I].Caption);
end;
procedure TForm8.CopyToClipboard(const AText, ALabel: string);
begin
if AText = '' then Exit;
// Marque le contenu sensible : sans cela Android 13+ affiche un apercu de ce
// qui vient d'etre copie, mot de passe compris, en clair et hors de
// l'application.
if not CopySensitive(AText) then Exit;
FCopied := AText;
// Reprogramme depuis zero : deux copies successives donnent au second
// contenu son delai complet, pas le reste de celui du premier.
FClipTimer.Enabled := False;
FClipTimer.Enabled := True;
// ponytail: le message reste jusqu'a la prochaine navigation, pas de minuterie
// pour l'effacer. Un deuxieme TTimer pour deux secondes d'affichage serait
// plus de code que ce que ca apporte.
FDetToast.Text := ALabel + ' copie - presse-papiers efface dans ' +
CLIPBOARD_CLEAR_SECONDS.ToString + ' s';
end;
procedure TForm8.OnClipTimer(Sender: TObject);
begin
FClipTimer.Enabled := False;
if FCopied = '' then Exit;
// Seulement si c'est TOUJOURS notre texte : l'utilisateur a pu copier autre
// chose entre-temps, et le lui effacer serait une surprise.
if CurrentClipboard = FCopied then ClearClipboard;
FCopied := '';
end;
{ ----------------------------------------------------------------------------
Cycle de vie
---------------------------------------------------------------------------- }
function TForm8.HandleAppEvent(AAppEvent: TApplicationEvent;
AContext: TObject): Boolean;
begin
Result := True;
case AAppEvent of
// WillBecomeInactive arrive AVANT la capture d'ecran des applications
// recentes : masquer ici, c'est ne pas y laisser la liste des comptes.
TApplicationEvent.WillBecomeInactive:
if FLayList.Visible or FLayDetail.Visible then
begin
FLayDetail.Visible := False;
FLayList.Visible := False;
FLayUnlock.Visible := True;
end;
// Et le clair est reellement jete quand l'application passe derriere.
TApplicationEvent.EnteredBackground:
if FVault.Count > 0 then LockVault;
end;
end;
{ ----------------------------------------------------------------------------
Journal
---------------------------------------------------------------------------- }
procedure TForm8.Log(const AMsg: string);
begin
// Appele depuis le thread de calcul : la mise a jour d'un controle FMX doit
// repasser par le thread principal.
TThread.Queue(nil,
procedure
begin
FLog.Lines.Add(AMsg);
FLog.GoToTextEnd;
end);
end;
procedure TForm8.Touch;
begin
FLastActivity := Now;
end;
procedure TForm8.OnIdleTimer(Sender: TObject);
begin
// Rien d'ouvert : rien a verrouiller.
if FVault.Count = 0 then
begin
FIdleTimer.Enabled := False;
Exit;
end;
if MinutesBetween(Now, FLastActivity) >= AUTOLOCK_MINUTES then
begin
Log('Verrouille apres ' + AUTOLOCK_MINUTES.ToString + ' min d''inactivite');
LockVault;
end;
end;
procedure TForm8.Status(const AMsg: string);
begin
FStatus.Text := AMsg;
end;
procedure TForm8.SetBusy(ABusy: Boolean);
begin
FBusy := ABusy;
FBtnSync.Enabled := not ABusy;
FBtnOpen.Enabled := not ABusy;
end;
end.
Reference in New Issue View Git Blame Copy Permalink