Zaki/Password-Manager
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
8dc0840e0321308586f9e84d2a975dc09da49134
Password-Manager/mainApk.pas
T
r-zakarya 8dc0840e03 fix(android): declare FMX's biometric activity, and stop LoadVault from deleting the cache 
The prompt raised ActivityNotFoundException: FMX does not show BiometricPrompt from our NativeActivity, it launches its own BiometricFragmentActivity, which lives in fmx.dex.jar but has to be declared in the manifest. Given a translucent framework theme - it hosts the system dialog and draws nothing itself, and the generated resources contain no AppCompat.

Then the read failed and the cache vanished with no trace. LoadVault sorted 'key lost' from 'not authenticated' on the exception message and deleted the file when it guessed the former - so a wrong guess destroyed the cache and the only record of why. It now reports through LastStoreError and deletes nothing; the caller has the log and the context. OpenLocalNow shows the reason, after ShowUnlock rather than before, which was overwriting it.

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

1227 lines
41 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.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,
PMA.Vault;
const
// Parametres du banc d'essai, pre-remplis pour ne pas les retaper.
//
// 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)}
TEST_URL = 'http://127.0.0.1:8080/server-php/sync.php';
{$ELSE}
TEST_URL = 'http://127.0.0.1/server-php/sync.php';
{$ENDIF}
// Jeton d'un serveur de test local. Il n'authentifie qu'un appareil et ne
// donne acces qu'a du chiffre - mais a remplacer avant toute mise en ligne.
TEST_TOKEN = '8765e5bf426039e9888f44bfbab27d489d12b7dbaaa54c8c695ae6af8b2a820e';
// 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;
// TEST_PWD vient d'un fichier LOCAL, hors depot : il ouvre le coffre entier
// une fois le conteneur telecharge. Absent 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;
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;
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;
{$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;
// 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;
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', TEST_TOKEN);
FUrl := TopEdit(FLaySettings, 'URL de l''endpoint', TEST_URL);
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.TextPrompt := 'Rechercher';
FSearch.OnChangeTracking := OnSearchChanged;
end;
/// Intitule discret au-dessus d'une valeur. Meme forme pour toutes les
/// lignes, y compris celle du TOTP.
function MakeRow(AParent: TFmxObject; const ACaption: string;
out AValue: TLabel): TLayout;
var
LCap: TLabel;
begin
Result := TLayout.Create(nil); // detruite a la main, voir ClearDetailRows
Result.Parent := AParent;
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;
// Defilant : une entree avec dix champs personnalises depasse l'ecran d'un
// telephone, et les lignes ne sont connues qu'a l'ouverture.
FDetBody := TVertScrollBox.Create(Self);
FDetBody.Parent := FLayDetail;
FDetBody.Align := TAlignLayout.Client;
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;
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 := '';
// Detruites explicitement plutot que par DeleteChildren : le conteneur est
// un TVertScrollBox, dont les enfants comprennent ses propres barres.
for LRow in FRowCtls do LRow.Free;
SetLength(FRowCtls, 0);
SetLength(FRowValues, 0);
SetLength(FRowShown, 0);
SetLength(FRows, 0);
end;
procedure TForm8.ShowDetail(AVaultIndex: Integer);
var
LMeta, LPwdCaption: string;
I: 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
ClearDetailRows;
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;
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));
// A REBOURS : des controles alignes en haut s'empilent dans l'ordre inverse
// de leur creation, donc la derniere ligne se cree en premier.
for I := High(FRows) downto 0 do
begin
LRow := MakeRow(FDetBody, FRows[I].Caption, LValue);
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.
if Length(FRowCtls) > 0 then
FRowCtls[High(FRows)].Margins.Bottom := 12;
// Le TOTP est la seule ligne vivante : creee en dernier, donc affichee en
// tete, parce que c'est ce qu'on vient chercher sur un telephone.
if FCurrent.Totp <> '' then
begin
LRow := MakeRow(FDetBody, 'Code 2FA', FTotpValue);
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;
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 := '';
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;
// 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;
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);
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;
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.
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.Text := E.Display;
LItem.ItemData.Detail := E.Username;
LItem.StyleLookup := 'listboxitembottomdetail';
// Le setter copie le bitmap : le cache garde la propriete du sien.
if FIcons.TryGetValue(FFiltered[I], LBmp) then
LItem.ItemData.Bitmap := LBmp;
LItem.Tag := FFiltered[I]; // indice dans le coffre, pas dans la liste
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
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
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);
var
LClip: IFMXClipboardService;
begin
if AText = '' then Exit;
if not TPlatformServices.Current.SupportsPlatformService(
IFMXClipboardService, LClip) then Exit;
LClip.SetClipboard(AText);
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);
var
LClip: IFMXClipboardService;
begin
FClipTimer.Enabled := False;
if FCopied = '' then Exit;
if TPlatformServices.Current.SupportsPlatformService(
IFMXClipboardService, LClip) then
// Seulement si c'est TOUJOURS notre texte : l'utilisateur a pu copier
// autre chose entre-temps, et le lui effacer serait une surprise.
if LClip.GetClipboard.ToString = FCopied then
LClip.SetClipboard('');
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.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