Zaki/Password-Manager
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
e5eb91cd3f386295821d405627c0d42b3116cb54
Password-Manager/mainApk.pas
T
r-zakarya e5eb91cd3f feat(android): paint the interface instead of wearing a style 
None of the styles Delphi ships is meant for a phone - grey gradients, sharp
corners, thick frames, all from the desktop era. And the day showed that
anything rendered through a style template may not exist in the style that is
actually loaded: the list row template, the search prompt and the detail row
each vanished in turn.

So the buttons are rectangles we draw: slate at rest, cyan for the one action
that matters, rounded, no gradient, with a press feedback a TRectangle does
not have on its own - without it you cannot tell whether the tap landed. The
form's own fill carries the background, the list drops its frame, labels take
the palette.

A style stays loaded underneath, as a base only: edits, list and memo are
native controls we are not going to rewrite, and with no style at all they
would render light.

Palette lives in PMA.Theme, the same slate and cyan as the desktop app.

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

1394 lines
48 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: TRectangle;
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;
FBtnReveal: TRectangle;
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, PMA.Theme;
{$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';
// Le fond de la forme, et non celui du style : tout le reste est peint
// par-dessus, et un gris herite se verrait entre les blocs.
Fill.Kind := TBrushKind.Solid;
Fill.Color := COL_BG;
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 = 52; APrimary: Boolean = False): TRectangle;
begin
Result := FlatButton(AParent, AText, AOnClick, APrimary);
Result.Align := TAlignLayout.Top;
Result.Margins.Rect := RectF(16, 8, 16, 0);
Result.Height := AHeight;
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);
FToken.Margins.Rect := RectF(16, 8, 16, 0);
FUrl.Margins.Rect := RectF(16, 8, 16, 0);
// 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, 40);
FBtnSync := TopButton(FLayUnlock, 'Synchroniser', DoSync);
// Accentue : c'est l'action attendue quand aucun coffre n'est encore la.
FBtnOpen := TopButton(FLayUnlock, 'Ouvrir le coffre', DoOpenLocal, 52, True);
// Pre-rempli depuis le fichier local, jamais depuis ce fichier-ci.
FPwd := TopEdit(FLayUnlock, 'mot de passe de sync', TEST_PWD, True);
FPwd.Margins.Rect := RectF(16, 16, 16, 0);
FStatus := TLabel.Create(Self);
FStatus.Parent := FLayUnlock;
FStatus.Align := TAlignLayout.Top;
FStatus.Margins.Rect := RectF(16, 24, 16, 4);
FStatus.Height := 26;
Tint(FStatus, 15, True);
end;
procedure TForm8.BuildList;
var
LBar, LTop: TLayout;
LBtnLock: TRectangle;
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 := FlatButton(LBar, 'Verrouiller', OnBackTap);
LBtnLock.Align := TAlignLayout.Left;
LBtnLock.Margins.Rect := RectF(16, 4, 0, 8);
LBtnLock.Width := 140;
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, 16, 8);
FCount.TextSettings.HorzAlign := TTextAlign.Trailing;
FCount.TextSettings.VertAlign := TTextAlign.Center;
Tint(FCount, 13, True);
FList := TListBox.Create(Self);
FList.Parent := FLayList;
FList.Align := TAlignLayout.Client;
FList.Margins.Rect := RectF(8, 0, 8, 0);
FList.ItemHeight := 62;
FList.OnItemClick := OnItemTap;
// Sans cadre : la liste est posee sur le fond general, pas dans une boite.
// Le gabarit transparent existe dans les styles livres ; s'il manquait, on
// retomberait simplement sur l'apparence encadree.
FList.StyleLookup := 'transparentlistboxstyle';
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): TRectangle;
begin
Result := FlatButton(ARow, AText, AOnClick);
Result.Align := TAlignLayout.Right;
Result.Margins.Rect := RectF(8, 6, 0, 6);
Result.Width := 96;
Result.Tag := ATag;
end;
procedure TForm8.BuildDetail;
var
LBtnBack: TRectangle;
begin
FLayDetail := TLayout.Create(Self);
FLayDetail.Parent := Self;
FLayDetail.Align := TAlignLayout.Client;
FLayDetail.Visible := False;
LBtnBack := FlatButton(FLayDetail, 'Retour', OnBackTap);
LBtnBack.Align := TAlignLayout.Bottom;
LBtnBack.Height := 52;
LBtnBack.Margins.Rect := RectF(16, 8, 16, 8);
LBtnBack.Tag := 0;
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');
SetButtonText(FBtnSync, 'Synchroniser');
end
else
begin
Status('Aucun coffre local - premier telechargement');
SetButtonText(FBtnSync, '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 TRectangle) and (TRectangle(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 TRectangle) then Exit;
I := TRectangle(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;
SetButtonText(TRectangle(Sender), 'Masquer');
end
else
begin
FRowValues[I].Text := MASK;
SetButtonText(TRectangle(Sender), 'Afficher');
end;
end;
procedure TForm8.OnCopyTap(Sender: TObject);
var
I: Integer;
begin
Touch;
if not (Sender is TRectangle) then Exit;
I := TRectangle(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;
SetButtonEnabled(FBtnSync, not ABusy);
SetButtonEnabled(FBtnOpen, not ABusy);
end;
end.
Reference in New Issue View Git Blame Copy Permalink